From 5c9a5206dfdc4af4e44b90472e4a85c77775e9f8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 14 Apr 2022 15:05:32 +0200 Subject: [PATCH] chore(lms): fix some malfunctioning filters --- src/Foundation/Navigation.hs | 2 +- src/Handler/LMS.hs | 33 +++++++++++++-------------------- test/Database/Fill.hs | 1 + 3 files changed, 15 insertions(+), 21 deletions(-) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 7be1a4763..ebec4d9e3 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -704,7 +704,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the { navHeaderRole = NavHeaderPrimary , navIcon = IconMenuLms , navLink = NavLink - { navLabel = MsgMenuLms + { navLabel = MsgMenuQualifications , navRoute = LmsAllR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 9c59ed71e..21fb0df59 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -110,12 +110,12 @@ mkLmsAllTable = do dbtFilter = mconcat [ fltrSchool $ to (E.^. QualificationSchool) - , singletonMap "qelearning" . FilterColumn $ E.mkExactFilter (E.^. QualificationElearningStart) + , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) ] dbtFilterUI = mconcat [ fltrSchoolUI - , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsElearning) + , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def @@ -171,14 +171,13 @@ mkLmsTable (Entity qid quali) = do now <- liftIO getCurrentTime let nowaday = utctDay now - _mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday + mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday resultDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do qualUser <- asks queryQualUser user <- asks queryUser lmsUser <- asks queryLmsUser - lift $ do E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser @@ -217,28 +216,22 @@ mkLmsTable (Entity qid quali) = do dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) + -- , 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))) - , mempty - --, maybe mempty (\renewal -> - -- single ("renewal-due" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.<=. E.val renewal) . E.just . (E.^. QualificationUserValidUntil)))) - -- mbRenewal - -- , single $ fltrUserNameEmail queryUser - --("user" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryUser) (E.^. UserDisplayName)) - -- , ("email" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryUser) (E.^. UserEmail)) - -- , (csvLmsIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) - -- , (csvLmsSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + , single ("renewal-due" , FilterColumn $ \(view (to 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 + ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableLmsUser 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 "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) - , mempty - --, if isNothing mbRenewal then mempty - -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) - -- , fltrUserNameEmailUI mPrev - -- prismAForm (singletonFilter "user" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsUser) - --, prismAForm (singletonFilter "email" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableEmail) - -- , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess) + , if isNothing mbRenewal then mempty + else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 72ba41944..8315ac25a 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -469,6 +469,7 @@ fillDb = do void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) + void . insert' $ QualificationUser tinaTester qid_f (n_day $ -33) (n_day $ -60) (n_day $ -250) void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2)