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

refactor(qualification): rework lms view and user lms modal

Browse Source
This commit is contained in:
Steffen Jost 2023-06-27 15:15:32 +00:00
parent 878f98604c
commit 9abf8b69bf
10 changed files with 173 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -25,6 +25,8 @@ TableQualificationFirstHeld: Erstmalig
TableQualificationBlockedDue: Entzogen TableQualificationBlockedDue: Entzogen
TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? 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 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 TableQualificationNoRenewal: Auslaufend
TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein. 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? 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. 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 QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert 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. 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. LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden.
LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden

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

@ -26,6 +26,8 @@ TableQualificationBlockedDue: Revoked
TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? 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 TableQualificationBlockedTooltipSimple: If a date is shown, this qualification has been revoked on that date due to extraordinary reasons
TableQualificationNoRenewal: Discontinued 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. 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? QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon?
QualificationUserNoRenewal: Expires without further notification 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. QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone.
QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked
QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated 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. 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. LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only.
LmsActNotify: Resend e‑learning notification by post or email LmsActNotify: Resend e‑learning notification by post or email

150
src/Handler/LMS.hs
View File

@ -207,11 +207,12 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
, ltcValidUntil :: Day , ltcValidUntil :: Day
, ltcLastRefresh :: Day , ltcLastRefresh :: Day
, ltcFirstHeld :: Day , ltcFirstHeld :: Day
, ltcBlockedDue :: Maybe QualificationBlocked , ltcBlockStatus :: Maybe Bool
, ltcLmsIdent :: Maybe LmsIdent , ltcBlockFrom :: Maybe UTCTime
, ltcLmsIdent :: LmsIdent
, ltcLmsStatus :: Maybe LmsStatus , ltcLmsStatus :: Maybe LmsStatus
, ltcLmsStarted :: Maybe UTCTime , ltcLmsStarted :: UTCTime
, ltcLmsDatePin :: Maybe UTCTime , ltcLmsDatePin :: UTCTime
, ltcLmsReceived :: Maybe UTCTime , ltcLmsReceived :: Maybe UTCTime
, ltcLmsNotified :: Maybe UTCTime , ltcLmsNotified :: Maybe UTCTime
, ltcLmsEnded :: Maybe UTCTime , ltcLmsEnded :: Maybe UTCTime
@ -228,11 +229,12 @@ ltcExample = LmsTableCsv
, ltcValidUntil = compDay , ltcValidUntil = compDay
, ltcLastRefresh = compDay , ltcLastRefresh = compDay
, ltcFirstHeld = compDay , ltcFirstHeld = compDay
, ltcBlockedDue = Nothing , ltcBlockStatus = Nothing
, ltcLmsIdent = Nothing , ltcBlockFrom = Nothing
, ltcLmsIdent = LmsIdent "abcdefgh"
, ltcLmsStatus = Nothing , ltcLmsStatus = Nothing
, ltcLmsStarted = Just compTime , ltcLmsStarted = compTime
, ltcLmsDatePin = Nothing , ltcLmsDatePin = compTime
, ltcLmsReceived = Nothing , ltcLmsReceived = Nothing
, ltcLmsNotified = Nothing , ltcLmsNotified = Nothing
, ltcLmsEnded = Nothing , ltcLmsEnded = Nothing
@ -269,6 +271,8 @@ instance CsvColumnsExplained LmsTableCsv where
, ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil) , ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) , ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld) , ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld)
, ('ltcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus)
, ('ltcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
, ('ltcLmsIdent , SomeMessage MsgTableLmsIdent) , ('ltcLmsIdent , SomeMessage MsgTableLmsIdent)
, ('ltcLmsStatus , SomeMessage MsgTableLmsStatus) , ('ltcLmsStatus , SomeMessage MsgTableLmsStatus)
, ('ltcLmsStarted , SomeMessage MsgTableLmsStarted) , ('ltcLmsStarted , SomeMessage MsgTableLmsStarted)
@ -278,21 +282,25 @@ instance CsvColumnsExplained LmsTableCsv where
] ]
type LmsTableExpr = E.SqlExpr (Entity QualificationUser) type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)
`E.InnerJoin` E.SqlExpr (Entity LmsUser) `E.InnerJoin` E.SqlExpr (Entity LmsUser)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 3 1) queryQualUser = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 3 2) queryUser = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser) 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 :: Lens' LmsTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1 resultQualUser = _dbrOutput . _1
@ -303,11 +311,14 @@ resultUser = _dbrOutput . _2
resultLmsUser :: Lens' LmsTableData (Entity LmsUser) resultLmsUser :: Lens' LmsTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 resultLmsUser = _dbrOutput . _3
resultQualBlock :: Traversal' LmsTableData (Entity QualificationUserBlock)
resultQualBlock = _dbrOutput . _4 . _Just
resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
resultPrintAck = _dbrOutput . _4 . _unValue . _Just resultPrintAck = _dbrOutput . _5 . _unValue . _Just
resultCompanyUser :: Lens' LmsTableData [Entity UserCompany] resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _5 resultCompanyUser = _dbrOutput . _6
instance HasEntity LmsTableData User where instance HasEntity LmsTableData User where
hasEntity = resultUser hasEntity = resultUser
@ -315,6 +326,12 @@ instance HasEntity LmsTableData User where
instance HasUser LmsTableData where instance HasUser LmsTableData where
hasUser = resultUser . _entityVal hasUser = resultUser . _entityVal
instance HasEntity LmsTableData QualificationUser where
hasEntity = resultQualUser
instance HasQualificationUser LmsTableData where
hasQualificationUser = resultQualUser . _entityVal
data LmsTableAction = LmsActNotify data LmsTableAction = LmsActNotify
| LmsActRenewNotify | LmsActRenewNotify
| LmsActRenewPin | LmsActRenewPin
@ -333,6 +350,7 @@ data LmsTableActionData = LmsActNotifyData
| LmsActRestartData | LmsActRestartData
{ lmsActRestartExtend :: Maybe Integer { lmsActRestartExtend :: Maybe Integer
, lmsActRestartUnblock :: Maybe Bool , lmsActRestartUnblock :: Maybe Bool
, lmsActRestartNotify :: Maybe Bool
} }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
@ -350,18 +368,20 @@ lmsTableQuery :: QualificationId -> LmsTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User) , E.SqlExpr (Entity User)
, E.SqlExpr (Entity LmsUser) , 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 , 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 -- 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; -- - 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 -- 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.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.&&. 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.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification 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! -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) 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! 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! 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 E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
return (qualUser, user, lmsUser, printAcknowledged) return (qualUser, user, lmsUser, qualBlock, printAcknowledged)
mkLmsTable :: ( Functor h, ToSortable h mkLmsTable :: ( Functor h, ToSortable h
@ -395,20 +415,20 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
dbtIdent = "lms" dbtIdent = "lms"
dbtSQLQuery = lmsTableQuery qid dbtSQLQuery = lmsTableQuery qid
dbtRowKey = queryUser >>> (E.^. UserId) 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] cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
return (qualUsr, usr, lmsUsr, printAcks, cmpUsr) return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr)
dbtColonnade = cols cmpMap dbtColonnade = cols cmpMap
dbtSorting = mconcat dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser , single $ sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser , single $ sortUserMatriclenr queryUser
, single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday) -- , single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday)
, single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) , single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
, single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) , single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
, single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus)) , 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 ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
, single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date , single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) , 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.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
E.orderBy [E.asc (comp E.^. CompanyName)] 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 ("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 ("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) ((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 -> -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
-- if | Just renewal <- mbRenewal -- if | Just renewal <- mbRenewal
-- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal -- , 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 . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
<*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue) <*> preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
<*> preview (resultLmsUser . _entityVal . _lmsUserIdent) <*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) <*> view (resultLmsUser . _entityVal . _lmsUserIdent)
<*> preview (resultLmsUser . _entityVal . _lmsUserStarted) <*> view (resultLmsUser . _entityVal . _lmsUserStatus)
<*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) <*> view (resultLmsUser . _entityVal . _lmsUserStarted)
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) <*> view (resultLmsUser . _entityVal . _lmsUserDatePin)
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge <*> view (resultLmsUser . _entityVal . _lmsUserReceived)
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) <*> 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 getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
[] -> pure Nothing [] -> pure Nothing
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
@ -560,12 +581,13 @@ postLmsR sid qsh = do
, singletonMap LmsActRestart $ LmsActRestartData , singletonMap LmsActRestart $ LmsActRestartData
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
<* aformMessage msgRestartWarning <* aformMessage msgRestartWarning
] ]
-- lmsStatusLink = toMaybe isAdmin LmsUserR -- lmsStatusLink = toMaybe isAdmin LmsUserR
colChoices cmpMap = mconcat 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 , colUserNameModalHdr MsgLmsUser AdminUserR
, colUserEmail , colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> , 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 (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
in wgtCell companies in wgtCell companies
, colUserMatriclenr , 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 "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 "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 "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b qualificationValidReasonCell isAdmin nowaday row (row ^? resultQualBlock)
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid , sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid
@ -650,34 +672,26 @@ postLmsR sid qsh = do
(LmsActRestartData{..}, selectedUsers) -> do (LmsActRestartData{..}, selectedUsers) -> do
let usersList = Set.toList selectedUsers let usersList = Set.toList selectedUsers
numUsers = Set.size selectedUsers
delUsers <- runDB $ do delUsers <- runDB $ do
when (lmsActRestartUnblock == Just True && ) $ do when (lmsActRestartUnblock == Just True) $ do
authBy <- maybeAuthId oks <- qualificationUserBlocking qid usersList True (Left "Manueller LMS Neustart") (fromMaybe True lmsActRestartNotify)
TODO addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers
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
whenIsJust lmsActRestartExtend $ \extDays -> do whenIsJust lmsActRestartExtend $ \extDays -> do
let cutoff = addDays extDays nowaday let cutoff = addDays extDays nowaday
shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
[ QualificationUserQualification ==. qid [ QualificationUserQualification ==. qid
, QualificationUserUser <-. usersList , QualificationUserUser <-. usersList
, QualificationUserBlockedDue ==. Nothing
, QualificationUserValidUntil <. cutoff , QualificationUserValidUntil <. cutoff
] [] ] []
forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing Nothing forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
runDBJobs $ forM_ selectedUsers $ \uid -> runDBJobs $ forM_ selectedUsers $ \uid ->
queueDBJob $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } queueDBJob $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
let numUsers = length selectedUsers let mStatus = bool Success Warning $ delUsers < numUsers
mStatus = bool Success Warning $ delUsers < numUsers
addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers
reloadKeepGetParams $ LmsR sid qsh reloadKeepGetParams $ LmsR sid qsh
@ -714,7 +728,7 @@ getLmsUserR uuid = do
uid <- decrypt uuid uid <- decrypt uuid
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let nowaday = utctDay now let nowaday = utctDay now
(user@User{userDisplayName}, quals) <- runDB $ do (user@User{userDisplayName}, quals, qblocks) <- runDB $ do
usr <- get404 uid usr <- get404 uid
qs <- Ex.select $ do qs <- Ex.select $ do
(qual :& qualUsr :& lmsUsr) <- (qual :& qualUsr :& lmsUsr) <-
@ -730,9 +744,21 @@ getLmsUserR uuid = do
Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser) Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser)
E.||. E.isJust ( lmsUsr E.?. LmsUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)
Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand] Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand]
pure (qual, qualUsr, lmsUsr, validQualification' nowaday qualUsr) pure (qual, qualUsr, lmsUsr, validQualification' now qualUsr)
return (usr,qs) 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}|] let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
siteLayout heading $ do siteLayout heading $ do
setTitle $ toHtml userDisplayName setTitle $ toHtml userDisplayName

