From 482dbe5c4e680e81eeb7a72c6ef1676a98738851 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 17:38:53 +0100 Subject: [PATCH] chore(dbtable): add FilterColumnIO and proof-of-concept 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. --- src/Handler/Qualification.hs | 25 ++++++++++++++++++------- src/Handler/Utils/Table/Pagination.hs | 26 ++++++++++++++++++++++---- 2 files changed, 40 insertions(+), 11 deletions(-) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 5b2c315af..28ffdecea 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 0bca321ac..d573f139e 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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