diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index bb5d645c5..4ec8764fb 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -83,6 +83,7 @@ LmsStatusExpired: Durchgefallen nach Fristablauf LmsStatusSuccess: E#{nonBreakableDash}Learning bestanden LmsStatusPlanned: E#{nonBreakableDash}Learning wird gerade noch eröffnet (nur für Admin sichtbar) LmsStatusDelay: Hinweis: Statusänderung können in seltenen Fällen mehrere Stunden bis zur Anzeige benötigen. +FilterLmsLongValid: Längerfristig gültig FilterLmsValid: Aktuell gültig FilterLmsRenewal: Erneuerung anstehend FilterLmsNotified: Benachrichtigt diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index a31f86360..5707f3e8e 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -83,6 +83,7 @@ LmsStatusExpired: Failed due to expiry LmsStatusSuccess: Passed LmsStatusPlanned: E#{nonBreakableDash}learning is about to be opened soon (visible to Admins only) LmsStatusDelay: Note that status changes may occassionaly require more than a hour to be displayed here. +FilterLmsLongValid: Long-term valid FilterLmsValid: Currently valid FilterLmsRenewal: Renewal due FilterLmsNotified: Notified diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 12f883fe4..7ffe0f542 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -437,12 +437,13 @@ mkLmsTable :: ( Functor h, ToSortable h -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData)) -> DB (FormResult (LmsTableActionData, Set UserId), Widget) mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do - now <- liftIO getCurrentTime -- lookup all companies cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps + now <- liftIO getCurrentTime let + nowaday = utctDay now getCompanyName :: CompanyId -> CompanyName getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure @@ -494,6 +495,16 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do -- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday -- | otherwise -> E.true -- ) + , ("long-valid", + let cutoff = if + | Just refWithin <- qualificationRefreshWithin quali -> computeNewValidDate' (refWithin <> calendarDay) nowaday -- longer valid than renewal + | Just valDuration <- qualificationValidDuration quali -> computeNewValidDate (valDuration `div` 2) nowaday -- or longer valid than half the duration + | otherwise -> computeNewValidDate' (calendarYear <> calendarDay) nowaday -- or a year and a day + -- in FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>. E.val cutoff) . (E.^. QualificationUserValidUntil)) -- for use with boolField + in FilterColumn $ \(queryQualUser -> quser) (getLast -> criterion) -> if -- for use with checkboxField + | Just True <- criterion -> quser E.^. QualificationUserValidUntil E.>=. E.val cutoff + | otherwise -> E.true + ) , ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) , ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do @@ -521,10 +532,11 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumberFraport) , 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) - , prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) - , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) + , prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt boolField' (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "long-valid" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsLongValid) + , prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt boolField' (fslI MsgFilterLmsNotified) + , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) -- , if isNothing mbRenewal then mempty -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) ] diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 61ff4cbb9..05c6c84fd 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -425,25 +425,36 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) - , ("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 + , ("long-valid", + let cutoff = if + | Just refWithin <- qualificationRefreshWithin quali -> computeNewValidDate' (refWithin <> calendarDay) nowaday -- longer valid than renewal + | Just valDuration <- qualificationValidDuration quali -> computeNewValidDate (valDuration `div` 2) nowaday -- or longer valid than half the duration + | otherwise -> computeNewValidDate' (calendarYear <> calendarDay) nowaday -- or a year and a day + in FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>. E.val cutoff) . (E.^. QualificationUserValidUntil)) -- for use with boolField + -- in FilterColumn $ \(queryQualUser -> quser) (getLast -> criterion) -> if -- for use with checkboxField + -- | Just True <- criterion -> quser E.^. QualificationUserValidUntil E.>=. E.val cutoff + -- | otherwise -> E.true ) - , ("tobe-notified", FilterColumn $ \row criterion -> - if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) - | otherwise -> E.true + , ("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 + ) + , ("tobe-notified", FilterColumn $ \row criterion -> if + | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) + | otherwise -> E.true ) , ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev - , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) - , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumberFraport) + , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumberFraport) , fltrAVSCardNosUI mPrev - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) - , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) + , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt boolField' (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "long-valid" . maybePrism _PathPiece) mPrev $ aopt boolField' (fslI MsgFilterLmsLongValid) , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue)