fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): add single lms user modal to qualifications page

Browse Source
This commit is contained in:
Steffen Jost 2023-03-06 15:11:06 +00:00
parent be3fb39171
commit 4f8295d334
16 changed files with 131 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -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

1
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -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

1
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -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

1
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -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

1
routes
View File

@ -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

10
src/Database/Esqueleto/Utils.hs
View File

@ -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

1
src/Foundation/Navigation.hs
View File

@ -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

36
src/Handler/LMS.hs
View File

@ -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")

2
src/Handler/LMS/Userlist.hs
View File

@ -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

2
src/Handler/LMS/Users.hs
View File

@ -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

5
src/Handler/Qualification.hs
View File

@ -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

19
src/Handler/Utils/LMS.hs
View File

@ -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}
|]

8
src/Handler/Utils/Table/Cells.hs
View File

@ -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}) =

4
templates/lms-result.hamlet
View File

@ -4,8 +4,8 @@ $# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
LMS Result
^{lmsTable}
<p>
^{lmsTable}
<p>
<a href=@{directUploadLink}>
_{MsgLmsDirectUpload}

53
templates/lms-user.hamlet
View File

@ -4,5 +4,54 @@ $# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
LMS User
^{lmsTable}
$if null quals
_{MsgQualificationUserNone}
$else
$forall (Entity _ quali, mbQualUsr, mbLmsUsr) <- quals
<section>
<div .container>
<h2>
#{qualificationShorthand quali} - #{qualificationName quali} - #{qualificationSchool quali}
<div .container>
<dl .deflist>
$maybe (Entity _ qualUsr) <- mbQualUsr
<dt .deflist__dt>_{MsgLmsQualificationValidUntil}
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserValidUntil qualUsr)}
$if not (qualificationUserScheduleRenewal qualUsr)
\ #{icon IconNoNotification}
$maybe (qblock) <- qualificationUserBlockedDue qualUsr
<dt .deflist__dt>_{MsgTableQualificationBlockedDue}
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationBlockedDay qblock)}
\ #{icon IconBlocked}
\ #{qualificationBlockedReason qblock}
<dt .deflist__dt>_{MsgTableQualificationLastRefresh}
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserLastRefresh qualUsr)}
<dt .deflist__dt>_{MsgTableQualificationFirstHeld}
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserFirstHeld qualUsr)}
$maybe (Entity _ lmsUsr) <- mbLmsUsr
<dt .deflist__dt>_{MsgTableLmsStarted}
<dd .deflist__dd>^{formatTimeW SelFormatDateTime (lmsUserStarted lmsUsr)}
$maybe _ <- lmsUserStatus lmsUsr
<dt .deflist__dt>_{MsgTableLmsStatus}
<dd .deflist__dd>^{lmsUserStatusWidget lmsUsr}
<dt .deflist__dt>_{MsgTableLmsIdent}
<dd .deflist__dd .email>#{getLmsIdent (lmsUserIdent lmsUsr)}
<dt .deflist__dt>_{MsgTableLmsPin}
<dd .deflist__dd >
<span .email>
#{lmsUserPin lmsUsr}
\ ^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)}
$if lmsUserResetPin lmsUsr
\ #{icon IconReset}
$maybe ts <- lmsUserReceived lmsUsr
<dt .deflist__dt>_{MsgTableLmsReceived}
<dd .deflist__dd>^{formatTimeW SelFormatDateTime ts}
$maybe ts <- lmsUserNotified lmsUsr
<dt .deflist__dt>_{MsgTableLmsNotified}
<dd .deflist__dd>^{formatTimeW SelFormatDateTime ts}
$maybe ts <- lmsUserEnded lmsUsr
<dt .deflist__dt>_{MsgTableLmsEnded}
<dd .deflist__dd>^{formatTimeW SelFormatDateTime ts}

8
templates/lms-userlist.hamlet
View File

@ -1,8 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
LMS Userlist
^{lmsTable}