From 4f8295d3344d95ee02f1e6ec5d28d767dc6bb41f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 6 Mar 2023 15:11:06 +0000 Subject: [PATCH] chore(lms): add single lms user modal to qualifications page --- .../categories/qualification/de-de-formal.msg | 1 + .../categories/qualification/en-eu.msg | 1 + .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 1 + src/Database/Esqueleto/Utils.hs | 10 ++++ src/Foundation/Navigation.hs | 1 + src/Handler/LMS.hs | 36 ++++++++++++- src/Handler/LMS/Userlist.hs | 2 +- src/Handler/LMS/Users.hs | 2 +- src/Handler/Qualification.hs | 5 +- src/Handler/Utils/LMS.hs | 19 +++++-- src/Handler/Utils/Table/Cells.hs | 8 ++- templates/lms-result.hamlet | 4 +- templates/lms-user.hamlet | 53 ++++++++++++++++++- templates/lms-userlist.hamlet | 8 --- 16 files changed, 131 insertions(+), 22 deletions(-) delete mode 100644 templates/lms-userlist.hamlet diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 6901a104d..e99f42ec6 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -26,6 +26,7 @@ TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonde TableQualificationNoRenewal: Storniert TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein. QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus +QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. LmsUser: Inhaber TableLmsEmail: E-Mail TableLmsIdent: LMS Identifikation diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 83acfaf45..729511c76 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -26,6 +26,7 @@ TableQualificationBlockedTooltipSimple: When was this qualification revoked due TableQualificationNoRenewal: Canceled TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. QualificationUserNoRenewal: Expires without further notification +QualificationUserNone: No registered qualifications for this person. LmsUser: Licensee TableLmsEmail: Email TableLmsIdent: LMS Identifier diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 7e22bc31c..d008c4b44 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -117,6 +117,7 @@ MenuLanguage: Sprache MenuQualifications: Qualifikationen MenuLms !ident-ok: E-Learning MenuLmsEdit: Bearbeiten E-Learning +MenuLmsUser: Benutzer Qualifikationen MenuLmsUsers: Export E-Learning Benutzer MenuLmsUserlist: Melden E-Learning Benutzer MenuLmsResult: Melden Ergebnisse E-Learning diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index dcc934a38..a5760a1dd 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -118,6 +118,7 @@ MenuLanguage: Language MenuQualifications: Qualifications MenuLms: E-Learning MenuLmsEdit: Edit E-Learning +MenuLmsUser: User Qualifications MenuLmsUsers: Download E-Learning Users MenuLmsUserlist: Upload E-Learning Users MenuLmsResult: Upload E-Learning Results diff --git a/routes b/routes index 448f81452..7599239cb 100644 --- a/routes +++ b/routes @@ -278,6 +278,7 @@ /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST /lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS +/lmsuser/#CryptoUUIDUser LmsUserR GET /api ApiDocsR GET !free diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f88277d09..30f779bf1 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -12,6 +12,7 @@ module Database.Esqueleto.Utils , isInfixOf, hasInfix , strConcat, substring , (=?.), (?=.) + , (=~.), (~=.) , or, and , any, all , subSelectAnd, subSelectOr @@ -123,6 +124,15 @@ infixl 4 ?=. (?=.) :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value Bool) (?=.) a b = a E.==. E.just b +-- | like (=?.) but also succeeds if the right-hand side is NULL. Can often be avoided by moving from where- to join-condition! +infixl 4 =~. +(=~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) +(=~.) a b = E.isNothing b E.||. (E.just a E.==. b) + +infixl 4 ~=. +(~=.) :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value Bool) +(~=.) a b = E.isNothing a E.||. (a E.==. E.just b) + -- | Negation of `isNothing` which is missing isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) isJust = E.not_ . E.isNothing diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 617a3a5a1..6e9986238 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -184,6 +184,7 @@ breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed +breadcrumb (LmsUserR _) = i18nCrumb MsgMenuLmsUser $ Just LmsAllR -- breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index d3b2d8f4d..e32257e53 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -11,12 +11,13 @@ module Handler.LMS , getLmsSchoolR , getLmsR , postLmsR , getLmsEditR , postLmsEditR - , getLmsUsersR , getLmsUsersDirectR + , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR , getLmsResultR , postLmsResultR , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR , getLmsFakeR , postLmsFakeR + , getLmsUserR ) where @@ -34,6 +35,7 @@ import qualified Data.Csv as Csv import qualified Data.Text as T import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.PostgreSQL as E @@ -497,7 +499,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do - isAdmin <- hasReadAccessTo AdminR + isAdmin <- hasReadAccessTo AdminR currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do qent <- getBy404 $ SchoolQualificationShort sid qsh @@ -507,6 +509,7 @@ postLmsR sid qsh = do , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData ] + -- lmsStatusLink = toMaybe isAdmin LmsUserR colChoices = mconcat [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" , colUserNameModalHdr MsgLmsUser AdminUserR @@ -601,3 +604,32 @@ postLmsR sid qsh = do siteLayout heading $ do setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh $(widgetFile "lms") + + +-- intended to be viewed primarily in a modal, vie lmsStatusPlusCell' +getLmsUserR :: CryptoUUIDUser -> Handler Html +getLmsUserR uuid = do + uid <- decrypt uuid + (user@User{userDisplayName}, quals) <- runDB $ do + usr <- get404 uid + qs <- Ex.select $ do + (qual :& qualUsr :& lmsUsr) <- + Ex.from $ Ex.table @Qualification + `Ex.leftJoin` Ex.table @QualificationUser + `Ex.on` (\(qual :& qualUsr) -> qualUsr E.?. QualificationUserUser E.?=. Ex.val uid + E.&&. qualUsr E.?. QualificationUserQualification E.?=. qual Ex.^. QualificationId + ) + `Ex.leftJoin` Ex.table @LmsUser + `Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr E.?. LmsUserUser E.?=. Ex.val uid + E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId + ) + Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser) + E.||. E.isJust ( lmsUsr E.?. LmsUserUser) + pure (qual, qualUsr, lmsUsr) + return (usr,qs) + + let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|] + siteLayout heading $ do + setTitle $ toHtml $ "Qualifkationen " <> userDisplayName + $(widgetFile "lms-user") + -- $(i18nWidgetFile "lms-user") diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 5732e1cd3..a9ccbf942 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -206,7 +206,7 @@ postLmsUserlistR sid qsh = do view _2 <$> mkUserlistTable sid qsh qid siteLayoutMsg MsgMenuLmsUserlist $ do setTitleI MsgMenuLmsUserlist - $(widgetFile "lms-userlist") + lmsTable -- Direct File Upload/Download diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 28ca2613e..8c3f1fe69 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -149,7 +149,7 @@ getLmsUsersR sid qsh = do view _2 <$> mkUserTable sid qsh qid siteLayoutMsg MsgMenuLmsUsers $ do setTitleI MsgMenuLmsUsers - $(widgetFile "lms-user") + lmsTable getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsUsersDirectR sid qsh = do diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 06c54ce6f..98b76d742 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -388,6 +388,7 @@ postQualificationR sid qsh = do [ singletonMap QualificationActExpire $ pure QualificationActExpireData , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData ] + linkLmsUser = toMaybe isAdmin LmsUserR colChoices = mconcat [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameModalHdr MsgLmsUser ForProfileR @@ -400,9 +401,9 @@ postQualificationR sid qsh = do ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification -- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted) -- $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d - -- , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status + -- , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltip (MsgTableLmsStatusTooltip auditMonths)) - $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap lmsStatusPlusCell lu + $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell' linkLmsUser) lu ] psValidator = def & defaultSorting [SortDescBy "blocked-due", SortDescBy "valid-until"] tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 0bf580288..9467a5812 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -19,6 +19,7 @@ module Handler.Utils.LMS , csvFilenameLmsResult , lmsUserToDelete, _lmsUserToDelete , lmsUserToDeleteExpr + , lmsUserStatusWidget , randomLMSIdent, randomLMSIdentBut , randomLMSpw, maxLmsUserIdentRetries ) where @@ -26,7 +27,7 @@ module Handler.Utils.LMS -- general utils for LMS Interface Handlers import Import -import Handler.Utils +import Handler.Utils.DateTime import Handler.Utils.Csv import Data.Csv (HasHeader(..), FromRecord) @@ -100,7 +101,7 @@ makeLmsFilename ftag (citext2lower -> qsh) = do getYMTH :: MonadHandler m => m Text getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime --- | Deceide whether LMS platform should delete an identifier +-- | Decide whether LMS platform should delete an identifier lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus) @@ -110,7 +111,6 @@ lmsUserToDelete LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && _lmsUserToDelete :: Getter LmsUser Bool _lmsUserToDelete = to lmsUserToDelete - -- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y? lengthIdent :: Int @@ -151,3 +151,16 @@ randomLMSpw :: MonadIO m => m Text randomLMSpw = randomText extra lengthPassword where extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters + + +lmsUserStatusWidget :: LmsUser -> Widget +lmsUserStatusWidget LmsUser{lmsUserStatus=Just lStat} = + [whamlet|$newline never + ^{formatTimeW SelFormatDate (lmsStatusDay lStat)} + \ ^{boolSymbol (isLmsSuccess lStat)} + |] +lmsUserStatusWidget LmsUser{lmsUserStarted} = + [whamlet|$newline never + ^{formatTimeW SelFormatDate lmsUserStarted} + \ ^{icon IconWaitingForUser} + |] \ No newline at end of file diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 57eac2418..c9ac58c8b 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -12,7 +12,7 @@ import Handler.Utils.Table.Pagination import Handler.Utils.DateTime import Handler.Utils.Widgets import Handler.Utils.Occurrences - +import Handler.Utils.LMS (lmsUserStatusWidget) type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! @@ -356,6 +356,12 @@ lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat lmsStatusPlusCell LmsUser{lmsUserStarted} = iconCell IconWaitingForUser <> spacerCell <> dateCell lmsUserStarted +lmsStatusPlusCell' :: IsDBTable m a => Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a +lmsStatusPlusCell' Nothing lu = wgtCell $ lmsUserStatusWidget lu +lmsStatusPlusCell' (Just toLink) lu = cell $ do + uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser + modal (lmsUserStatusWidget lu) (Left $ SomeRoute $ toLink uuid) + qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a qualificationBlockedCellNoReason Nothing = mempty qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlockedDay=d}) = diff --git a/templates/lms-result.hamlet b/templates/lms-result.hamlet index 7c47df527..dc4a84f5c 100644 --- a/templates/lms-result.hamlet +++ b/templates/lms-result.hamlet @@ -4,8 +4,8 @@ $# SPDX-FileCopyrightText: 2022 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later -LMS Result -^{lmsTable} +

