From 549a9b5d9b909d723bfe4058d6d2aac99cf9b3f3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 May 2022 18:11:47 +0200 Subject: [PATCH 1/4] 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 -- 2.39.2 From 9859d9bbc11483849faedafb0ae8b7bcbe965807 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 20 May 2022 13:57:55 +0200 Subject: [PATCH 2/4] chore(lms): wip add actions to lms table --- src/Handler/LMS.hs | 26 +++++++++++++++++++------- src/Handler/LMS/Result.hs | 2 +- 2 files changed, 20 insertions(+), 8 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index debdf37b6..157fd2add 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -214,8 +214,9 @@ data LmsTableActionData = LmsActNotifyData 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 + -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route precisely heres let + currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday resultDBTable = DBTable{..} @@ -231,7 +232,7 @@ mkLmsTable (Entity qid quali) = do 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? + dbtProj = dbtProjFilteredPostId dbtColonnade = dbColonnade $ mconcat [ colUserNameLinkHdr MsgTableLmsUser AdminUserR , colUserEmail @@ -245,7 +246,7 @@ mkLmsTable (Entity qid quali) = do , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d ] where - i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a + -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg dbtSorting = mconcat [ single $ sortUserNameLink queryUser @@ -310,6 +311,7 @@ mkLmsTable (Entity qid quali) = do let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData)) resultDBTableValidator = def -- & defaultSorting [SortAscBy csvLmsIdent] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -317,10 +319,20 @@ mkLmsTable (Entity qid quali) = do getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do - (lmsTable, quali) <- runDB $ do - qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh - tbl <- view _2 <$> mkLmsTable qent - return (tbl, quali) + ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do + qent <- getBy404 $ SchoolQualificationShort sid qsh + tbl <- mkLmsTable qent + return (tbl, qent) + + formResult lmsRes $ \case + (LmsActNotifyData, selectedUsers) -> do + forM_ selectedUsers $ \uid -> + runDBJobs $ queueDBJob (JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid}) + (LmsActRenewPinData, selectedUsers) -> do + --TODO Dummy, we need a DB action here + forM_ selectedUsers $ \uid -> + runDBJobs $ queueDBJob (JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid}) + let heading = citext2widget $ qualificationName quali siteLayout heading $ do setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 30d999565..6e7fbc6b2 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -268,7 +268,7 @@ postLmsResultDirectR sid qsh = do .| decodeCsv .| foldMC (saveResultCsv qid) 0 case enr of - Left (e :: SomeException) -> do + Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e return (badRequest400, "Exception: " <> tshow e) Right nr -> do -- 2.39.2 From fd35bdc222a4a57ce02469c34c84d61c9b7c09da Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 3 Jun 2022 13:00:04 +0200 Subject: [PATCH 3/4] fix(lms): refactor, fix and generalize mkLmsTable --- src/Handler/LMS.hs | 201 +++++++++++++++++++++++++-------------------- 1 file changed, 110 insertions(+), 91 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 157fd2add..4be9b857e 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -211,29 +211,120 @@ data LmsTableActionData = LmsActNotifyData deriving (Eq, Ord, Read, Show, Generic, Typeable) -mkLmsTable :: Entity Qualification -> DB (FormResult (LmsTableActionData, Set UserId), Widget) -mkLmsTable (Entity qid quali) = do +lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) + , E.SqlExpr (Entity User) + , E.SqlExpr (Maybe (Entity LmsUser)) + ) +lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = 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 + return (qualUser, user, lmsUser) + + +mkLmsTable :: forall h p cols act act'. + ( Functor h, ToSortable h + , Ord act, PathPiece act, RenderMessage UniWorX act + , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols + ) + => Entity Qualification + -> Map act (AForm Handler act') + -> (LmsTableExpr -> E.SqlExpr (E.Value Bool)) + -> cols + -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) + -> DB (FormResult (act', Set UserId), Widget) +mkLmsTable (Entity qid quali) acts restrict cols psValidator = do now <- liftIO getCurrentTime -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route precisely heres let currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) nowaday = utctDay now 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 - 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 - return (qualUser, user, lmsUser) - dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjFilteredPostId - dbtColonnade = dbColonnade $ mconcat + dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q) + dbtRowKey = queryUser >>> (E.^. UserId) + dbtProj = dbtProjFilteredPostId + dbtColonnade = cols + dbtSorting = mconcat + [ single $ sortUserNameLink 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 ("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)) + -- , 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 ("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) + , if isNothing mbRenewal then mempty + else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtIdent :: Text + 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 act', DBFormResult UserId Bool LmsTableData) + -> FormResult ( act', 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 :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData)) + -- resultDBTableValidator = def + -- & defaultSorting [SortAscBy csvLmsIdent] + over _1 postprocess <$> dbTable psValidator DBTable{..} + +getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsR = postLmsR +postLmsR sid qsh = do + ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do + qent <- getBy404 $ SchoolQualificationShort sid qsh + let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) + acts = mconcat + [ singletonMap LmsActNotify $ pure LmsActNotifyData + , singletonMap LmsActRenewPin $ pure LmsActRenewPinData + ] + colChoices = mconcat [ colUserNameLinkHdr MsgTableLmsUser AdminUserR , colUserEmail , sortable (Just "valid-until") (i18nCell MsgTableQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d @@ -248,80 +339,8 @@ mkLmsTable (Entity qid quali) = do 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 ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) - , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) - , 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)) - -- , 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 ("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) - , if isNothing mbRenewal then mempty - else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtIdent :: Text - 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 :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData)) - resultDBTableValidator = def - -- & defaultSorting [SortAscBy csvLmsIdent] - over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable - -getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsR = postLmsR -postLmsR sid qsh = do - ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do - qent <- getBy404 $ SchoolQualificationShort sid qsh - tbl <- mkLmsTable qent + psValidator = def + tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator return (tbl, qent) formResult lmsRes $ \case -- 2.39.2 From 5f936b34078162ca98df42531286e8c6981df631 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Jun 2022 18:06:14 +0200 Subject: [PATCH 4/4] chore(lms): allow renewal of pins and manual notification sending --- .../categories/qualification/de-de-formal.msg | 9 ++-- .../categories/qualification/en-eu.msg | 7 +++- models/lms.model | 3 +- src/Handler/LMS.hs | 42 +++++++++++++------ 4 files changed, 43 insertions(+), 18 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index cf2e48f9b..f59532997 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -44,6 +44,9 @@ LmsDirectUpload: Direkter Upload für automatisierte Systeme LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. 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 +MailLmsRenewalBody: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern. +LmsActNotify: Benachrichtigung E-Lernen erneut per Post oder E-Mail versenden +LmsActRenewPin: Neue zufällige E-Lernen PIN zuweisen +LmsActRenewNotify: Neue zufällige E-Lernen PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden +LmsNotificationSend n@Int: E-Lernen Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet. +LmsPinRenewal n@Int: E-Lernen Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. \ 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 f37eeae58..05c9c95ba 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -45,5 +45,8 @@ LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically 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. -LmsActNotify: Send e-learning notification again -LmsActRenewPin: Randomly replace e-learning PIN \ No newline at end of file +LmsActNotify: Resend e-learning notification by post or email +LmsActRenewPin: Randomly replace e-learning PIN +LmsActRenewNotify: Randomly replace e-learning PIN and re-send notification by post or email +LmsNotificationSend n@Int: E-learning notifications will be sent to #{n} #{pluralEN n "Examinee" "Examinees"} by letter post or by email. +LmsPinRenewal n@Int: E-learning pin replaced randomly for #{n} #{pluralEN n "Examinee" "Examinees"}. \ No newline at end of file diff --git a/models/lms.model b/models/lms.model index 73ebd11a5..7efa55af5 100644 --- a/models/lms.model +++ b/models/lms.model @@ -101,7 +101,8 @@ LmsUser received UTCTime Maybe -- last acknowledgement by LMS ended UTCTime Maybe -- ident was deleted from LMS -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? - UniqueLmsUser ident -- idents must be unique accross all qualifications, since idents are global within LMS! + UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS! + UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course deriving Generic -- LmsUserlist stores LMS upload for later processing only diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 4be9b857e..c0c1a150b 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -20,8 +20,10 @@ import Import import Jobs import Handler.Utils -- import Handler.Utils.Csv --- import Handler.Utils.LMS +import Handler.Utils.LMS + +import qualified Data.Set as Set import qualified Data.Map as Map -- import qualified Data.Csv as Csv -- import qualified Data.Conduit.List as C @@ -197,6 +199,7 @@ instance HasUser LmsTableData where hasUser = resultUser . _entityVal data LmsTableAction = LmsActNotify + | LmsActRenewNotify | LmsActRenewPin deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) @@ -207,9 +210,19 @@ embedRenderMessage ''UniWorX ''LmsTableAction id -- Not yet needed, since there is no additional data for now: data LmsTableActionData = LmsActNotifyData - | LmsActRenewPinData + | LmsActRenewNotifyData + | LmsActRenewPinData deriving (Eq, Ord, Read, Show, Generic, Typeable) +isNotifyAct :: LmsTableActionData -> Bool +isNotifyAct LmsActNotifyData = True +isNotifyAct LmsActRenewNotifyData = True +isNotifyAct LmsActRenewPinData = False + +isRenewPinAct :: LmsTableActionData -> Bool +isRenewPinAct LmsActNotifyData = False +isRenewPinAct LmsActRenewNotifyData = True +isRenewPinAct LmsActRenewPinData = True lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) @@ -321,11 +334,13 @@ postLmsR sid qsh = do qent <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) acts = mconcat - [ singletonMap LmsActNotify $ pure LmsActNotifyData - , singletonMap LmsActRenewPin $ pure LmsActRenewPinData + [ singletonMap LmsActNotify $ pure LmsActNotifyData + , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData + , singletonMap LmsActRenewPin $ pure LmsActRenewPinData ] colChoices = mconcat - [ colUserNameLinkHdr MsgTableLmsUser AdminUserR + [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) + , colUserNameLinkHdr MsgTableLmsUser AdminUserR , 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 @@ -344,13 +359,16 @@ postLmsR sid qsh = do return (tbl, qent) formResult lmsRes $ \case - (LmsActNotifyData, selectedUsers) -> do - forM_ selectedUsers $ \uid -> - runDBJobs $ queueDBJob (JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid}) - (LmsActRenewPinData, selectedUsers) -> do - --TODO Dummy, we need a DB action here - forM_ selectedUsers $ \uid -> - runDBJobs $ queueDBJob (JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid}) + (action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do + runDBJobs $ forM_ selectedUsers $ \uid -> do + when (isRenewPinAct action) $ do + newPin <- liftIO randomLMSpw + updateBy (UniqueLmsQualificationUser qid uid) [LmsUserPin =. newPin] -- must be within its own runDB + when (isNotifyAct action) $ + queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid} + let numExaminees = Set.size selectedUsers + when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees + when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees let heading = citext2widget $ qualificationName quali siteLayout heading $ do -- 2.39.2