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

chore(lms): qualifications view for supervisors

Browse Source
This commit is contained in:
Steffen Jost 2023-02-06 20:05:23 +01:00
parent cc070ed21b
commit 80e5dad4aa
16 changed files with 170 additions and 292 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -9,14 +9,14 @@ QualificationValidDuration: Gültigkeitsdauer
QualificationAuditDuration: Aufbewahrung Audit Log
QualificationRefreshWithin: Erneurerungszeitraum
QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des E-Learning
QualificationElearningStart: E-Learning automatisch starten
QualificationElearningStart: Wird das E-Learning automatisch gestartet?
TableQualificationCountActive: Aktive
TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation
TableQualificationCountTotal: Gesamt
TableQualificationIsAvsLicence: AVS
TableQualificationIsAvsLicenceTooltip: Wird die Qualifikation mit dem AVS synchronisiert? Wenn ja, als welche Qualifikation? Betrifft nur Benutzer mit AVS PersonenID.
TableQualificationIsAvsLicenceTooltip: Unter welchem Namen wird diese Qualifikation mit dem Ausweisverwaltungssystem (AVS) synchronisiert? Betrifft nur Benutzer mit AVS PersonenID.
TableQualificationSapExport: SAP
TableQualificationSapExportTooltip: Wird die Qualifikation an SAP übermittelt? Betrifft nur Benutzer mit Fraport Personalnummer.
TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermittelt? Betrifft nur Benutzer mit Fraport Personalnummer.
LmsQualificationValidUntil: Gültig bis
TableQualificationLastRefresh: Zuletzt erneuert
TableQualificationFirstHeld: Erstmalig
@ -66,6 +66,10 @@ MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort
MailBodyQualificationRenewal qname@Text: Sie müssen die Qualifikation #{qname} demnächst durch einen E-Learning Kurs erneuern, siehe Anhang.
MailBodyQualificationExpiry: Diese Qualifikation läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden!
MailBodyQualificationExpired: Diese Qualifikation is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E-Learning.
QualificationActExpire: Qualifikation ohne Benachrichtigung auslaufen lassen
QualificationActUnexpire: Benachrichtigung bei anstehender Erneuerung senden
QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E-Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"}
QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E-Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"}
LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort Ihre 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
@ -74,6 +78,7 @@ LmsActRenewNotify: Neue zufällige E-Learning PIN zuweisen und Benachrichtigung
LmsNotificationSend n@Int: E-Learning Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet.
LmsPinRenewal n@Int: E-Learning Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}.
LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen.
LmsStarted: E-Learning eröffnet
MppOpening: Anrede
MppClosing: Grußformel
MppSupervisor: Ansprechpartner

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

@ -9,7 +9,7 @@ QualificationValidDuration: Validity period
QualificationAuditDuration: Audit log keept
QualificationRefreshWithin: Refresh within
QualificationRefreshWithinTooltip: Period before expiry to send a notification or to start e-learning
QualificationElearningStart: Start e-learning automatically
QualificationElearningStart: Is e-learning automatically started?
TableQualificationCountActive: Active
TableQualificationCountActiveTooltip: Number of currently valid qualification holders
TableQualificationCountTotal: Total
@ -66,14 +66,19 @@ MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid
MailBodyQualificationRenewal qname: You will soon need to renew qualification #{qname} by completing an e-learning course. For details see attachment.
MailBodyQualificationExpiry: This qualification expires soon. You may then no longer execute any duties that require this qualification as a precondition!
MailBodyQualificationExpired: This qualification is now expired. You may no longer execute any duties that require this qualification as a precondition! It is possible that the qualification expired prematurely, e.g. due to a failed compulsory e-learning.
QualificationActExpire: Qualification shall expire silently
QualificationActUnexpire: Notify upon due renewal
QualificationSetExpire n: Expiry notification and e-learning deactivated for #{n} #{pluralENs n "person"}
QualificationSetUnexpire n: Expiry notification and e-learning activated for #{n} #{pluralENs n "person"}
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with your chosen FRADrive PDF-Password. If you have not yet chosen a PDF-Password yet, then the password is your Fraport id card number, inkluding 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
LmsActRenewPin: Randomly replace e-learning PIN
LmsActRenewNotify: Randomly replace e-learning PIN and re-send notification by post or email
LmsNotificationSend n@Int: E-learning notifications will be sent to #{n} #{pluralENs n "examinee"} by letter post or by email.
LmsPinRenewal n@Int: E-learning pin replaced randomly for #{n} #{pluralENs n "examinee"}.
LmsActionFailed n@Int: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.
LmsNotificationSend n: E-learning notifications will be sent to #{n} #{pluralENs n "examinee"} by letter post or by email.
LmsPinRenewal n: E-learning pin replaced randomly for #{n} #{pluralENs n "examinee"}.
LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.
LmsStarted: E-learning open since
MppOpening: Opening
MppClosing: Closing
MppSupervisor: Supervisor

