From 2163ed96d0300b60de34d07e9212fa1d9535578b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 14 Dec 2022 15:37:43 +0100 Subject: [PATCH] chore(lms): disable some content from lms overview page for non-admins --- .../categories/qualification/de-de-formal.msg | 6 ++- .../categories/qualification/en-eu.msg | 6 ++- routes | 10 ++--- src/Handler/LMS.hs | 42 ++++++++++--------- templates/lms-all.hamlet | 14 +++++-- 5 files changed, 48 insertions(+), 30 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index d4211562f..bce996fef 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -80,4 +80,8 @@ MppPin !ident-ok: Pin MppRecipient: Empfänger MppAddress: Adresse MppLang: Sprache -MppBadLanguage: Sprache muss derzeit "de" oder "en" sein. \ No newline at end of file +MppBadLanguage: Sprache muss derzeit "de" oder "en" sein. +LmsAutomaticQueuing n@Natural: Die folgenden Funktionen werden normalerweise einmal pro Tag um #{show n} Uhr ausgeführt. +LmsManualQueuing: Die folgenden Funktionen sollten einmal pro Tag ausgeführt werden. +BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E-Learning anmelden und benachrichtigen +BtnLmsDequeue: Nutzer mit beendetem E-Learning ggf. benachrichtigen und aufräumen \ 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 2e15e3c97..3a95b25bf 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -80,4 +80,8 @@ MppPin: Pin MppRecipient: Recipient MppAddress: Address MppLang: Language -MppBadLanguage: Language currently restricted to "en" or "de". \ No newline at end of file +MppBadLanguage: Language currently restricted to "en" or "de". +LmsAutomaticQueuing n@Natural: The following functions are executed daily at #{show n} o'clock. +LmsManualQueuing: The following functions should be executed daily. +BtnLmsEnqueue: Enqueue users with expiring qualifications for e-learning and notify them. +BtnLmsDequeue: Dequeue users with finished e-learning and notify, if appropriate. \ No newline at end of file diff --git a/routes b/routes index 259feb9a7..3d25760f6 100644 --- a/routes +++ b/routes @@ -294,16 +294,16 @@ -- OSIS CSV Export Demo /lms LmsAllR GET POST !free -- TODO verify that this is ok /lms/#SchoolId LmsSchoolR GET !free -- TODO verify that this is ok -/lms/#SchoolId/#QualificationShorthand LmsR GET POST !free -- TODO Filtering does not work! +/lms/#SchoolId/#QualificationShorthand LmsR GET POST !free -- /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET -- development +/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET -- development only /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST -/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST -- development +/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST -- development only /lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST !development -- TODO: delete this testing URL +/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST -- TODO: delete this testing URL /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST -- development +/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST -- development only /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token /api ApiDocsR GET !free diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index a5468f722..b03e7f8ef 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -50,19 +50,17 @@ single :: (k,a) -> Map k a single = uncurry Map.singleton -- Button only needed here -data ButtonManualLms = LmsEnqueue | LmsDequeue +data ButtonManualLms = BtnLmsEnqueue | BtnLmsDequeue deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonManualLms instance Finite ButtonManualLms nullaryPathPiece ''ButtonManualLms camelToPathPiece +embedRenderMessage ''UniWorX ''ButtonManualLms id instance Button UniWorX ButtonManualLms where - btnLabel LmsEnqueue = "Enqeue" - btnLabel LmsDequeue = "Deqeue" - - btnClasses LmsEnqueue = [BCIsButton, BCPrimary] - btnClasses LmsDequeue = [BCIsButton, BCDefault] + btnClasses BtnLmsEnqueue = [BCIsButton, BCPrimary] + btnClasses BtnLmsDequeue = [BCIsButton, BCDefault] getLmsSchoolR :: SchoolId -> Handler Html @@ -71,19 +69,22 @@ getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPath getLmsAllR, postLmsAllR :: Handler Html getLmsAllR = postLmsAllR postLmsAllR = do - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms) - let btnForm = wrapForm btnWdgt def - { formAction = Just $ SomeRoute LmsAllR - , formEncoding = btnEnctype - , formSubmit = FormNoSubmit - } - case btnResult of - (FormSuccess LmsEnqueue) -> queueJob' JobLmsQualificationsEnqueue - (FormSuccess LmsDequeue) -> queueJob' JobLmsQualificationsDequeue - FormMissing -> return () - _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt" - isAdmin <- hasReadAccessTo AdminR + mbQcheck <- getsYesod $ view _appQualificationCheckHour + -- TODO: Move this functionality elsewhere without the need for `isAdmin` + mbBtnForm <- if not isAdmin then return Nothing else do + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms) + case btnResult of + (FormSuccess BtnLmsEnqueue) -> queueJob' JobLmsQualificationsEnqueue + (FormSuccess BtnLmsDequeue) -> queueJob' JobLmsQualificationsDequeue + FormMissing -> return () + _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt" + return $ Just $ wrapForm btnWdgt def + { formAction = Just $ SomeRoute LmsAllR + , formEncoding = btnEnctype + , formSubmit = FormNoSubmit + } + lmsTable <- runDB $ do view _2 <$> mkLmsAllTable isAdmin siteLayoutMsg MsgMenuQualifications $ do @@ -120,6 +121,7 @@ mkLmsAllTable isAdmin = do return (quali, cactive, cusers) dbtRowKey = (E.^. QualificationId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + adminable = if isAdmin then sortable else \_ _ _ -> mempty dbtColonnade = dbColonnade $ mconcat [ colSchool $ resultAllQualification . _qualificationSchool , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> @@ -147,9 +149,9 @@ mkLmsAllTable isAdmin = do Nothing -> mempty Just sapId | isAdmin -> cellTooltipIcon (Just icn) (text2message sapId) mempty Just _ -> iconCell icn - , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) + , adminable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n - , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal + , adminable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal -- \(view resultAllQualificationTotal -> n) -> wgtCell $ word2widget n ] dbtSorting = mconcat diff --git a/templates/lms-all.hamlet b/templates/lms-all.hamlet index b0cd792f0..b4e5077fd 100644 --- a/templates/lms-all.hamlet +++ b/templates/lms-all.hamlet @@ -4,7 +4,15 @@ $# SPDX-FileCopyrightText: 2022 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later -

- ^{btnForm}

- ^{lmsTable} \ No newline at end of file + ^{lmsTable} + +$maybe btnForm <- mbBtnForm +

+

+ $maybe qcheck <- mbQcheck + _{MsgLmsAutomaticQueuing qcheck} + $nothing + _{MsgLmsManualQueuing} +

+ ^{btnForm} \ No newline at end of file