From 484cac208f85be8dd8e4fa2845a78c87154023f8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 16:00:08 +0000 Subject: [PATCH] chore(lms): add filter for personnel- and card numbers --- src/Handler/LMS.hs | 41 +++++++++++++++++++++++++++-------------- 1 file changed, 27 insertions(+), 14 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index d902aed38..1f4821a54 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -381,7 +381,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do cmps <- selectList [] [Asc CompanyId] return $ Map.fromAscList $ fmap (\c -> (entityKey c, c)) cmps let - mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday + -- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" @@ -421,12 +421,12 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do -- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) - , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> - if | Just renewal <- mbRenewal - , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal - E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday - | otherwise -> E.true - ) + -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> + -- if | Just renewal <- mbRenewal + -- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal + -- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday + -- | otherwise -> E.true + -- ) , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do @@ -441,18 +441,31 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do testcrit = maybe testname testnumber $ readMay $ CI.original criterion 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 . E.mkExistsFilter $ \row criterion -> + E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do + E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId + E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId + E.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text))) + `E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text)))) + ) + , 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 + ) ] dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailHdrUI MsgLmsUser mPrev - , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) + [ prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , 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) + , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) - , if isNothing mbRenewal then mempty - else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) + -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) + -- , if isNothing mbRenewal then mempty + -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtCsvEncode = Just DBTCsvEncode