6
routes
View File

@ -259,9 +259,9 @@
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect
-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists
/qualification QualificationAllR GET !free
/qualification/#SchoolId QualificationSchoolR GET !free
/qualification/#SchoolId/#QualificationShorthand QualificationR GET !free
/qualification QualificationAllR GET !free
/qualification/#SchoolId QualificationSchoolR GET !free
/qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free
/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement
-- /qualification/CryptoUUIDUser/ -- maybe distingquish via URL

4
src/Handler/Admin/Avs.hs
View File

@ -507,8 +507,8 @@ mkLicenceTable PaginationParameters{..} dbtIdent aLic apids = do
return (usrAvs, user, qualUser, qual)
dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
-- Not sure what changes here:
-- dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali)
dbtProj = dbtProjFilteredPostId
dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali)
-- dbtProj = dbtProjFilteredPostId
dbtColonnade = mconcat
[ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
-- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal

8
src/Handler/LMS.hs
View File

@ -123,7 +123,7 @@ mkLmsAllTable isAdmin = do
-- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
return (quali, cactive, cusers)
dbtRowKey = (Ex.^. QualificationId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference?
adminable = if isAdmin then sortable else \_ _ _ -> mempty
dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool
@ -214,7 +214,7 @@ makeLenses_ ''LmsTableCsv
ltcExample :: LmsTableCsv
ltcExample = LmsTableCsv
{ ltcDisplayName = "Max Mustermann"
, ltcEmail = "m.mustermann@does.not.exist"
, ltcEmail = "m.mustermann@example.com"
, ltcValidUntil = compDay
, ltcLastRefresh = compDay
, ltcFirstHeld = compDay
@ -528,8 +528,8 @@ postLmsLSR sid qsh nlimit noffset
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
, sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status
, sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
, sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status
, sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d
, sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d
, sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d

6
src/Handler/Profile.hs
View File

@ -588,14 +588,16 @@ makeProfileData (Entity uid User{..}) = do
E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
let supervisors = intersperse (text2widget ", ") $
let numSupervisors = length supervisors'
supervisors = intersperse (text2widget ", ") $
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
icnReroute = text2widget " " <> toWgt (icon IconLetter)
supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
let supervisees = intersperse (text2widget ", ") $
let numSupervisees = length supervisees'
supervisees = intersperse (text2widget ", ") $
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
-- icnReroute = text2widget " " <> toWgt (icon IconLetter)
--Tables

380
src/Handler/Qualification.hs
View File

@ -9,13 +9,13 @@
module Handler.Qualification
( getQualificationAllR
, getQualificationSchoolR
, getQualificationR
, getQualificationR, postQualificationR
)
where
import Import
import Jobs
-- import Jobs
import Handler.Utils
-- import Handler.Utils.Csv
-- import Handler.Utils.LMS
@ -27,9 +27,10 @@ import qualified Data.Csv as Csv
import qualified Data.Text as T
import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.List as C
import Database.Persist.Sql (updateWhereCount)
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
@ -87,7 +88,7 @@ mkQualificationAllTable = do
Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser
return (quali, cactive, cusers)
dbtRowKey = (Ex.^. QualificationId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference?
dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
@ -149,39 +150,27 @@ mkQualificationAllTable = do
-- getQualificationEditR = postQualificationEditR
-- postQualificationEditR = error "TODO"
data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
{ ltcDisplayName :: UserDisplayName
, ltcEmail :: UserEmail
, ltcValidUntil :: Day
, ltcLastRefresh :: Day
, ltcFirstHeld :: Day
, ltcBlockedDue :: Maybe QualificationBlocked
, ltcLmsIdent :: Maybe LmsIdent
, ltcLmsStatus :: Maybe LmsStatus
, ltcLmsStarted :: Maybe UTCTime
, ltcLmsDatePin :: Maybe UTCTime
, ltcLmsReceived :: Maybe UTCTime
, ltcLmsNotified :: Maybe UTCTime
, ltcLmsEnded :: Maybe UTCTime
data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
{ qtcDisplayName :: UserDisplayName
, qtcEmail :: UserEmail
, qtcValidUntil :: Day
, qtcLastRefresh :: Day
, qtcBlocked :: Maybe Day
, qtcLmsStarted :: Maybe UTCTime
, qtcLmsStatus :: Maybe LmsStatus
}
deriving Generic
makeLenses_ ''LmsTableCsv
makeLenses_ ''QualificationTableCsv
ltcExample :: LmsTableCsv
ltcExample = LmsTableCsv
{ ltcDisplayName = "Max Mustermann"
, ltcEmail = "m.mustermann@does.not.exist"
, ltcValidUntil = compDay
, ltcLastRefresh = compDay
, ltcFirstHeld = compDay
, ltcBlockedDue = Nothing
, ltcLmsIdent = Nothing
, ltcLmsStatus = Nothing
, ltcLmsStarted = Just compTime
, ltcLmsDatePin = Nothing
, ltcLmsReceived = Nothing
, ltcLmsNotified = Nothing
, ltcLmsEnded = Nothing
qtcExample :: QualificationTableCsv
qtcExample = QualificationTableCsv
{ qtcDisplayName = "Max Mustermann"
, qtcEmail = "m.mustermann@example.com"
, qtcValidUntil = compDay
, qtcLastRefresh = compDay
, qtcBlocked = Nothing
, qtcLmsStarted = Just compTime
, qtcLmsStatus = Nothing
}
where
compTime :: UTCTime
@ -189,208 +178,139 @@ ltcExample = LmsTableCsv
compDay :: Day
compDay = utctDay compTime
ltcOptions :: Csv.Options
ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
qtcOptions :: Csv.Options
qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
where
renameLtc "ltcDisplayName" = "licensee"
renameLtc "ltcLmsDatePin" = prefixLms "pin-created"
renameLtc "ltcLmsReceived" = prefixLms "last-update"
renameLtc "qtcDisplayName" = "licensee"
renameLtc other = replaceLtc $ camelToPathPiece' 1 other
replaceLtc ('l':'m':'s':'-':t) = prefixLms t
replaceLtc other = other
prefixLms = ("e-learn-" <>)
instance Csv.ToNamedRecord LmsTableCsv where
toNamedRecord = Csv.genericToNamedRecord ltcOptions
instance Csv.ToNamedRecord QualificationTableCsv where
toNamedRecord = Csv.genericToNamedRecord qtcOptions
instance Csv.DefaultOrdered LmsTableCsv where
headerOrder = Csv.genericHeaderOrder ltcOptions
instance Csv.DefaultOrdered QualificationTableCsv where
headerOrder = Csv.genericHeaderOrder qtcOptions
instance CsvColumnsExplained LmsTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
[ ('ltcDisplayName, MsgLmsUser)
, ('ltcEmail , MsgTableLmsEmail)
, ('ltcValidUntil , MsgLmsQualificationValidUntil)
, ('ltcLastRefresh, MsgTableQualificationLastRefresh)
, ('ltcFirstHeld , MsgTableQualificationFirstHeld)
, ('ltcLmsIdent , MsgTableLmsIdent)
, ('ltcLmsStatus , MsgTableLmsStatus)
, ('ltcLmsStarted , MsgTableLmsStarted)
, ('ltcLmsDatePin , MsgTableLmsDatePin)
, ('ltcLmsReceived, MsgTableLmsReceived)
, ('ltcLmsEnded , MsgTableLmsEnded)
instance CsvColumnsExplained QualificationTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
[ ('qtcDisplayName, MsgLmsUser)
, ('qtcEmail , MsgTableLmsEmail)
, ('qtcValidUntil , MsgLmsQualificationValidUntil)
, ('qtcLastRefresh, MsgTableQualificationLastRefresh)
, ('qtcLmsStarted , MsgLmsStarted)
, ('qtcLmsStatus , MsgTableLmsStatus)
]
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1)
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser = $(sqlLOJproj 2 2)
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), E.Value (Maybe [Maybe UTCTime]))
type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser))
resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1
resultUser :: Lens' LmsTableData (Entity User)
resultUser :: Lens' QualificationTableData (Entity User)
resultUser = _dbrOutput . _2
resultLmsUser :: Traversal' LmsTableData (Entity LmsUser)
resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just
resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
resultPrintAck = _dbrOutput . _4 . _unValue . _Just
instance HasEntity LmsTableData User where
instance HasEntity QualificationTableData User where
hasEntity = resultUser
instance HasUser LmsTableData where
instance HasUser QualificationTableData where
hasUser = resultUser . _entityVal
data LmsTableAction = LmsActNotify
| LmsActRenewNotify
| LmsActRenewPin
data QualificationTableAction = QualificationActExpire | QualificationActUnexpire
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe LmsTableAction
instance Finite LmsTableAction
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LmsTableAction id
instance Universe QualificationTableAction
instance Finite QualificationTableAction
nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''QualificationTableAction id
-- Not yet needed, since there is no additional data for now:
data LmsTableActionData = LmsActNotifyData
| LmsActRenewNotifyData
| LmsActRenewPinData -- no longer used
data QualificationTableActionData = QualificationActExpireData | QualificationActUnexpireData
deriving (Eq, Ord, Read, Show, Generic)
isNotifyAct :: LmsTableActionData -> Bool
isNotifyAct LmsActNotifyData = True
isNotifyAct LmsActRenewNotifyData = True
isNotifyAct LmsActRenewPinData = False
isExpiryAct :: QualificationTableActionData -> Bool -- const true, but this may change in the future
isExpiryAct QualificationActExpireData = True
isExpiryAct QualificationActUnexpireData = True
isRenewPinAct :: LmsTableActionData -> Bool
isRenewPinAct LmsActNotifyData = False
isRenewPinAct LmsActRenewNotifyData = True
isRenewPinAct LmsActRenewPinData = True
lmsTableQuery :: QualificationId -> LmsTableExpr -> Int64 -> Int64
qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser))
, 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.LeftOuterJoin` lmsUser) nlimit noffset = 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 noExsists on printJob join condition works, but only deliver single value;
-- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest
qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
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
when (nlimit > 0) $ E.limit nlimit >> E.offset (nlimit * noffset) -- FIXME Pagination does not work here somehow
-- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other!
-- 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)
E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser))
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)
E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
return (qualUser, user, lmsUser)
newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool }
instance Default LmsTableFilterProj where
def = LmsTableFilterProj
{ ltProjFilterMayAccess = Nothing }
makeLenses_ ''LmsTableFilterProj
mkLmsTable :: forall h p cols act act'.
mkQualificationTable ::
( Functor h, ToSortable h
, Ord act, PathPiece act, RenderMessage UniWorX act
, AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols
, AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols
)
=> Int64 -> Int64
-> Bool
-> Entity Qualification
-> Map act (AForm Handler act')
=> Entity Qualification
-> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-> cols
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
-> DB (FormResult (act', Set UserId), Widget)
mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
-> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
-> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
mkQualificationTable (Entity qid quali) acts cols psValidator = do
svs <- getSupervisees
now <- liftIO getCurrentTime
-- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here
currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute
let
currentRoute = QualificationR (qualificationSchool quali) (qualificationShorthand quali)
nowaday = utctDay now
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
dbtIdent :: Text
dbtIdent = "qualification"
dbtSQLQuery q = lmsTableQuery qid q nlimit noffset
fltrSvs = \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
dbtSQLQuery q = qualificationTableQuery qid fltrSvs q
dbtRowKey = queryUser >>> (E.^. UserId)
--dbtProj = dbtProjFilteredPostId
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
qusr <- view $ _dbtProjRow . resultQualUser
user <- view $ _dbtProjRow . resultUser
lusr <- preview $ _dbtProjRow . resultLmsUser
pjac <- preview $ _dbtProjRow . resultPrintAck
forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do
euid <- encrypt $ user ^. _entityKey
guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfileDataR euid -- TODO create a page with proper rights; this is only for admins!
return (qusr,user,lusr,E.Value pjac)
dbtProj = dbtProjFilteredPostId
dbtColonnade = cols
dbtSorting = mconcat
[ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
, single ("schedule-renew", SortColumn $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent))
, single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
, single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
, single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin))
, single ("lms-received" , SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived))
, single ("lms-notified" , SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded))
, single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
]
dbtFilter = mconcat
[ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny)
, single $ fltrUserNameEmail queryUser
, single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent))
-- , single ("lms-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 $ fltrUserNameEmail queryUser
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
if | Just renewal <- mbRenewal
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true
)
, single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
)
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
-- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
, prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
, if isNothing mbRenewal then mempty
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
]
@ -401,55 +321,45 @@ mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
, dbtCsvName = csvName
, dbtCsvSheetName = csvName
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const $ return $ Csv.headerOrder ltcExample
, dbtCsvExampleData = Just [ltcExample]
, dbtCsvHeader = const $ return $ Csv.headerOrder qtcExample
, dbtCsvExampleData = Just [qtcExample]
}
where
doEncode' :: LmsTableData -> LmsTableCsv
doEncode' = LmsTableCsv
doEncode' :: QualificationTableData -> QualificationTableCsv
doEncode' = QualificationTableCsv
<$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userEmail)
<*> 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))
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
-- <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue . _qualificationBlockedDay)
<*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay)
<*> 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))
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus))
dbtCsvDecode = Nothing
dbtExtraReps = []
dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
DBParamsForm
dbtExtraReps = []
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
= renderAForm FormStandard
$ (, mempty) . First . Just
$ (, mempty) . First . Just
<$> multiActionA acts (fslI MsgTableAction) Nothing
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
-- acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
-- acts = mconcat
-- [ singletonMap LmsActNotify $ pure LmsActNotifyData
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
-- ]
postprocess :: FormResult (First act', DBFormResult UserId Bool LmsTableData)
-> FormResult ( act', Set UserId)
postprocess :: FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)
-> FormResult ( QualificationTableActionData, Set UserId)
postprocess inp = do
(First (Just act), usrMap) <- inp
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet)
-- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData))
-- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableActionData))
-- resultDBTableValidator = def
-- & defaultSorting [SortAscBy csvLmsIdent]
over _1 postprocess <$> dbTable psValidator DBTable{..}
@ -457,104 +367,46 @@ mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
getQualificationR = postQualificationR
postQualificationR sid qsh = do
let nlimit = 5000 -- TODO: remove me
noffset = 0
isAdmin <- hasReadAccessTo AdminR
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
qent <- getBy404 $ SchoolQualificationShort sid qsh
let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
acts = mconcat
[ singletonMap LmsActNotify $ pure LmsActNotifyData
, singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
[ singletonMap QualificationActExpire $ pure QualificationActExpireData
, singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData
]
colChoices = mconcat
[ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is"
[ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameLinkHdr MsgLmsUser AdminUserR
, colUserEmail
, 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-due") (i18nCell MsgTableQualificationBlockedDue -- & cellTooltip MsgTableQualificationBlockedTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> d) -> foldMap (dayCell . qualificationBlockedDay) d
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
, sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status
, sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d
, sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d
, sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d
--, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row ->
-- 4 Cases:
-- - No notification: LmsUserNotified == Nothing
-- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing
-- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _
-- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified
lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent
recipient = row ^. hasUser
letterDates = row ^? resultPrintAck
lastLetterDate = headDef Nothing =<< letterDates
letterSent = isJust letterDates && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter)
notNotified = isNothing notifyDate
cIcon = iconFixedCell $ iconLetterOrEmail letterSent
cDate = if | not letterSent -> foldMap dateTimeCell notifyDate
| Just d <- lastLetterDate -> dateTimeCell d
| otherwise -> i18nCell MsgPrintJobUnacknowledged
lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)]))
cAckDates = case letterDates of
Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
<h1>
_{MsgPrintJobAcknowledgements} ^{userWidget recipient}
<ul>
$forall mbackdate <- ackDates
<li>
#{iconLetter} #
$maybe ackdate <- mbackdate
^{formatTimeW SelFormatDateTime ackdate}
$nothing
_{MsgPrintJobUnacknowledged}
$maybe lu <- lprLink
<p>
<a href=@{lu}>
_{MsgPrintJobs}
|]
-- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
_ -> mempty
in if notNotified
then mempty
else cIcon <> spacerCell <> cDate <> cAckDates
-- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d)
, sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d
, sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted)
$ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d
, sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status
, sortable Nothing (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap lmsStatusPlusCell lu
]
where
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
psValidator = def & forceFilter "may-access" (Any True)
tbl <- mkLmsTable nlimit noffset isAdmin qent acts colChoices psValidator
psValidator = def
tbl <- mkQualificationTable qent acts colChoices psValidator
return (tbl, qent)
isAdmin <- hasReadAccessTo AdminR
formResult lmsRes $ \case
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
(action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do
now <- liftIO getCurrentTime
numExaminees <- runDBJobs $ do
okUsers <- selectList [LmsUserUser <-. Set.toList selectedUsers, LmsUserQualification ==. qid] []
forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do
when (isRenewPinAct action) $ do
update lid [LmsUserPin =. "1234", LmsUserDatePin =. now]
when (isNotifyAct action) $
queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' }
return $ length okUsers
let numSelected = length selectedUsers
diffSelected = numSelected - numExaminees
when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees
when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees
when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
redirect currentRoute
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now
(action, selectedUsers) | isExpiryAct action -> do
let isUnexpire = action == QualificationActUnexpireData
upd <- runDB $ updateWhereCount
[QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
[QualificationUserScheduleRenewal =. isUnexpire]
let msgKind = if upd > 0 then Success else Warning
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
addMessageI msgKind msgVal
redirect currentRoute
_ -> return ()
let heading = citext2widget $ qualificationName quali
siteLayout heading $ do

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

@ -341,6 +341,10 @@ lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls)
ic | isLmsSuccess ls = IconOK
| otherwise = IconNotOK
lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a
lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat
lmsStatusPlusCell LmsUser{lmsUserStarted} = iconCell IconWaitingForUser <> spacerCell <> dateCell lmsUserStarted
qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
qualificationBlockedCell Nothing = mempty
qualificationBlockedCell (Just QualificationBlocked{..})

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

@ -280,7 +280,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
updateBy (UniqueQualificationUser qid (lmsUserUser luser))
[QualificationUserBlockedDue =. Just (QualificationBlocked { qualificationBlockedDay = blockedDay
, qualificationBlockedReason = "LMS" } )]
, qualificationBlockedReason = "E-Learning durchgefallen" } )]
queueDBJob JobSendNotification
{ jRecipient = lmsUserUser luser
, jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay }

5
src/Model/Types/Lms.hs
View File

@ -48,6 +48,8 @@ isLmsSuccess :: LmsStatus -> Bool
isLmsSuccess LmsSuccess{} = True
isLmsSuccess _other = False
makeLenses_ ''LmsStatus
-- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! Siehe Model.TypesSpec
instance Semigroup LmsStatus where
a <> b = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess
@ -64,12 +66,13 @@ instance Csv.ToField LmsStatus where
toField (LmsBlocked d) = "Failure: " <> Csv.toField d
toField (LmsSuccess d) = "Success: " <> Csv.toField d
data QualificationBlocked = QualificationBlocked { qualificationBlockedDay :: Day
, qualificationBlockedReason :: Text
}
deriving (Eq, Ord, Read, Show, Generic, NFData)
makeLenses_ ''QualificationBlocked
deriveJSON defaultOptions
{ tagSingleConstructors = False
, fieldLabelModifier = camelToPathPiece' 2

2
src/Utils/Icon.hs
View File

@ -106,6 +106,7 @@ data Icon
| IconLetter
| IconAt
| IconSupervisor
| IconWaitingForUser
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
deriving anyclass (Universe, Finite, NFData)
@ -190,6 +191,7 @@ iconText = \case
IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well
IconAt -> "at"
IconSupervisor -> "head-side" -- must be notably different to user
IconWaitingForUser -> "user-cog" -- Waiting on a user to do something
nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon

2
templates/mail/body/qualificationRenewal.hamlet
View File

@ -11,7 +11,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dl>
<dt>_{SomeMessage MsgQualificationName}
<dd>
<a href=@{LmsR qualSchool (CI.mk qualShort)}>
<a href=@{QualificationR qualSchool (CI.mk qualShort)}>
#{qualName}
<dt>_{SomeMessage MsgLmsUser}
<dd>#{nameHtml qualHolder qualHolderSN}

2
templates/mail/qualificationExpired.hamlet
View File

@ -25,7 +25,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dl>
<dt>_{SomeMessage MsgQualificationName}
<dd>
<a href=@{LmsR qualificationSchool qualificationShorthand}>
<a href=@{QualificationR qualificationSchool qualificationShorthand}>
#{qualificationName}
<dt>_{SomeMessage MsgLmsUser}
<dd>#{nameHtml userDisplayName userSurname}

2
templates/mail/qualificationExpiry.hamlet
View File

@ -25,7 +25,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dl>
<dt>_{SomeMessage MsgQualificationName}
<dd>
<a href=@{LmsR qualificationSchool qualificationShorthand}>
<a href=@{QualificationR qualificationSchool qualificationShorthand}>
#{qualificationName}
<dt>_{SomeMessage MsgLmsUser}
<dd>#{nameHtml userDisplayName userSurname}

10
templates/profileData.hamlet
View File

@ -93,13 +93,17 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dt .deflist__dt>
_{MsgCompany}
<dd .deflist__dd>
^{toWgt (mconcat companies)}
$if not $ null supervisors
^{toWgt (mconcat companies)}
$if numSupervisors > 0
<dt .deflist__dt>_{MsgProfileSupervisor}
$if numSupervisors > 3
\ #{numSupervisors}
<dd .deflist__dd>
^{mconcat supervisors}
$if not $ null supervisees
$if numSupervisees > 0
<dt .deflist__dt>_{MsgProfileSupervisee}
$if length supervisees > 3
\ #{numSupervisees}
<dd .deflist__dd>
^{mconcat supervisees}
$if showAdminInfo

5
test/Database/Fill.hs
View File

@ -512,8 +512,9 @@ fillDb = do
, UserSupervisor svaupel fhamann True
, UserSupervisor sbarth tinaTester True
, UserSupervisor gkleen fhamann False
] ++
take 333 [ UserSupervisor fhamann uid False | Entity uid _ <- matUsers ]
]
++ take 333 [ UserSupervisor fhamann uid False | Entity uid _ <- matUsers ]
++ take 111 [ UserSupervisor gkleen uid False | Entity uid _ <- drop 300 matUsers ]
upsertManyWhere supvs [] [] []
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok
-- insertMany_ supvs -- NOTE: multiple calls like this throw an error!