refactor(qualification): rework lms view and user lms modal
This commit is contained in:
parent
878f98604c
commit
9abf8b69bf
@ -25,6 +25,8 @@ TableQualificationFirstHeld: Erstmalig
|
||||
TableQualificationBlockedDue: Entzogen
|
||||
TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst?
|
||||
TableQualificationBlockedTooltipSimple: Falls die Qualifikation aus besonderem Grund vorzeitig widerrufen wurde, so wird das Datum des Widerrufs angezeigt
|
||||
InfoQualificationBlockStatus: Besteht aktuell ein Entzug? Falsch bedeutet, dass ein Entzug zuletzt aufgehoben wurde
|
||||
InfoQualificationBlockFrom: Datum der letzten Änderungen eines Entzugs oder der Aufhebung eines Entzugs
|
||||
TableQualificationNoRenewal: Auslaufend
|
||||
TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein.
|
||||
QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte?
|
||||
@ -96,6 +98,7 @@ QualificationActGrant: Qualifikation vergeben
|
||||
QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben.
|
||||
QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
|
||||
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
|
||||
LmsInactive: Aktuell kein E‑Learning aktiv
|
||||
LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach.
|
||||
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden.
|
||||
LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden
|
||||
|
||||
@ -26,6 +26,8 @@ TableQualificationBlockedDue: Revoked
|
||||
TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended?
|
||||
TableQualificationBlockedTooltipSimple: If a date is shown, this qualification has been revoked on that date due to extraordinary reasons
|
||||
TableQualificationNoRenewal: Discontinued
|
||||
InfoQualificationBlockStatus: Is the qualification currently revoked? False indicates, that a revocation had been lifted
|
||||
InfoQualificationBlockFrom: Date of last revocation or lifting of a revocation
|
||||
TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid.
|
||||
QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon?
|
||||
QualificationUserNoRenewal: Expires without further notification
|
||||
@ -96,6 +98,7 @@ QualificationActGrant: Grant qualification
|
||||
QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone.
|
||||
QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked
|
||||
QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
|
||||
LmsInactive: Currently no active e‑learning
|
||||
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.
|
||||
LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only.
|
||||
LmsActNotify: Resend e‑learning notification by post or email
|
||||
|
||||
@ -207,11 +207,12 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
|
||||
, ltcValidUntil :: Day
|
||||
, ltcLastRefresh :: Day
|
||||
, ltcFirstHeld :: Day
|
||||
, ltcBlockedDue :: Maybe QualificationBlocked
|
||||
, ltcLmsIdent :: Maybe LmsIdent
|
||||
, ltcBlockStatus :: Maybe Bool
|
||||
, ltcBlockFrom :: Maybe UTCTime
|
||||
, ltcLmsIdent :: LmsIdent
|
||||
, ltcLmsStatus :: Maybe LmsStatus
|
||||
, ltcLmsStarted :: Maybe UTCTime
|
||||
, ltcLmsDatePin :: Maybe UTCTime
|
||||
, ltcLmsStarted :: UTCTime
|
||||
, ltcLmsDatePin :: UTCTime
|
||||
, ltcLmsReceived :: Maybe UTCTime
|
||||
, ltcLmsNotified :: Maybe UTCTime
|
||||
, ltcLmsEnded :: Maybe UTCTime
|
||||
@ -228,11 +229,12 @@ ltcExample = LmsTableCsv
|
||||
, ltcValidUntil = compDay
|
||||
, ltcLastRefresh = compDay
|
||||
, ltcFirstHeld = compDay
|
||||
, ltcBlockedDue = Nothing
|
||||
, ltcLmsIdent = Nothing
|
||||
, ltcBlockStatus = Nothing
|
||||
, ltcBlockFrom = Nothing
|
||||
, ltcLmsIdent = LmsIdent "abcdefgh"
|
||||
, ltcLmsStatus = Nothing
|
||||
, ltcLmsStarted = Just compTime
|
||||
, ltcLmsDatePin = Nothing
|
||||
, ltcLmsStarted = compTime
|
||||
, ltcLmsDatePin = compTime
|
||||
, ltcLmsReceived = Nothing
|
||||
, ltcLmsNotified = Nothing
|
||||
, ltcLmsEnded = Nothing
|
||||
@ -269,6 +271,8 @@ instance CsvColumnsExplained LmsTableCsv where
|
||||
, ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
|
||||
, ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
|
||||
, ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld)
|
||||
, ('ltcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus)
|
||||
, ('ltcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
|
||||
, ('ltcLmsIdent , SomeMessage MsgTableLmsIdent)
|
||||
, ('ltcLmsStatus , SomeMessage MsgTableLmsStatus)
|
||||
, ('ltcLmsStarted , SomeMessage MsgTableLmsStarted)
|
||||
@ -278,21 +282,25 @@ instance CsvColumnsExplained LmsTableCsv where
|
||||
]
|
||||
|
||||
|
||||
type LmsTableExpr = E.SqlExpr (Entity QualificationUser)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
`E.InnerJoin` E.SqlExpr (Entity LmsUser)
|
||||
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
`E.InnerJoin` E.SqlExpr (Entity LmsUser)
|
||||
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||
|
||||
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
|
||||
queryQualUser = $(sqlIJproj 3 1)
|
||||
queryQualUser = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
|
||||
|
||||
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
|
||||
queryUser = $(sqlIJproj 3 2)
|
||||
queryUser = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
|
||||
|
||||
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser)
|
||||
queryLmsUser = $(sqlIJproj 3 3)
|
||||
queryLmsUser = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
|
||||
|
||||
queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||
queryQualBlock = $(sqlLOJproj 2 2)
|
||||
|
||||
|
||||
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany])
|
||||
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany])
|
||||
|
||||
resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
|
||||
resultQualUser = _dbrOutput . _1
|
||||
@ -303,11 +311,14 @@ resultUser = _dbrOutput . _2
|
||||
resultLmsUser :: Lens' LmsTableData (Entity LmsUser)
|
||||
resultLmsUser = _dbrOutput . _3
|
||||
|
||||
resultQualBlock :: Traversal' LmsTableData (Entity QualificationUserBlock)
|
||||
resultQualBlock = _dbrOutput . _4 . _Just
|
||||
|
||||
resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
|
||||
resultPrintAck = _dbrOutput . _4 . _unValue . _Just
|
||||
resultPrintAck = _dbrOutput . _5 . _unValue . _Just
|
||||
|
||||
resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
|
||||
resultCompanyUser = _dbrOutput . _5
|
||||
resultCompanyUser = _dbrOutput . _6
|
||||
|
||||
instance HasEntity LmsTableData User where
|
||||
hasEntity = resultUser
|
||||
@ -315,6 +326,12 @@ instance HasEntity LmsTableData User where
|
||||
instance HasUser LmsTableData where
|
||||
hasUser = resultUser . _entityVal
|
||||
|
||||
instance HasEntity LmsTableData QualificationUser where
|
||||
hasEntity = resultQualUser
|
||||
|
||||
instance HasQualificationUser LmsTableData where
|
||||
hasQualificationUser = resultQualUser . _entityVal
|
||||
|
||||
data LmsTableAction = LmsActNotify
|
||||
| LmsActRenewNotify
|
||||
| LmsActRenewPin
|
||||
@ -333,6 +350,7 @@ data LmsTableActionData = LmsActNotifyData
|
||||
| LmsActRestartData
|
||||
{ lmsActRestartExtend :: Maybe Integer
|
||||
, lmsActRestartUnblock :: Maybe Bool
|
||||
, lmsActRestartNotify :: Maybe Bool
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
@ -350,18 +368,20 @@ lmsTableQuery :: QualificationId -> LmsTableExpr
|
||||
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
|
||||
, E.SqlExpr (Entity User)
|
||||
, E.SqlExpr (Entity LmsUser)
|
||||
, E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
|
||||
)
|
||||
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do
|
||||
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
|
||||
-- RECALL: another outer join on PrintJob did not work out well, since
|
||||
-- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
|
||||
-- - using notExists on printJob join condition works, but only deliver single value, aggregation can deliver all;
|
||||
-- - using notExists on printJob join condition works, but only delivers single value, while aggregation can deliver all;
|
||||
-- experiments with separate sub-query showed that we would need two subqueries to learn whether the request was indeed the latest
|
||||
E.on $ qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
|
||||
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, which does not work
|
||||
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
||||
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
|
||||
-- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other!
|
||||
E.&&. qualBlock `isLatestBlockBefore` E.now_
|
||||
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
|
||||
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
|
||||
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
|
||||
@ -369,7 +389,7 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do
|
||||
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
|
||||
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this!
|
||||
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
|
||||
return (qualUser, user, lmsUser, printAcknowledged)
|
||||
return (qualUser, user, lmsUser, qualBlock, printAcknowledged)
|
||||
|
||||
|
||||
mkLmsTable :: ( Functor h, ToSortable h
|
||||
@ -395,20 +415,20 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
dbtIdent = "lms"
|
||||
dbtSQLQuery = lmsTableQuery qid
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do
|
||||
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks) -> do
|
||||
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
|
||||
return (qualUsr, usr, lmsUsr, printAcks, cmpUsr)
|
||||
return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr)
|
||||
dbtColonnade = cols cmpMap
|
||||
dbtSorting = mconcat
|
||||
[ single $ sortUserNameLink queryUser
|
||||
, single $ sortUserEmail queryUser
|
||||
, single $ sortUserMatriclenr queryUser
|
||||
, single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
||||
, single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday)
|
||||
, single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
|
||||
, single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
||||
, single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue))
|
||||
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
||||
, single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
||||
-- , single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday)
|
||||
, single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
|
||||
, single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
||||
, single ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
|
||||
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
||||
, single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
|
||||
, single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
|
||||
, single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus))
|
||||
@ -417,7 +437,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
, single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
|
||||
, single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
|
||||
, single ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded))
|
||||
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
, single ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
|
||||
E.orderBy [E.asc (comp E.^. CompanyName)]
|
||||
@ -429,7 +449,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
, single ("ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
|
||||
-- , single ("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 ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
|
||||
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
|
||||
-- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
|
||||
-- if | Just renewal <- mbRenewal
|
||||
-- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
|
||||
@ -496,14 +516,15 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue)
|
||||
<*> preview (resultLmsUser . _entityVal . _lmsUserIdent)
|
||||
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus))
|
||||
<*> preview (resultLmsUser . _entityVal . _lmsUserStarted)
|
||||
<*> preview (resultLmsUser . _entityVal . _lmsUserDatePin)
|
||||
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived))
|
||||
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge
|
||||
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded))
|
||||
<*> preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
|
||||
<*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserIdent)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStatus)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStarted)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserDatePin)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserReceived)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserEnded)
|
||||
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
|
||||
[] -> pure Nothing
|
||||
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
|
||||
@ -560,12 +581,13 @@ postLmsR sid qsh = do
|
||||
, singletonMap LmsActRestart $ LmsActRestartData
|
||||
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
|
||||
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
|
||||
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
|
||||
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
|
||||
<* aformMessage msgRestartWarning
|
||||
]
|
||||
-- lmsStatusLink = toMaybe isAdmin LmsUserR
|
||||
colChoices cmpMap = mconcat
|
||||
[ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is"
|
||||
[ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey))
|
||||
, colUserNameModalHdr MsgLmsUser AdminUserR
|
||||
, colUserEmail
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
|
||||
@ -578,12 +600,12 @@ postLmsR sid qsh = do
|
||||
(\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
|
||||
in wgtCell companies
|
||||
, colUserMatriclenr
|
||||
, sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
||||
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
||||
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( 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 "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
|
||||
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
|
||||
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
|
||||
qualificationValidReasonCell isAdmin nowaday row (row ^? resultQualBlock)
|
||||
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
|
||||
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
|
||||
, sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid
|
||||
@ -650,34 +672,26 @@ postLmsR sid qsh = do
|
||||
|
||||
(LmsActRestartData{..}, selectedUsers) -> do
|
||||
let usersList = Set.toList selectedUsers
|
||||
numUsers = Set.size selectedUsers
|
||||
delUsers <- runDB $ do
|
||||
when (lmsActRestartUnblock == Just True && ) $ do
|
||||
authBy <- maybeAuthId
|
||||
TODO
|
||||
let unblock = toMaybe (lmsActRestartUnblock == Just True) (nowaday, "Manueller LMS Neustart", authBy)
|
||||
unblockUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
|
||||
[ QualificationUserQualification ==. qid
|
||||
, QualificationUserUser <-. usersList
|
||||
, QualificationUserBlockedDue !=. Nothing
|
||||
] []
|
||||
void $ qualificationUserBlocking qid unblockUsers False Nothing
|
||||
when (lmsActRestartUnblock == Just True) $ do
|
||||
oks <- qualificationUserBlocking qid usersList True (Left "Manueller LMS Neustart") (fromMaybe True lmsActRestartNotify)
|
||||
addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers
|
||||
|
||||
whenIsJust lmsActRestartExtend $ \extDays -> do
|
||||
let cutoff = addDays extDays nowaday
|
||||
shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
|
||||
[ QualificationUserQualification ==. qid
|
||||
, QualificationUserUser <-. usersList
|
||||
, QualificationUserBlockedDue ==. Nothing
|
||||
, QualificationUserUser <-. usersList
|
||||
, QualificationUserValidUntil <. cutoff
|
||||
] []
|
||||
forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing Nothing
|
||||
forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
|
||||
|
||||
fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
|
||||
|
||||
runDBJobs $ forM_ selectedUsers $ \uid ->
|
||||
queueDBJob $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
||||
let numUsers = length selectedUsers
|
||||
mStatus = bool Success Warning $ delUsers < numUsers
|
||||
let mStatus = bool Success Warning $ delUsers < numUsers
|
||||
addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers
|
||||
reloadKeepGetParams $ LmsR sid qsh
|
||||
|
||||
@ -714,7 +728,7 @@ getLmsUserR uuid = do
|
||||
uid <- decrypt uuid
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
(user@User{userDisplayName}, quals) <- runDB $ do
|
||||
(user@User{userDisplayName}, quals, qblocks) <- runDB $ do
|
||||
usr <- get404 uid
|
||||
qs <- Ex.select $ do
|
||||
(qual :& qualUsr :& lmsUsr) <-
|
||||
@ -730,9 +744,21 @@ getLmsUserR uuid = do
|
||||
Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser)
|
||||
E.||. E.isJust ( lmsUsr E.?. LmsUserUser)
|
||||
Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand]
|
||||
pure (qual, qualUsr, lmsUsr, validQualification' nowaday qualUsr)
|
||||
return (usr,qs)
|
||||
|
||||
pure (qual, qualUsr, lmsUsr, validQualification' now qualUsr)
|
||||
bs :: Map.Map QualificationUserId [(Entity QualificationUserBlock, Ex.Value (Maybe UserDisplayName), Ex.Value (Maybe UserSurname))]
|
||||
<- foldMapM (\(_, mbqu, _, _) -> case mbqu of
|
||||
Nothing -> pure mempty
|
||||
Just (Entity quid _) -> do
|
||||
blocks <- Ex.select $ do
|
||||
(qBlock :& qbUsr) <- Ex.from $ Ex.table @QualificationUserBlock
|
||||
`Ex.leftJoin` Ex.table @User
|
||||
`Ex.on` (\(qBlock :& qbUsr) -> qBlock Ex.^. QualificationUserBlockBlocker Ex.==. qbUsr Ex.?. UserId)
|
||||
Ex.where_ $ qBlock Ex.^. QualificationUserBlockQualificationUser Ex.==. Ex.val quid
|
||||
Ex.orderBy [Ex.desc (qBlock Ex.^. QualificationUserBlockFrom)]
|
||||
pure (qBlock, qbUsr Ex.?. UserDisplayName, qbUsr Ex.?. UserSurname)
|
||||
return $ Map.singleton quid blocks
|
||||
) qs
|
||||
return (usr,qs,bs)
|
||||
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
|
||||
siteLayout heading $ do
|
||||
setTitle $ toHtml userDisplayName
|
||||
|
||||
@ -30,7 +30,7 @@ import Database.Persist.Sql (updateWhereCount)
|
||||
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
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
@ -152,7 +152,8 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
|
||||
, qtcCompanyNumbers :: CsvSemicolonList Int
|
||||
, qtcValidUntil :: Day
|
||||
, qtcLastRefresh :: Day
|
||||
, qtcBlocked :: Maybe UTCTime
|
||||
, qtcBlockStatus :: Maybe Bool
|
||||
, qtcBlockFrom :: Maybe UTCTime
|
||||
, qtcScheduleRenewal:: Bool
|
||||
, qtcLmsStatusTxt :: Maybe Text
|
||||
, qtcLmsStatusDay :: Maybe Day
|
||||
@ -168,7 +169,8 @@ qtcExample = QualificationTableCsv
|
||||
, qtcCompanyNumbers = CsvSemicolonList [27,69]
|
||||
, qtcValidUntil = compDay
|
||||
, qtcLastRefresh = compDay
|
||||
, qtcBlocked = Nothing
|
||||
, qtcBlockStatus = Nothing
|
||||
, qtcBlockFrom = Nothing
|
||||
, qtcScheduleRenewal= True
|
||||
, qtcLmsStatusTxt = Just "Success"
|
||||
, qtcLmsStatusDay = Just compDay
|
||||
@ -201,7 +203,9 @@ instance CsvColumnsExplained QualificationTableCsv where
|
||||
, ('qtcCompany , SomeMessage MsgTableCompanies)
|
||||
, ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
|
||||
, ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
|
||||
, ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
|
||||
, ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
|
||||
, ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus)
|
||||
, ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
|
||||
, ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
|
||||
, ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus)
|
||||
, ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
|
||||
@ -249,6 +253,16 @@ instance HasEntity QualificationTableData User where
|
||||
instance HasUser QualificationTableData where
|
||||
hasUser = resultUser . _entityVal
|
||||
|
||||
instance HasEntity QualificationTableData QualificationUser where
|
||||
hasEntity = resultQualUser
|
||||
|
||||
instance HasQualificationUser QualificationTableData where
|
||||
hasQualificationUser = resultQualUser . _entityVal
|
||||
|
||||
-- instance HasEntity QualificationUserBlock where
|
||||
-- hasQualificationUserBlock = resultQualBlock
|
||||
|
||||
|
||||
data QualificationTableAction
|
||||
= QualificationActExpire
|
||||
| QualificationActUnexpire
|
||||
@ -325,10 +339,7 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin`
|
||||
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
||||
E.where_ $ fltr qualUser
|
||||
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
|
||||
E.&&. E.notExists (E.from $ \earlierBlock ->
|
||||
E.where_ $ earlierBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
|
||||
E.&&. E.just (earlierBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom
|
||||
)
|
||||
E.&&. qualBlock `isLatestBlockBefore` E.now_
|
||||
return (qualUser, user, lmsUser, qualBlock)
|
||||
|
||||
|
||||
@ -378,7 +389,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
, single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
|
||||
, queryLmsUser row E.?. LmsUserStarted])
|
||||
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
||||
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
, single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
|
||||
E.orderBy [E.asc (comp E.^. CompanyName)]
|
||||
@ -450,6 +461,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
<*> (view resultCompanyUser >>= getCompanyNos)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
||||
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
|
||||
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
|
||||
<*> getStatusPlusTxt
|
||||
@ -573,7 +585,7 @@ postQualificationR sid qsh = do
|
||||
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
|
||||
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
||||
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
|
||||
qualificationValidReasonCell isAdmin nowaday (row ^. resultQualUser) (row ^? resultQualBlock)
|
||||
qualificationValidReasonCell isAdmin nowaday row (row ^? resultQualBlock)
|
||||
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
|
||||
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
|
||||
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
|
||||
@ -590,7 +602,7 @@ postQualificationR sid qsh = do
|
||||
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
||||
reloadKeepGetParams $ QualificationR sid qsh
|
||||
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
|
||||
runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing Nothing
|
||||
runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
|
||||
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
||||
reloadKeepGetParams $ QualificationR sid qsh
|
||||
(action, selectedUsers) | isExpiryAct action -> do
|
||||
|
||||
@ -65,31 +65,37 @@ quserToNotify quser cutoff =
|
||||
)
|
||||
)
|
||||
|
||||
-- condition to ensure that the lastes QualificationUserBlock was picked
|
||||
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
|
||||
isLatestBlockBefore qualBlock cutoff = E.notExists $ do
|
||||
newerBlock <- E.from $ E.table @QualificationUserBlock
|
||||
E.where_ $ newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff
|
||||
E.&&. E.just (newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom
|
||||
E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
|
||||
|
||||
-- TODO: consider replacing `cutoff` by `Database.Esqueleto.PostgreSQL.now_`?
|
||||
|
||||
quserBlockAux :: Bool -> UTCTime -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
||||
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
|
||||
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
||||
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
|
||||
qualUserBlock <- E.from $ E.table @QualificationUserBlock
|
||||
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
|
||||
E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff)
|
||||
E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. cutoff)
|
||||
E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser)
|
||||
E.&&. E.notExists (do
|
||||
qualUserUnblock <- E.from $ E.table @QualificationUserBlock
|
||||
E.where_ $ (qualUserUnblock E.^. QualificationUserBlockUnblock)
|
||||
E.&&. checkQualUserId (qualUserUnblock E.^. QualificationUserBlockQualificationUser)
|
||||
E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
|
||||
E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. cutoff
|
||||
E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
|
||||
)
|
||||
whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock))
|
||||
|
||||
-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked
|
||||
quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
|
||||
quserBlock negCond cutoff qualUser = quserBlockAux negCond cutoff (E.==. (qualUser E.^. QualificationUserId)) Nothing
|
||||
quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing
|
||||
|
||||
-- | Variant of `isBlocked` for outer joins
|
||||
quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
|
||||
quserBlock' negCond cutoff qualUser = quserBlockAux negCond cutoff (E.=?. (qualUser E.?. QualificationUserId)) Nothing
|
||||
quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing
|
||||
|
||||
qualificationValid :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
|
||||
qualificationValid = flip validQualification
|
||||
@ -127,8 +133,8 @@ selectRelevantBlock cutoff quid =
|
||||
------------------------
|
||||
|
||||
|
||||
upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> Maybe (UTCTime, Text, Maybe UserId) -> UserId -> DB () -- may also unblock
|
||||
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal mbUnblockBecause qualificationUserUser = do
|
||||
upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking
|
||||
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
|
||||
Entity quid _ <- upsert
|
||||
QualificationUser
|
||||
{ qualificationUserFirstHeld = qualificationUserLastRefresh
|
||||
@ -144,12 +150,6 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
|
||||
]
|
||||
)
|
||||
|
||||
whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do
|
||||
block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlockFrom ]
|
||||
whenIsJust block $ \qub ->
|
||||
unless (qub ^. _entityVal . _qualificationUserBlockUnblock) $
|
||||
insert_ QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..}
|
||||
|
||||
audit TransactionQualificationUserEdit
|
||||
{ transactionQualificationUser = quid
|
||||
, transactionQualification = qualificationUserQualification
|
||||
@ -264,6 +264,6 @@ qualificationUserUnblockByReason qid uids (qualificationBlockReasonText -> reaso
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids
|
||||
E.&&. quserBlockAux True now (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
|
||||
E.&&. quserBlockAux True (E.val now) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
|
||||
return $ quser E.^. QualificationUserUser
|
||||
qualificationUserBlocking qid (E.unValue <$> toUnblock) True undo_reason notify
|
||||
|
||||
@ -333,29 +333,20 @@ qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd
|
||||
vtd = q ^. hasQualificationUser . _qualificationUserValidUntil
|
||||
|
||||
qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> DBCell m c
|
||||
qualificationValidIconCell d qu qb = iconBoolCell $ isValidQualification d qu qb
|
||||
qualificationValidIconCell d qu qb = blockIcon $ isValidQualification d qu qb
|
||||
where
|
||||
blockIcon = cell . toWidget . iconQualificationBlock
|
||||
|
||||
qualificationValidReasonCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Bool -> Day -> a -> Maybe b -> DBCell m c
|
||||
qualificationValidReasonCell showReason d qu qb = ic <> foldMap blc qb
|
||||
where
|
||||
ic = iconBoolCell $ isValidQualification d qu qb
|
||||
where
|
||||
ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb
|
||||
blc (view hasQualificationUserBlock -> QualificationUserBlock{..})
|
||||
| showReason = spacerCell <> dateCell qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
|
||||
-- TODO: add anchorLink to block history, if user is allowed
|
||||
| qualificationUserBlockUnblock = mempty
|
||||
| otherwise = spacerCell <> dateCell qualificationUserBlockFrom
|
||||
|
||||
-- qualificationBlockedCellNoReason :: IsDBTable m a => QualificationUserBlock -> DBCell m a
|
||||
-- qualificationBlockedCellNoReason QualificationUserBlock{qualificationUserBlockFrom=t, qualificationUserBlockUnblock=unblock} =
|
||||
-- iconBoolCell unblock <> spacerCell <> dateCell d
|
||||
|
||||
-- qualificationBlockedCell :: IsDBTable m a => QualificationUserBlock -> DBCell m a
|
||||
-- qualificationBlockedCell QualificationUserBlock{..}
|
||||
-- | 32 >= length qualificationUserBlockReason = mkCellWith textCell
|
||||
-- | otherwise = mkCellWith modalCell
|
||||
-- where
|
||||
-- mkCellWith c = c qualificationUserBlockReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationUserBlockFrom
|
||||
|
||||
lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
|
||||
lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name
|
||||
where
|
||||
|
||||
@ -1209,11 +1209,12 @@ partitionM crit = ofoldlM dist mempty
|
||||
| okay -> acc `mappend` (opoint x, mempty)
|
||||
| otherwise -> acc `mappend` (mempty, opoint x)
|
||||
|
||||
mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b
|
||||
mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList
|
||||
-- use `foldMapM` instead
|
||||
-- mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b
|
||||
-- mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList
|
||||
|
||||
mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
|
||||
mconcatForM = flip mconcatMapM
|
||||
-- mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
|
||||
-- mconcatForM = flip mconcatMapM
|
||||
|
||||
findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b)
|
||||
findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero
|
||||
|
||||
@ -104,6 +104,7 @@ data Icon
|
||||
| IconRemoveUser
|
||||
| IconReset
|
||||
| IconBlocked
|
||||
| IconCertificate
|
||||
| IconPrintCenter
|
||||
| IconLetter
|
||||
| IconAt
|
||||
@ -191,6 +192,7 @@ iconText = \case
|
||||
IconSubmissionNoUsers -> "user-slash"
|
||||
IconReset -> "undo" -- From fontawesome v6 onwards: "arrow-rotate-left"
|
||||
IconBlocked -> "ban"
|
||||
IconCertificate -> "badge-check"
|
||||
IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk"
|
||||
IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well
|
||||
IconAt -> "at"
|
||||
@ -295,6 +297,10 @@ iconLetterOrEmail :: Bool -> Markup
|
||||
iconLetterOrEmail True = icon IconLetter
|
||||
iconLetterOrEmail False = icon IconAt
|
||||
|
||||
iconQualificationBlock :: Bool -> Markup
|
||||
iconQualificationBlock True = icon IconCertificate
|
||||
iconQualificationBlock False = icon IconBlocked
|
||||
|
||||
----------------
|
||||
-- For documentation on how to avoid these unneccessary functions
|
||||
-- we implement them here just once for the first icon:
|
||||
|
||||
@ -166,7 +166,7 @@ instance HasQualificationUser a => HasQualificationUser (Entity a) where
|
||||
-- hasQualificationUser = _2 . hasQualificationUser
|
||||
|
||||
instance HasQualificationUserBlock a => HasQualificationUserBlock (Entity a) where
|
||||
hasQualificationUser = _entityVal . hasQualificationUserBlock
|
||||
hasQualificationUserBlock = _entityVal . hasQualificationUserBlock
|
||||
|
||||
instance HasLmsUser a => HasLmsUser (Entity a) where
|
||||
hasLmsUser = _entityVal . hasLmsUser
|
||||
|
||||
@ -11,19 +11,33 @@ $else
|
||||
<section>
|
||||
<div .container>
|
||||
<h2>
|
||||
#{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali}) #{boolSymbol (E.unValue validity)}
|
||||
#{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali})
|
||||
<span .#{statusToUrgencyClass (bool Error Success (E.unValue validity))}>
|
||||
#{iconQualificationBlock (E.unValue validity)}
|
||||
<div .container>
|
||||
<dl .deflist>
|
||||
$maybe (Entity _ qualUsr) <- mbQualUsr
|
||||
$maybe (Entity quid qualUsr) <- mbQualUsr
|
||||
<dt .deflist__dt>_{MsgLmsQualificationValidUntil}
|
||||
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserValidUntil qualUsr)}
|
||||
$if not (qualificationUserScheduleRenewal qualUsr)
|
||||
\ #{icon IconNoNotification}
|
||||
$maybe (qblock) <- qualificationUserBlockedDue qualUsr
|
||||
$maybe qblock <- Map.lookup quid qblocks
|
||||
<dt .deflist__dt>_{MsgTableQualificationBlockedDue}
|
||||
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationBlockedDay qblock)}
|
||||
\ #{icon IconBlocked}
|
||||
\ #{qualificationBlockedReason qblock}
|
||||
<dd .deflist__dd>
|
||||
<ul>
|
||||
$forall (Entity _ block, blockerDN, blockerSN) <- qblock
|
||||
<li>
|
||||
^{formatTimeW SelFormatDateTime (view _qualificationUserBlockFrom block)}
|
||||
\ #{iconQualificationBlock (view _qualificationUserBlockUnblock block)}
|
||||
\ #{view _qualificationUserBlockReason block}
|
||||
<p>
|
||||
$maybe bdn <- E.unValue blockerDN
|
||||
$maybe bsn <- E.unValue blockerSN
|
||||
^{nameWidget bdn bsn}
|
||||
$nothing
|
||||
^{text2widget bdn}
|
||||
$nothing
|
||||
?
|
||||
<dt .deflist__dt>_{MsgTableQualificationLastRefresh}
|
||||
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserLastRefresh qualUsr)}
|
||||
<dt .deflist__dt>_{MsgTableQualificationFirstHeld}
|
||||
@ -57,5 +71,6 @@ $else
|
||||
$maybe ts <- lmsUserEnded lmsUsr
|
||||
<dt .deflist__dt>_{MsgTableLmsEnded}
|
||||
<dd .deflist__dd>^{formatTimeW SelFormatDateTime ts}
|
||||
|
||||
|
||||
$nothing
|
||||
<dt .deflist__dt>_{MsgLmsInactive}
|
||||
<dd .deflist__dd>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user