diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index abc8d8bd6..944e8321e 100644 --- a/src/Handler/LMS.hs +++ b/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 - 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) - ) + , fltrAVSCardNos queryUser , 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) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 0005b82b6..93bb5048e 100644 --- a/src/Handler/Qualification.hs +++ b/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 - -- 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 - ) + , fltrAVSCardNos queryUser , 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 diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index c0f768e99..53dce7cb9 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/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 -- ----------------------------