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

@@ -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
+      -- , single ("avs-card"  , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
-            Nothing -> E.false
+      --       Nothing -> E.false
-            Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
+      --       Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
-                E.on     $ usrAvs E.^. UserAvsPersonId  E.==. avsCard E.^. UserAvsCardPersonId  
+      --           E.on     $ usrAvs E.^. UserAvsPersonId  E.==. avsCard E.^. UserAvsCardPersonId  
-                E.where_ $ usrAvs E.^. UserAvsUser      E.==. user    E.^. UserId
+      --           E.where_ $ usrAvs E.^. UserAvsUser      E.==. user    E.^. UserId
-                    E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
+      --               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

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