fix(avs): fix #152 by providing new online avs card filter throughout

src/Handler/LMS.hs

@@ -499,13 +499,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
                 E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                 E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
         )        
-      , single ("avs-card"  , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
+      , fltrAVSCardNos queryUser
-            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 ("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
@@ -515,7 +509,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
       [ fltrUserNameEmailHdrUI MsgLmsUser mPrev    
       , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
       , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
-      , prismAForm (singletonFilter "avs-card" )        mPrev $ aopt textField (fslI MsgAvsCardNo)
+      , fltrAVSCardNosUI mPrev
       , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
       , prismAForm (singletonFilter "ident"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
       , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)

src/Handler/Qualification.hs

@@ -18,8 +18,6 @@ import Import
 import Handler.Utils
 import Handler.Utils.Users
 import Handler.Utils.LMS
-import Handler.Utils.Avs (queryAvsCardNos)
-import Handler.Utils.Concurrent
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
@@ -405,34 +403,13 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
       -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now)
       ]
     dbtFilter = mconcat
-      [ single $ fltrUserNameEmail   queryUser
+      [ single $ fltrUserNameEmail queryUser
       , single ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
               E.from $ \usrAvs -> -- 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
+      , fltrAVSCardNos queryUser
-      --       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"  , FilterColumnHandler $ \case
-          [] -> return (const E.true) :: Handler (QualificationTableExpr -> E.SqlExpr (E.Value Bool))
-          cs -> do
-            let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs
-            toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout
-            maybeTimeoutHandler toutsecs (queryAvsCardNos crds) >>= \case 
-              Nothing               -> addMessageI Error MsgAvsCommunicationTimeout 
-                                    >> return (const E.false)
-              (Just (null -> True)) -> return (const E.false)
-              (Just apids) -> return $ 
-                \(queryUser -> user) ->
-                  E.exists $ E.from $ \usrAvs ->
-                    E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
-                        E.&&.  usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids
-        )
       , 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
@@ -463,7 +440,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
       [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
       , prismAForm (singletonFilter "user-company")                             mPrev $ aopt textField (fslI MsgTableCompany)
       , prismAForm (singletonFilter "personal-number" )                         mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
-      , prismAForm (singletonFilter "avs-card" )                                mPrev $ aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded]))
+      , fltrAVSCardNosUI mPrev
       , prismAForm (singletonFilter "avs-number" )                              mPrev $ aopt textField (fslI MsgAvsPersonNo)            
       , prismAForm (singletonFilter "validity"         . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
       , if isNothing mbRenewal then mempty

src/Handler/Utils/Table/Columns.hs

@@ -8,6 +8,8 @@ module Handler.Utils.Table.Columns where
 
 import Import hiding (link)
 
+import qualified Data.Map as Map
+
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E hiding ((->.))
 import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus, anyFilter)
@@ -21,6 +23,8 @@ import Handler.Utils.Form
 import Handler.Utils.Widgets
 import Handler.Utils.DateTime
 import Handler.Utils.StudyFeatures
+import Handler.Utils.Avs (queryAvsCardNos)
+import Handler.Utils.Concurrent
 
 import qualified Data.CaseInsensitive as CI
 
@@ -801,6 +805,37 @@ fltrCompanyNameNrHdrUI msg mPrev =
   prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr)
 
 
+---------
+-- AVS --
+---------
+
+
+fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k) 
+              => (a -> E.SqlExpr (Entity User)) -> Map k (FilterColumn t fs)
+fltrAVSCardNos queryUser = Map.singleton "avs-card" fch
+  where 
+    fch = FilterColumnHandler $ \case
+      [] -> return (const E.true)
+      cs -> do
+        let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs
+        toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout
+        maybeTimeoutHandler toutsecs (queryAvsCardNos crds) >>= \case 
+          Nothing               -> addMessageI Error MsgAvsCommunicationTimeout 
+                                >> return (const E.false)
+          (Just (null -> True)) -> return (const E.false)
+          (Just apids) -> return $ 
+            \(queryUser -> user) ->
+              E.exists $ E.from $ \usrAvs ->
+                E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
+                    E.&&.  usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids
+
+fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrAVSCardNosUI mPrev = 
+  prismAForm (singletonFilter "avs-card" ) mPrev $ 
+    aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded]))
+
+
+
 ----------------------------
 -- Colonnade manipulation --
 ----------------------------