34
src/Handler/Qualification.hs
View File

@ -30,7 +30,7 @@ import Database.Persist.Sql (updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E 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 qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
@ -152,7 +152,8 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
, qtcCompanyNumbers :: CsvSemicolonList Int , qtcCompanyNumbers :: CsvSemicolonList Int
, qtcValidUntil :: Day , qtcValidUntil :: Day
, qtcLastRefresh :: Day , qtcLastRefresh :: Day
, qtcBlocked :: Maybe UTCTime , qtcBlockStatus :: Maybe Bool
, qtcBlockFrom :: Maybe UTCTime
, qtcScheduleRenewal:: Bool , qtcScheduleRenewal:: Bool
, qtcLmsStatusTxt :: Maybe Text , qtcLmsStatusTxt :: Maybe Text
, qtcLmsStatusDay :: Maybe Day , qtcLmsStatusDay :: Maybe Day
@ -168,7 +169,8 @@ qtcExample = QualificationTableCsv
, qtcCompanyNumbers = CsvSemicolonList [27,69] , qtcCompanyNumbers = CsvSemicolonList [27,69]
, qtcValidUntil = compDay , qtcValidUntil = compDay
, qtcLastRefresh = compDay , qtcLastRefresh = compDay
, qtcBlocked = Nothing , qtcBlockStatus = Nothing
, qtcBlockFrom = Nothing
, qtcScheduleRenewal= True , qtcScheduleRenewal= True
, qtcLmsStatusTxt = Just "Success" , qtcLmsStatusTxt = Just "Success"
, qtcLmsStatusDay = Just compDay , qtcLmsStatusDay = Just compDay
@ -201,7 +203,9 @@ instance CsvColumnsExplained QualificationTableCsv where
, ('qtcCompany , SomeMessage MsgTableCompanies) , ('qtcCompany , SomeMessage MsgTableCompanies)
, ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
, ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus)
, ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
, ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
, ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus)
, ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
@ -249,6 +253,16 @@ instance HasEntity QualificationTableData User where
instance HasUser QualificationTableData where instance HasUser QualificationTableData where
hasUser = resultUser . _entityVal 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 data QualificationTableAction
= QualificationActExpire = QualificationActExpire
| QualificationActUnexpire | QualificationActUnexpire
@ -325,10 +339,7 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin`
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ fltr qualUser E.where_ $ fltr qualUser
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
E.&&. E.notExists (E.from $ \earlierBlock -> E.&&. qualBlock `isLatestBlockBefore` E.now_
E.where_ $ earlierBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
E.&&. E.just (earlierBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom
)
return (qualUser, user, lmsUser, qualBlock) 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}" , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
, queryLmsUser row E.?. LmsUserStarted]) , queryLmsUser row E.?. LmsUserStarted])
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , 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.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
E.orderBy [E.asc (comp E.^. CompanyName)] E.orderBy [E.asc (comp E.^. CompanyName)]
@ -450,6 +461,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
<*> (view resultCompanyUser >>= getCompanyNos) <*> (view resultCompanyUser >>= getCompanyNos)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
<*> getStatusPlusTxt <*> getStatusPlusTxt
@ -573,7 +585,7 @@ postQualificationR sid qsh = do
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) , 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 "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> , 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 , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) , 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 addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
reloadKeepGetParams $ QualificationR sid qsh reloadKeepGetParams $ QualificationR sid qsh
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do (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 addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
reloadKeepGetParams $ QualificationR sid qsh reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isExpiryAct action -> do (action, selectedUsers) | isExpiryAct action -> do

32
src/Handler/Utils/Qualification.hs
View File

@ -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_`? -- 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 :: 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)
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
qualUserBlock <- E.from $ E.table @QualificationUserBlock qualUserBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) 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.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser)
E.&&. E.notExists (do E.&&. E.notExists (do
qualUserUnblock <- E.from $ E.table @QualificationUserBlock qualUserUnblock <- E.from $ E.table @QualificationUserBlock
E.where_ $ (qualUserUnblock E.^. QualificationUserBlockUnblock) E.where_ $ (qualUserUnblock E.^. QualificationUserBlockUnblock)
E.&&. checkQualUserId (qualUserUnblock E.^. QualificationUserBlockQualificationUser) 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 E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
) )
whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock)) whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock))
-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked -- | 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 :: 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 -- | Variant of `isBlocked` for outer joins
quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) 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 :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
qualificationValid = flip validQualification 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 :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal mbUnblockBecause qualificationUserUser = do upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
Entity quid _ <- upsert Entity quid _ <- upsert
QualificationUser QualificationUser
{ qualificationUserFirstHeld = qualificationUserLastRefresh { 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 audit TransactionQualificationUserEdit
{ transactionQualificationUser = quid { transactionQualificationUser = quid
, transactionQualification = qualificationUserQualification , transactionQualification = qualificationUserQualification
@ -264,6 +264,6 @@ qualificationUserUnblockByReason qid uids (qualificationBlockReasonText -> reaso
quser <- E.from $ E.table @QualificationUser quser <- E.from $ E.table @QualificationUser
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids 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 return $ quser E.^. QualificationUserUser
qualificationUserBlocking qid (E.unValue <$> toUnblock) True undo_reason notify qualificationUserBlocking qid (E.unValue <$> toUnblock) True undo_reason notify

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

@ -333,29 +333,20 @@ qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd
vtd = q ^. hasQualificationUser . _qualificationUserValidUntil vtd = q ^. hasQualificationUser . _qualificationUserValidUntil
qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> DBCell m c 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 :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Bool -> Day -> a -> Maybe b -> DBCell m c
qualificationValidReasonCell showReason d qu qb = ic <> foldMap blc qb qualificationValidReasonCell showReason d qu qb = ic <> foldMap blc qb
where where
ic = iconBoolCell $ isValidQualification d qu qb ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb
blc (view hasQualificationUserBlock -> QualificationUserBlock{..}) blc (view hasQualificationUserBlock -> QualificationUserBlock{..})
| showReason = spacerCell <> dateCell qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason | showReason = spacerCell <> dateCell qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
-- TODO: add anchorLink to block history, if user is allowed -- TODO: add anchorLink to block history, if user is allowed
| qualificationUserBlockUnblock = mempty | qualificationUserBlockUnblock = mempty
| otherwise = spacerCell <> dateCell qualificationUserBlockFrom | 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 :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name
where where

9
src/Utils.hs
View File

@ -1209,11 +1209,12 @@ partitionM crit = ofoldlM dist mempty
| okay -> acc `mappend` (opoint x, mempty) | okay -> acc `mappend` (opoint x, mempty)
| otherwise -> acc `mappend` (mempty, opoint x) | otherwise -> acc `mappend` (mempty, opoint x)
mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b -- use `foldMapM` instead
mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList -- 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 :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
mconcatForM = flip mconcatMapM -- mconcatForM = flip mconcatMapM
findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b) 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 findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero

6
src/Utils/Icon.hs
View File

@ -104,6 +104,7 @@ data Icon
| IconRemoveUser | IconRemoveUser
| IconReset | IconReset
| IconBlocked | IconBlocked
| IconCertificate
| IconPrintCenter | IconPrintCenter
| IconLetter | IconLetter
| IconAt | IconAt
@ -191,6 +192,7 @@ iconText = \case
IconSubmissionNoUsers -> "user-slash" IconSubmissionNoUsers -> "user-slash"
IconReset -> "undo" -- From fontawesome v6 onwards: "arrow-rotate-left" IconReset -> "undo" -- From fontawesome v6 onwards: "arrow-rotate-left"
IconBlocked -> "ban" IconBlocked -> "ban"
IconCertificate -> "badge-check"
IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk" IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk"
IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well
IconAt -> "at" IconAt -> "at"
@ -295,6 +297,10 @@ iconLetterOrEmail :: Bool -> Markup
iconLetterOrEmail True = icon IconLetter iconLetterOrEmail True = icon IconLetter
iconLetterOrEmail False = icon IconAt iconLetterOrEmail False = icon IconAt
iconQualificationBlock :: Bool -> Markup
iconQualificationBlock True = icon IconCertificate
iconQualificationBlock False = icon IconBlocked
---------------- ----------------
-- For documentation on how to avoid these unneccessary functions -- For documentation on how to avoid these unneccessary functions
-- we implement them here just once for the first icon: -- we implement them here just once for the first icon:

2
src/Utils/Lens.hs
View File

@ -166,7 +166,7 @@ instance HasQualificationUser a => HasQualificationUser (Entity a) where
-- hasQualificationUser = _2 . hasQualificationUser -- hasQualificationUser = _2 . hasQualificationUser
instance HasQualificationUserBlock a => HasQualificationUserBlock (Entity a) where instance HasQualificationUserBlock a => HasQualificationUserBlock (Entity a) where
hasQualificationUser = _entityVal . hasQualificationUserBlock hasQualificationUserBlock = _entityVal . hasQualificationUserBlock
instance HasLmsUser a => HasLmsUser (Entity a) where instance HasLmsUser a => HasLmsUser (Entity a) where
hasLmsUser = _entityVal . hasLmsUser hasLmsUser = _entityVal . hasLmsUser

31
templates/lms-user.hamlet
View File

@ -11,19 +11,33 @@ $else
<section> <section>
<div .container> <div .container>
<h2> <h2>
#{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali}) &nbsp; #{boolSymbol (E.unValue validity)} #{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali}) &nbsp;
<span .#{statusToUrgencyClass (bool Error Success (E.unValue validity))}>
#{iconQualificationBlock (E.unValue validity)}
<div .container> <div .container>
<dl .deflist> <dl .deflist>
$maybe (Entity _ qualUsr) <- mbQualUsr $maybe (Entity quid qualUsr) <- mbQualUsr
<dt .deflist__dt>_{MsgLmsQualificationValidUntil} <dt .deflist__dt>_{MsgLmsQualificationValidUntil}
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserValidUntil qualUsr)} <dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserValidUntil qualUsr)}
$if not (qualificationUserScheduleRenewal qualUsr) $if not (qualificationUserScheduleRenewal qualUsr)
\ #{icon IconNoNotification} \ #{icon IconNoNotification}
$maybe (qblock) <- qualificationUserBlockedDue qualUsr $maybe qblock <- Map.lookup quid qblocks
<dt .deflist__dt>_{MsgTableQualificationBlockedDue} <dt .deflist__dt>_{MsgTableQualificationBlockedDue}
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationBlockedDay qblock)} <dd .deflist__dd>
\ #{icon IconBlocked} <ul>
\ #{qualificationBlockedReason qblock} $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} <dt .deflist__dt>_{MsgTableQualificationLastRefresh}
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserLastRefresh qualUsr)} <dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserLastRefresh qualUsr)}
<dt .deflist__dt>_{MsgTableQualificationFirstHeld} <dt .deflist__dt>_{MsgTableQualificationFirstHeld}
@ -57,5 +71,6 @@ $else
$maybe ts <- lmsUserEnded lmsUsr $maybe ts <- lmsUserEnded lmsUsr
<dt .deflist__dt>_{MsgTableLmsEnded} <dt .deflist__dt>_{MsgTableLmsEnded}
<dd .deflist__dd>^{formatTimeW SelFormatDateTime ts} <dd .deflist__dd>^{formatTimeW SelFormatDateTime ts}
$nothing
<dt .deflist__dt>_{MsgLmsInactive}
<dd .deflist__dd>