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

chore(dbtable): add FilterColumnIO and proof-of-concept

Browse Source 
This commit adds a new type of filter to dbtables in module Pagination. The filter can perform an arbitrary IO action on its arguments before producing an sql/esqueleto filter expression.

Also, we turn some unnecessarily monadic code pure.
This commit is contained in:
Steffen Jost 2024-02-07 17:38:53 +01:00
parent f5d57d9e5e
commit 482dbe5c4e
2 changed files with 40 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/Handler/Qualification.hs
View File

@ -410,13 +410,24 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
, single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
Nothing -> E.false
Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
)
-- , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
-- Nothing -> E.false
-- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
-- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
-- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
-- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
-- )
-- , single ("avs-card" , FilterColumnIO $ \(queryUser -> user) (criterion :: [Text]) -> const (return E.true :: IO (E.SqlExpr (E.Value Bool))) -- putStrLn "******** IT WORKS *****************"
, single ("avs-card" , FilterColumnIO $ \(criteria :: [Text]) ->
case criteria of
[] -> return (const E.true) :: IO (QualificationTableExpr -> E.SqlExpr (E.Value Bool))
xs -> do
putStrLn "******** IT WORKS *****************"
putStrLn $ tshow (length xs) <> ": " <> T.intercalate ", " criteria
putStrLn "******** IT WORKS *****************"
return $ \(queryUser-> user) ->
user E.^. UserFirstName `E.in_` E.vals xs
)
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria

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

@ -22,7 +22,7 @@ module Handler.Utils.Table.Pagination
, SortColumn(..), SortDirection(..)
, SortingSetting(..)
, pattern SortAscBy, pattern SortDescBy
, FilterColumn(..), IsFilterColumn, IsFilterProjected
, FilterColumn(..), IsFilterColumn, IsFilterColumnIO, IsFilterProjected
, mkFilterProjectedPost
, DBTProjFilterPost(..)
, DBRow(..), _dbrOutput, _dbrCount
@ -262,12 +262,18 @@ instance Monoid (DBTProjFilterPost r') where
data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a
| forall a. IsFilterColumnIO t a => FilterColumnIO a
| forall a. IsFilterProjected fs a => FilterProjected a
filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
filterColumn (FilterColumn f) = Just $ filterColumn' f
filterColumn _ = Nothing
filterColumnIO :: FilterColumn t fs -> Maybe ([Text] -> IO (t -> E.SqlExpr (E.Value Bool)))
filterColumnIO (FilterColumnIO f) = Just $ filterColumnIO' f
filterColumnIO _ = Nothing
filterProjected :: FilterColumn t fs -> [Text] -> (fs -> fs)
filterProjected (FilterProjected f) = filterProjected' f
filterProjected _ = const id
@ -287,6 +293,12 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'
class IsFilterColumnIO t a where
filterColumnIO' :: a -> [Text] -> IO (t -> E.SqlExpr (E.Value Bool))
instance IsFilterColumnIO t ([Text] -> IO (t -> E.SqlExpr (E.Value Bool))) where
filterColumnIO' fin args = fin args
class IsFilterProjected fs a where
filterProjected' :: a -> [Text] -> (fs -> fs)
@ -1198,7 +1210,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
sortSql :: _ -> [E.SqlExpr E.OrderBy]
sortSql t = concatMap (\(f, d) -> f d t) $ mapMaybe (\(c, d) -> (, d) <$> sqlSortDirection c) psSorting'
filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool)))
filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool))) -- could there be any reason not to remove Nothing values from the map already here?
filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter'
-- selectPagesize = primarySortSql
@ -1206,6 +1218,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
-- psLimit' = bool PagesizeAll psLimit selectPagesize
filterIO <- case csvMode of
FormSuccess DBCsvImport{} -> return mempty -- don't execute IO actions for unneeded filters upon csv _import_
_other -> liftIO $ forM psFilter' $ \(fc,args) -> mapM ($ args) $ filterColumnIO fc -- TODO: add timeout
rows' <- E.select . E.from $ \t -> do
res <- dbtSQLQuery t
E.orderBy $ sortSql t
@ -1221,9 +1237,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
-> do
E.limit l
E.offset $ psPage * l
Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps -- Note that multiple where_ are indeed concatenated
_other -> return ()
Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql
let filterAppT = Map.foldr (\fc expr -> maybe expr ((: expr) . ($ t)) fc) []
sqlFilters = filterAppT filterIO <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both
unless (null sqlFilters) $ E.where_ $ E.and sqlFilters
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> pure k <*> f v