From 549a9b5d9b909d723bfe4058d6d2aac99cf9b3f3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 May 2022 18:11:47 +0200 Subject: [PATCH] chore(lms): wip actions for lms table --- .../categories/qualification/de-de-formal.msg | 2 + .../categories/qualification/en-eu.msg | 4 +- src/Handler/LMS.hs | 151 ++++++++++-------- 3 files changed, 93 insertions(+), 64 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 9d09d0b63..cf2e48f9b 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -45,3 +45,5 @@ LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, d MailSubjectQualificationRenewal qname@Text: Ihre Qualifikation #{qname} muss demnächst erneuert werden MailSubjectQualificationExpiry qname@Text: Ihre Qualifikation #{qname} läuft demnächst ab MailLmsRenewalBody: Sie müssen diese Qualifikaton demnächst durch einen E-Learning Kurs erneuern. +LmsActNotify: Benachrichtigung E-Lernen erneut versenden +LmsActRenewPin: Neue zufällig E-Lernen PIN setzen \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index c8054d175..f37eeae58 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -44,4 +44,6 @@ LmsDirectUpload: Direct upload for automated Systems LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set. MailSubjectQualificationRenewal qname@Text: Your qualification #{qname} must be renewed shortly MailSubjectQualificationExpiry qname@Text: Your qualification #{qname} expires soon -MailLmsRenewalBody: You will soon need to renew this qualficiation by completing an e-learning course. \ No newline at end of file +MailLmsRenewalBody: You will soon need to renew this qualficiation by completing an e-learning course. +LmsActNotify: Send e-learning notification again +LmsActRenewPin: Randomly replace e-learning PIN \ No newline at end of file diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c4a9d91ef..debdf37b6 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -38,21 +38,21 @@ import Handler.LMS.Result as Handler.LMS single :: (k,a) -> Map k a single = uncurry Map.singleton --- Button only needed here +-- Button only needed here data ButtonManualLms = LmsEnqueue | LmsDequeue deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Universe ButtonManualLms +instance Universe ButtonManualLms instance Finite ButtonManualLms nullaryPathPiece ''ButtonManualLms camelToPathPiece instance Button UniWorX ButtonManualLms where btnLabel LmsEnqueue = "Enqeue" - btnLabel LmsDequeue = "Deqeue" + btnLabel LmsDequeue = "Deqeue" btnClasses LmsEnqueue = [BCIsButton, BCPrimary] btnClasses LmsDequeue = [BCIsButton, BCDefault] - + getLmsSchoolR :: SchoolId -> Handler Html getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)]) @@ -61,26 +61,26 @@ getLmsAllR, postLmsAllR :: Handler Html getLmsAllR = postLmsAllR postLmsAllR = do ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms) - let btnForm = wrapForm btnWdgt def + let btnForm = wrapForm btnWdgt def { formAction = Just $ SomeRoute LmsAllR , formEncoding = btnEnctype , formSubmit = FormNoSubmit } - case btnResult of + case btnResult of (FormSuccess LmsEnqueue) -> queueJob' JobLmsQualificationsEnqueue (FormSuccess LmsDequeue) -> queueJob' JobLmsQualificationsDequeue FormMissing -> return () _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt" lmsTable <- runDB $ do - view _2 <$> mkLmsAllTable + view _2 <$> mkLmsAllTable siteLayoutMsg MsgMenuQualifications $ do setTitleI MsgMenuQualifications $(widgetFile "lms-all") type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) resultAllQualification :: Lens' AllQualificationTableData Qualification -resultAllQualification = _dbrOutput . _1 . _entityVal +resultAllQualification = _dbrOutput . _1 . _entityVal resultAllQualificationActive :: Lens' AllQualificationTableData Word64 resultAllQualificationActive = _dbrOutput . _2 . _unValue @@ -90,46 +90,46 @@ resultAllQualificationTotal = _dbrOutput . _3 . _unValue mkLmsAllTable :: DB (Any, Widget) -mkLmsAllTable = do +mkLmsAllTable = do now <- liftIO getCurrentTime - let + let resultDBTable = DBTable{..} where - dbtSQLQuery quali = do - cusers <- pure . Ex.subSelectCount $ do + dbtSQLQuery quali = do + cusers <- pure . Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser - Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId - cactive <- pure . Ex.subSelectCount $ do + Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId + cactive <- pure . Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser - Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId + Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId E.&&. quser Ex.^. QualificationUserValidUntil Ex.>=. E.val (utctDay now) - -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem - return (quali, cactive, cusers) + -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem + return (quali, cactive, cusers) dbtRowKey = (E.^. QualificationId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtColonnade = dbColonnade $ mconcat [ colSchool $ resultAllQualification . _qualificationSchool - , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> - let qsh = qualificationShorthand quali in + , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> + let qsh = qualificationShorthand quali in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh - , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> + , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> let qsh = qualificationShorthand quali - qnm = qualificationName quali + qnm = qualificationName quali in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qnm , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> maybeCell (qualificationDescription quali) markupCellLargeModal - , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ + , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltip MsgTableDiffDaysTooltip) $ - foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between - , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) + , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) - , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) + , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal -- \(view resultAllQualificationTotal -> n) -> wgtCell $ word2widget n - ] + ] dbtSorting = mconcat [ sortSchool $ to (E.^. QualificationSchool) @@ -149,22 +149,8 @@ mkLmsAllTable = do ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def - {- = DBParamsForm - { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute currentRoute - , dbParamsFormAttrs = [] - , dbParamsFormSubmit = FormSubmit - , dbParamsFormAdditional - = renderAForm FormStandard - $ (, mempty) . First . Just - <$> multiActionA acts (fslI MsgTableAction) Nothing - , dbParamsFormEvaluate = liftHandler . runFormPost - , dbParamsFormResult = id - , dbParamsFormIdent = def - } - -} dbtIdent :: Text - dbtIdent = "qualification-overview" + dbtIdent = "qualification-overview" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] @@ -176,7 +162,7 @@ mkLmsAllTable = do getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsEditR = postLmsEditR +getLmsEditR = postLmsEditR postLmsEditR = error "TODO" @@ -204,18 +190,34 @@ resultUser = _dbrOutput . _2 resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just -instance HasEntity LmsTableData User where - hasEntity = resultUser +instance HasEntity LmsTableData User where + hasEntity = resultUser instance HasUser LmsTableData where hasUser = resultUser . _entityVal -mkLmsTable :: Entity Qualification -> DB (Any, Widget) -mkLmsTable (Entity qid quali) = do +data LmsTableAction = LmsActNotify + | LmsActRenewPin + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe LmsTableAction +instance Finite LmsTableAction +nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''LmsTableAction id + +-- Not yet needed, since there is no additional data for now: +data LmsTableActionData = LmsActNotifyData + | LmsActRenewPinData + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + +mkLmsTable :: Entity Qualification -> DB (FormResult (LmsTableActionData, Set UserId), Widget) +mkLmsTable (Entity qid quali) = do now <- liftIO getCurrentTime + currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute let nowaday = utctDay now - mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday + mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday resultDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do @@ -226,37 +228,37 @@ mkLmsTable (Entity qid quali) = do E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause - E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification + E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification return (qualUser, user, lmsUser) dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtColonnade = dbColonnade $ mconcat [ colUserNameLinkHdr MsgTableLmsUser AdminUserR - , colUserEmail + , colUserEmail , sortable (Just "valid-until") (i18nCell MsgTableQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid , sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d - , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d + , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d - ] - where + ] + where i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg dbtSorting = mconcat [ single $ sortUserNameLink queryUser - , single $ sortUserEmail queryUser + , single $ sortUserEmail queryUser , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) - , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) + , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent)) , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) , single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) - ] + ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) @@ -268,32 +270,55 @@ mkLmsTable (Entity qid quali) = do E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | otherwise -> E.true ) - ] - dbtFilterUI mPrev = mconcat + ] + dbtFilterUI mPrev = mconcat [ 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) , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def dbtIdent :: Text - dbtIdent = "qualification" + dbtIdent = "qualification" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + + acts :: Map LmsTableAction (AForm Handler LmsTableActionData) + acts = mconcat + [ singletonMap LmsActNotify $ pure LmsActNotifyData + , singletonMap LmsActRenewPin $ pure LmsActRenewPinData + ] + postprocess :: FormResult (First LmsTableActionData, DBFormResult UserId Bool (DBRow (Entity User))) -> FormResult (LmsTableActionData, Set UserId) + postprocess inp = do + (First (Just act), usrMap) <- inp + let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap + return (act, usrSet) resultDBTableValidator = def -- & defaultSorting [SortAscBy csvLmsIdent] - dbTable resultDBTableValidator resultDBTable + over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do - (lmsTable, quali) <- runDB $ do - qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh + (lmsTable, quali) <- runDB $ do + qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh tbl <- view _2 <$> mkLmsTable qent return (tbl, quali) let heading = citext2widget $ qualificationName quali