+ ^{lmsTable}

_{MsgLmsDirectUpload} diff --git a/templates/lms-user.hamlet b/templates/lms-user.hamlet index a507d71b8..13b3c0375 100644 --- a/templates/lms-user.hamlet +++ b/templates/lms-user.hamlet @@ -4,5 +4,54 @@ $# SPDX-FileCopyrightText: 2022 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later -LMS User -^{lmsTable} +$if null quals + _{MsgQualificationUserNone} +$else + $forall (Entity _ quali, mbQualUsr, mbLmsUsr) <- quals +

+
+

+ #{qualificationShorthand quali} - #{qualificationName quali} - #{qualificationSchool quali} +
+
+ $maybe (Entity _ qualUsr) <- mbQualUsr +
_{MsgLmsQualificationValidUntil} +
^{formatTimeW SelFormatDate (qualificationUserValidUntil qualUsr)} + $if not (qualificationUserScheduleRenewal qualUsr) + \ #{icon IconNoNotification} + $maybe (qblock) <- qualificationUserBlockedDue qualUsr +
_{MsgTableQualificationBlockedDue} +
^{formatTimeW SelFormatDate (qualificationBlockedDay qblock)} + \ #{icon IconBlocked} + \ #{qualificationBlockedReason qblock} +
_{MsgTableQualificationLastRefresh} +
^{formatTimeW SelFormatDate (qualificationUserLastRefresh qualUsr)} +
_{MsgTableQualificationFirstHeld} +
^{formatTimeW SelFormatDate (qualificationUserFirstHeld qualUsr)} + + $maybe (Entity _ lmsUsr) <- mbLmsUsr +
_{MsgTableLmsStarted} +
^{formatTimeW SelFormatDateTime (lmsUserStarted lmsUsr)} + $maybe _ <- lmsUserStatus lmsUsr +
_{MsgTableLmsStatus} +
^{lmsUserStatusWidget lmsUsr} +
_{MsgTableLmsIdent} +
#{getLmsIdent (lmsUserIdent lmsUsr)} +
_{MsgTableLmsPin} +
+ + #{lmsUserPin lmsUsr} + \ ^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)} + $if lmsUserResetPin lmsUsr + \ #{icon IconReset} + $maybe ts <- lmsUserReceived lmsUsr +
_{MsgTableLmsReceived} +
^{formatTimeW SelFormatDateTime ts} + $maybe ts <- lmsUserNotified lmsUsr +
_{MsgTableLmsNotified} +
^{formatTimeW SelFormatDateTime ts} + $maybe ts <- lmsUserEnded lmsUsr +
_{MsgTableLmsEnded} +
^{formatTimeW SelFormatDateTime ts} + + diff --git a/templates/lms-userlist.hamlet b/templates/lms-userlist.hamlet deleted file mode 100644 index f2b6171ff..000000000 --- a/templates/lms-userlist.hamlet +++ /dev/null @@ -1,8 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Steffen Jost -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - -LMS Userlist -^{lmsTable}