fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): fix some malfunctioning filters

Browse Source
This commit is contained in:
Steffen Jost 2022-04-14 15:05:32 +02:00
parent 5f31e10119
commit 5c9a5206df
3 changed files with 15 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Foundation/Navigation.hs
View File

@ -704,7 +704,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
{ navHeaderRole = NavHeaderPrimary { navHeaderRole = NavHeaderPrimary
, navIcon = IconMenuLms , navIcon = IconMenuLms
, navLink = NavLink , navLink = NavLink
{ navLabel = MsgMenuLms { navLabel = MsgMenuQualifications
, navRoute = LmsAllR , navRoute = LmsAllR
, navAccess' = NavAccessTrue , navAccess' = NavAccessTrue
, navType = NavTypeLink { navModal = False } , navType = NavTypeLink { navModal = False }

33
src/Handler/LMS.hs
View File

@ -110,12 +110,12 @@ mkLmsAllTable = do
dbtFilter = mconcat dbtFilter = mconcat
[ [
fltrSchool $ to (E.^. QualificationSchool) fltrSchool $ to (E.^. QualificationSchool)
, singletonMap "qelearning" . FilterColumn $ E.mkExactFilter (E.^. QualificationElearningStart) , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart)
] ]
dbtFilterUI = mconcat dbtFilterUI = mconcat
[ [
fltrSchoolUI 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 } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def dbtParams = def
@ -171,14 +171,13 @@ mkLmsTable (Entity qid quali) = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
nowaday = utctDay now nowaday = utctDay now
_mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
resultDBTable = DBTable{..} resultDBTable = DBTable{..}
where where
dbtSQLQuery = runReaderT $ do dbtSQLQuery = runReaderT $ do
qualUser <- asks queryQualUser qualUser <- asks queryQualUser
user <- asks queryUser user <- asks queryUser
lmsUser <- asks queryLmsUser lmsUser <- asks queryLmsUser
lift $ do lift $ do
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
@ -217,28 +216,22 @@ mkLmsTable (Entity qid quali) = do
dbtFilter = mconcat dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser [ single $ fltrUserNameEmail queryUser
, single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) , 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))) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
, mempty , single ("renewal-due" , FilterColumn $ \(view (to queryQualUser) -> quser) criterion ->
--, maybe mempty (\renewal -> if | Just renewal <- mbRenewal
-- single ("renewal-due" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.<=. E.val renewal) . E.just . (E.^. QualificationUserValidUntil)))) , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
-- mbRenewal E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
-- , single $ fltrUserNameEmail queryUser | otherwise -> E.true
--("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))
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev [ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev
, prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , 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) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
, mempty , if isNothing mbRenewal then mempty
--, if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
-- 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)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def dbtParams = def

1
test/Database/Fill.hs
View File

@ -469,6 +469,7 @@ fillDb = do
void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) 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 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 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 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 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) void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2)