fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Better detect if dbTable-sorting is set by user

Browse Source 
Fixes #113
This commit is contained in:
Gregor Kleen 2018-08-06 16:46:01 +02:00
parent 4840acd38e
commit 8d70518fbb
2 changed files with 85 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

158
src/Handler/Utils/Table/Pagination.hs
View File

@ -124,6 +124,86 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon
| Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is
| otherwise = go (acc, is' . (i:)) is
data PaginationSettings = PaginationSettings
{ psSorting :: [(CI Text, SortDirection)]
, psFilter :: Map (CI Text) [Text]
, psLimit :: Int64
, psPage :: Int64
, psShortcircuit :: Bool
}
makeClassy_ ''PaginationSettings
instance Default PaginationSettings where
def = PaginationSettings
{ psSorting = []
, psFilter = Map.empty
, psLimit = 50
, psPage = 0
, psShortcircuit = False
}
data PaginationInput = PaginationInput
{ piSorting :: Maybe [(CI Text, SortDirection)]
, piFilter :: Maybe (Map (CI Text) [Text])
, piLimit :: Maybe Int64
, piPage :: Maybe Int64
, piShortcircuit :: Bool
}
makeClassy_ ''PaginationInput
piIsUnset :: PaginationInput -> Bool
piIsUnset PaginationInput{..} = and
[ isNothing piSorting
, isNothing piFilter
, isNothing piLimit
, isNothing piPage
, not piShortcircuit
]
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
instance Default (PSValidator m x) where
def = PSValidator $ \DBTable{..} -> \case
Nothing -> def
Just pi -> swap . (\act -> execRWS act pi def) $ do
asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
l <- asks piLimit
case l of
Just l'
| l' <= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
| otherwise -> modify $ \ps -> ps { psLimit = l' }
Nothing -> return ()
asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })
asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s })
defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x
defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable -> injectDefault <*> f dbTable
where
injectDefault x = case x >>= piFilter of
Just _ -> id
Nothing -> set (_2._psFilter) psFilter
defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable -> injectDefault <*> f dbTable
where
injectDefault x = case x >>= piSorting of
Just _ -> id
Nothing -> set (_2._psSorting) psSorting
restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
where
restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
where
restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
data DBRow r = DBRow
{ dbrOutput :: r
@ -173,82 +253,6 @@ data DBTable m x = forall a r r' h i t.
, dbtIdent :: i
}
data PaginationSettings = PaginationSettings
{ psSorting :: [(CI Text, SortDirection)]
, psFilter :: Map (CI Text) [Text]
, psLimit :: Int64
, psPage :: Int64
, psShortcircuit :: Bool
}
instance Default PaginationSettings where
def = PaginationSettings
{ psSorting = []
, psFilter = Map.empty
, psLimit = 50
, psPage = 0
, psShortcircuit = False
}
data PaginationInput = PaginationInput
{ piSorting :: Maybe [(CI Text, SortDirection)]
, piFilter :: Maybe (Map (CI Text) [Text])
, piLimit :: Maybe Int64
, piPage :: Maybe Int64
, piShortcircuit :: Bool
}
piIsUnset :: PaginationInput -> Bool
piIsUnset PaginationInput{..} = and
[ isNothing piSorting
, isNothing piFilter
, isNothing piLimit
, isNothing piPage
, not piShortcircuit
]
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
instance Default (PSValidator m x) where
def = PSValidator $ \DBTable{..} -> \case
Nothing -> def
Just pi -> swap . (\act -> execRWS act pi def) $ do
asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
l <- asks piLimit
case l of
Just l'
| l' <= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
| otherwise -> modify $ \ps -> ps { psLimit = l' }
Nothing -> return ()
asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })
asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s })
defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x
defaultFilter psFilter (runPSValidator -> f) = PSValidator g
where
g dbTable Nothing = over _2 (\s -> s { psFilter }) $ f dbTable Nothing
g dbTable x = f dbTable x
defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
defaultSorting psSorting (runPSValidator -> f) = PSValidator g
where
g dbTable Nothing = over _2 (\s -> s { psSorting }) $ f dbTable Nothing
g dbTable x = f dbTable x
restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
where
restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
where
restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where
type DBResult m x :: *
-- type DBResult' m x :: *
@ -368,7 +372,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
psResult <- runInputGetResult $ PaginationInput
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
<*> ((\m -> m <$ guard (not $ Map.null m)) . Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
<*> ((assertM' $ not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
<*> iopt intField (wIdent "pagesize")
<*> iopt intField (wIdent "page")
<*> ireq checkBoxField (wIdent "table-only")

7
src/Utils.hs
View File

@ -303,9 +303,10 @@ guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f
assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
assertM f x = do
x' <- x
x' <$ guard (f x')
assertM f x = x >>= assertM' f
assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
assertM' f x = x <$ guard (f x)
-- Some Utility Functions from Agda.Utils.Monad
-- | Monadic if-then-else.