diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 9d09d0b63..f59532997 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -44,4 +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. +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 c8054d175..05c9c95ba 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -44,4 +44,9 @@ 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: 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 c4a9d91ef..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 @@ -38,21 +40,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 +63,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 +92,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 +151,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 +164,7 @@ mkLmsAllTable = do getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsEditR = postLmsEditR +getLmsEditR = postLmsEditR postLmsEditR = error "TODO" @@ -204,98 +192,184 @@ 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 + | LmsActRenewNotify + | 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 + | 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) + , 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 -- TODO: or dbtProjSimple what is the difference? - dbtColonnade = dbColonnade $ mconcat - [ colUserNameLinkHdr MsgTableLmsUser AdminUserR - , colUserEmail + mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday + 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 LmsActRenewNotify $ pure LmsActRenewNotifyData + , singletonMap LmsActRenewPin $ pure LmsActRenewPinData + ] + colChoices = mconcat + [ 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 , 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 - 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 } - dbtParams = def - dbtIdent :: Text - dbtIdent = "qualification" - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - dbtExtraReps = [] + where + -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a + i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg + psValidator = def + tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator + return (tbl, qent) - resultDBTableValidator = def - -- & defaultSorting [SortAscBy csvLmsIdent] - 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 - tbl <- view _2 <$> mkLmsTable qent - return (tbl, quali) + formResult lmsRes $ \case + (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 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