fraport/fradrive-old
Archived
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 QualificationAuditDuration: Aufbewahrung Audit Log
QualificationRefreshWithin: Erneurerungszeitraum QualificationRefreshWithin: Erneurerungszeitraum
QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des E-Learning 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 TableQualificationCountActive: Aktive
TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation
TableQualificationCountTotal: Gesamt TableQualificationCountTotal: Gesamt
TableQualificationIsAvsLicence: AVS 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 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 LmsQualificationValidUntil: Gültig bis
TableQualificationLastRefresh: Zuletzt erneuert TableQualificationLastRefresh: Zuletzt erneuert
TableQualificationFirstHeld: Erstmalig 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. 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! 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. 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. 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. 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
@ -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. 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"}. 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. 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 MppOpening: Anrede
MppClosing: Grußformel MppClosing: Grußformel
MppSupervisor: Ansprechpartner MppSupervisor: Ansprechpartner

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

@ -9,7 +9,7 @@ QualificationValidDuration: Validity period
QualificationAuditDuration: Audit log keept QualificationAuditDuration: Audit log keept
QualificationRefreshWithin: Refresh within QualificationRefreshWithin: Refresh within
QualificationRefreshWithinTooltip: Period before expiry to send a notification or to start e-learning 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 TableQualificationCountActive: Active
TableQualificationCountActiveTooltip: Number of currently valid qualification holders TableQualificationCountActiveTooltip: Number of currently valid qualification holders
TableQualificationCountTotal: Total 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. 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! 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. 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. 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. 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
LmsActRenewPin: Randomly replace e-learning PIN LmsActRenewPin: Randomly replace e-learning PIN
LmsActRenewNotify: Randomly replace e-learning PIN and re-send notification by post or email 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. LmsNotificationSend n: 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"}. LmsPinRenewal n: 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. LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.
LmsStarted: E-learning open since
MppOpening: Opening MppOpening: Opening
MppClosing: Closing MppClosing: Closing
MppSupervisor: Supervisor MppSupervisor: Supervisor

6
routes
View File

@ -259,9 +259,9 @@
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect !/#UUID CryptoUUIDDispatchR GET !free -- just redirect
-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists
/qualification QualificationAllR GET !free /qualification QualificationAllR GET !free
/qualification/#SchoolId QualificationSchoolR GET !free /qualification/#SchoolId QualificationSchoolR GET !free
/qualification/#SchoolId/#QualificationShorthand QualificationR GET !free /qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free
/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement /qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement
-- /qualification/CryptoUUIDUser/ -- maybe distingquish via URL -- /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) return (usrAvs, user, qualUser, qual)
dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR? dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
-- Not sure what changes here: -- Not sure what changes here:
-- dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali)
dbtProj = dbtProjFilteredPostId -- dbtProj = dbtProjFilteredPostId
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
-- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal -- $ \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 -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
return (quali, cactive, cusers) return (quali, cactive, cusers)
dbtRowKey = (Ex.^. QualificationId) 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 adminable = if isAdmin then sortable else \_ _ _ -> mempty
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool [ colSchool $ resultAllQualification . _qualificationSchool
@ -214,7 +214,7 @@ makeLenses_ ''LmsTableCsv
ltcExample :: LmsTableCsv ltcExample :: LmsTableCsv
ltcExample = LmsTableCsv ltcExample = LmsTableCsv
{ ltcDisplayName = "Max Mustermann" { ltcDisplayName = "Max Mustermann"
, ltcEmail = "m.mustermann@does.not.exist" , ltcEmail = "m.mustermann@example.com"
, ltcValidUntil = compDay , ltcValidUntil = compDay
, ltcLastRefresh = compDay , ltcLastRefresh = compDay
, ltcFirstHeld = compDay , ltcFirstHeld = compDay
@ -528,8 +528,8 @@ postLmsLSR sid qsh nlimit noffset
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
, 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-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid , sortable (Just "lms-ident") (i18nCell 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-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-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-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-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.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)] E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) 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' (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
icnReroute = text2widget " " <> toWgt (icon IconLetter) icnReroute = text2widget " " <> toWgt (icon IconLetter)
supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) 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' (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
-- icnReroute = text2widget " " <> toWgt (icon IconLetter) -- icnReroute = text2widget " " <> toWgt (icon IconLetter)
--Tables --Tables

370
src/Handler/Qualification.hs
View File

@ -9,13 +9,13 @@
module Handler.Qualification module Handler.Qualification
( getQualificationAllR ( getQualificationAllR
, getQualificationSchoolR , getQualificationSchoolR
, getQualificationR , getQualificationR, postQualificationR
) )
where where
import Import import Import
import Jobs -- import Jobs
import Handler.Utils import Handler.Utils
-- import Handler.Utils.Csv -- import Handler.Utils.Csv
-- import Handler.Utils.LMS -- import Handler.Utils.LMS
@ -27,9 +27,10 @@ import qualified Data.Csv as Csv
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.List as C 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.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
@ -87,7 +88,7 @@ mkQualificationAllTable = do
Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser
return (quali, cactive, cusers) return (quali, cactive, cusers)
dbtRowKey = (Ex.^. QualificationId) dbtRowKey = (Ex.^. QualificationId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference?
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool [ colSchool $ resultAllQualification . _qualificationSchool
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
@ -149,39 +150,27 @@ mkQualificationAllTable = do
-- getQualificationEditR = postQualificationEditR -- getQualificationEditR = postQualificationEditR
-- postQualificationEditR = error "TODO" -- postQualificationEditR = error "TODO"
data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
{ ltcDisplayName :: UserDisplayName { qtcDisplayName :: UserDisplayName
, ltcEmail :: UserEmail , qtcEmail :: UserEmail
, ltcValidUntil :: Day , qtcValidUntil :: Day
, ltcLastRefresh :: Day , qtcLastRefresh :: Day
, ltcFirstHeld :: Day , qtcBlocked :: Maybe Day
, ltcBlockedDue :: Maybe QualificationBlocked , qtcLmsStarted :: Maybe UTCTime
, ltcLmsIdent :: Maybe LmsIdent , qtcLmsStatus :: Maybe LmsStatus
, ltcLmsStatus :: Maybe LmsStatus
, ltcLmsStarted :: Maybe UTCTime
, ltcLmsDatePin :: Maybe UTCTime
, ltcLmsReceived :: Maybe UTCTime
, ltcLmsNotified :: Maybe UTCTime
, ltcLmsEnded :: Maybe UTCTime
} }
deriving Generic deriving Generic
makeLenses_ ''LmsTableCsv makeLenses_ ''QualificationTableCsv
ltcExample :: LmsTableCsv qtcExample :: QualificationTableCsv
ltcExample = LmsTableCsv qtcExample = QualificationTableCsv
{ ltcDisplayName = "Max Mustermann" { qtcDisplayName = "Max Mustermann"
, ltcEmail = "m.mustermann@does.not.exist" , qtcEmail = "m.mustermann@example.com"
, ltcValidUntil = compDay , qtcValidUntil = compDay
, ltcLastRefresh = compDay , qtcLastRefresh = compDay
, ltcFirstHeld = compDay , qtcBlocked = Nothing
, ltcBlockedDue = Nothing , qtcLmsStarted = Just compTime
, ltcLmsIdent = Nothing , qtcLmsStatus = Nothing
, ltcLmsStatus = Nothing
, ltcLmsStarted = Just compTime
, ltcLmsDatePin = Nothing
, ltcLmsReceived = Nothing
, ltcLmsNotified = Nothing
, ltcLmsEnded = Nothing
} }
where where
compTime :: UTCTime compTime :: UTCTime
@ -189,193 +178,128 @@ ltcExample = LmsTableCsv
compDay :: Day compDay :: Day
compDay = utctDay compTime compDay = utctDay compTime
ltcOptions :: Csv.Options qtcOptions :: Csv.Options
ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
where where
renameLtc "ltcDisplayName" = "licensee" renameLtc "qtcDisplayName" = "licensee"
renameLtc "ltcLmsDatePin" = prefixLms "pin-created"
renameLtc "ltcLmsReceived" = prefixLms "last-update"
renameLtc other = replaceLtc $ camelToPathPiece' 1 other renameLtc other = replaceLtc $ camelToPathPiece' 1 other
replaceLtc ('l':'m':'s':'-':t) = prefixLms t replaceLtc ('l':'m':'s':'-':t) = prefixLms t
replaceLtc other = other replaceLtc other = other
prefixLms = ("e-learn-" <>) prefixLms = ("e-learn-" <>)
instance Csv.ToNamedRecord LmsTableCsv where instance Csv.ToNamedRecord QualificationTableCsv where
toNamedRecord = Csv.genericToNamedRecord ltcOptions toNamedRecord = Csv.genericToNamedRecord qtcOptions
instance Csv.DefaultOrdered LmsTableCsv where instance Csv.DefaultOrdered QualificationTableCsv where
headerOrder = Csv.genericHeaderOrder ltcOptions headerOrder = Csv.genericHeaderOrder qtcOptions
instance CsvColumnsExplained LmsTableCsv where instance CsvColumnsExplained QualificationTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
[ ('ltcDisplayName, MsgLmsUser) [ ('qtcDisplayName, MsgLmsUser)
, ('ltcEmail , MsgTableLmsEmail) , ('qtcEmail , MsgTableLmsEmail)
, ('ltcValidUntil , MsgLmsQualificationValidUntil) , ('qtcValidUntil , MsgLmsQualificationValidUntil)
, ('ltcLastRefresh, MsgTableQualificationLastRefresh) , ('qtcLastRefresh, MsgTableQualificationLastRefresh)
, ('ltcFirstHeld , MsgTableQualificationFirstHeld) , ('qtcLmsStarted , MsgLmsStarted)
, ('ltcLmsIdent , MsgTableLmsIdent) , ('qtcLmsStatus , MsgTableLmsStatus)
, ('ltcLmsStatus , MsgTableLmsStatus)
, ('ltcLmsStarted , MsgTableLmsStarted)
, ('ltcLmsDatePin , MsgTableLmsDatePin)
, ('ltcLmsReceived, MsgTableLmsReceived)
, ('ltcLmsEnded , MsgTableLmsEnded)
] ]
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) ) `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) 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) 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) 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 resultQualUser = _dbrOutput . _1
resultUser :: Lens' LmsTableData (Entity User) resultUser :: Lens' QualificationTableData (Entity User)
resultUser = _dbrOutput . _2 resultUser = _dbrOutput . _2
resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just 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 hasEntity = resultUser
instance HasUser LmsTableData where instance HasUser QualificationTableData where
hasUser = resultUser . _entityVal hasUser = resultUser . _entityVal
data LmsTableAction = LmsActNotify data QualificationTableAction = QualificationActExpire | QualificationActUnexpire
| LmsActRenewNotify
| LmsActRenewPin
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe LmsTableAction instance Universe QualificationTableAction
instance Finite LmsTableAction instance Finite QualificationTableAction
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LmsTableAction id embedRenderMessage ''UniWorX ''QualificationTableAction id
-- Not yet needed, since there is no additional data for now: -- Not yet needed, since there is no additional data for now:
data LmsTableActionData = LmsActNotifyData data QualificationTableActionData = QualificationActExpireData | QualificationActUnexpireData
| LmsActRenewNotifyData
| LmsActRenewPinData -- no longer used
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
isNotifyAct :: LmsTableActionData -> Bool isExpiryAct :: QualificationTableActionData -> Bool -- const true, but this may change in the future
isNotifyAct LmsActNotifyData = True isExpiryAct QualificationActExpireData = True
isNotifyAct LmsActRenewNotifyData = True isExpiryAct QualificationActUnexpireData = True
isNotifyAct LmsActRenewPinData = False
isRenewPinAct :: LmsTableActionData -> Bool qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
isRenewPinAct LmsActNotifyData = False
isRenewPinAct LmsActRenewNotifyData = True
isRenewPinAct LmsActRenewPinData = True
lmsTableQuery :: QualificationId -> LmsTableExpr -> Int64 -> Int64
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User) , E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser)) , 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 qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = 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
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_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
when (nlimit > 0) $ E.limit nlimit >> E.offset (nlimit * noffset) -- FIXME Pagination does not work here somehow return (qualUser, user, lmsUser)
-- 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)
newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool } mkQualificationTable ::
instance Default LmsTableFilterProj where
def = LmsTableFilterProj
{ ltProjFilterMayAccess = Nothing }
makeLenses_ ''LmsTableFilterProj
mkLmsTable :: forall h p cols act act'.
( Functor h, ToSortable h ( Functor h, ToSortable h
, Ord act, PathPiece act, RenderMessage UniWorX act , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols
, AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols
) )
=> Int64 -> Int64 => Entity Qualification
-> Bool -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-> Entity Qualification
-> Map act (AForm Handler act')
-> cols -> cols
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
-> DB (FormResult (act', Set UserId), Widget) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do mkQualificationTable (Entity qid quali) acts cols psValidator = do
svs <- getSupervisees
now <- liftIO getCurrentTime 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 let
currentRoute = QualificationR (qualificationSchool quali) (qualificationShorthand quali)
nowaday = utctDay now nowaday = utctDay now
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "qualification" 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) dbtRowKey = queryUser >>> (E.^. UserId)
--dbtProj = dbtProjFilteredPostId 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)
dbtColonnade = cols dbtColonnade = cols
dbtSorting = mconcat dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser , single $ sortUserEmail queryUser
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , 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-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
, single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin)) , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
, 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))
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny) [ single $ fltrUserNameEmail queryUser
, 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 ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
if | Just renewal <- mbRenewal if | Just renewal <- mbRenewal
@ -383,14 +307,10 @@ mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true | otherwise -> E.true
) )
, single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ 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 "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 , if isNothing mbRenewal then mempty
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) 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 , dbtCsvName = csvName
, dbtCsvSheetName = csvName , dbtCsvSheetName = csvName
, dbtCsvNoExportData = Just id , dbtCsvNoExportData = Just id
, dbtCsvHeader = const $ return $ Csv.headerOrder ltcExample , dbtCsvHeader = const $ return $ Csv.headerOrder qtcExample
, dbtCsvExampleData = Just [ltcExample] , dbtCsvExampleData = Just [qtcExample]
} }
where where
doEncode' :: LmsTableData -> LmsTableCsv doEncode' :: QualificationTableData -> QualificationTableCsv
doEncode' = LmsTableCsv doEncode' = QualificationTableCsv
<$> view (resultUser . _entityVal . _userDisplayName) <$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userEmail) <*> view (resultUser . _entityVal . _userEmail)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) -- <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue . _qualificationBlockedDay)
<*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay)
<*> preview (resultLmsUser . _entityVal . _lmsUserIdent)
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus))
<*> preview (resultLmsUser . _entityVal . _lmsUserStarted) <*> preview (resultLmsUser . _entityVal . _lmsUserStarted)
<*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus))
<*> (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))
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else dbtParams = DBParamsForm
DBParamsForm
{ dbParamsFormMethod = POST { dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAttrs = [] , dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit , dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional , dbParamsFormAdditional
= renderAForm FormStandard = renderAForm FormStandard
$ (, mempty) . First . Just $ (, mempty) . First . Just
<$> multiActionA acts (fslI MsgTableAction) Nothing <$> multiActionA acts (fslI MsgTableAction) Nothing
, dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id , dbParamsFormResult = id
, dbParamsFormIdent = def , dbParamsFormIdent = def
} }
-- acts :: Map LmsTableAction (AForm Handler LmsTableActionData) postprocess :: FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)
-- acts = mconcat -> FormResult ( QualificationTableActionData, Set UserId)
-- [ singletonMap LmsActNotify $ pure LmsActNotifyData
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
-- ]
postprocess :: FormResult (First act', DBFormResult UserId Bool LmsTableData)
-> FormResult ( act', Set UserId)
postprocess inp = do postprocess inp = do
(First (Just act), usrMap) <- inp (First (Just act), usrMap) <- inp
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet) 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 -- resultDBTableValidator = def
-- & defaultSorting [SortAscBy csvLmsIdent] -- & defaultSorting [SortAscBy csvLmsIdent]
over _1 postprocess <$> dbTable psValidator DBTable{..} 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 :: SchoolId -> QualificationShorthand -> Handler Html
getQualificationR = postQualificationR getQualificationR = postQualificationR
postQualificationR sid qsh = do 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 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 ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
qent <- getBy404 $ SchoolQualificationShort sid qsh qent <- getBy404 $ SchoolQualificationShort sid qsh
let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
acts = mconcat acts = mconcat
[ singletonMap LmsActNotify $ pure LmsActNotifyData [ singletonMap QualificationActExpire $ pure QualificationActExpireData
, singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
] ]
colChoices = mconcat 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 , colUserNameLinkHdr MsgLmsUser AdminUserR
, colUserEmail , colUserEmail
, 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 "blocked-due") (i18nCell MsgTableQualificationBlockedDue -- & cellTooltip MsgTableQualificationBlockedTooltip
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> d) -> foldMap (dayCell . qualificationBlockedDay) d
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
, 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-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted)
, sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d
, sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status
, sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d , sortable Nothing (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap lmsStatusPlusCell lu
, 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
] ]
where psValidator = def
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a tbl <- mkQualificationTable qent acts colChoices psValidator
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
psValidator = def & forceFilter "may-access" (Any True)
tbl <- mkLmsTable nlimit noffset isAdmin qent acts colChoices psValidator
return (tbl, qent) return (tbl, qent)
isAdmin <- hasReadAccessTo AdminR
formResult lmsRes $ \case formResult lmsRes $ \case
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now
(action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do (action, selectedUsers) | isExpiryAct action -> do
now <- liftIO getCurrentTime let isUnexpire = action == QualificationActUnexpireData
numExaminees <- runDBJobs $ do upd <- runDB $ updateWhereCount
okUsers <- selectList [LmsUserUser <-. Set.toList selectedUsers, LmsUserQualification ==. qid] [] [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do [QualificationUserScheduleRenewal =. isUnexpire]
when (isRenewPinAct action) $ do let msgKind = if upd > 0 then Success else Warning
update lid [LmsUserPin =. "1234", LmsUserDatePin =. now] msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
when (isNotifyAct action) $ addMessageI msgKind msgVal
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 redirect currentRoute
_ -> return ()
let heading = citext2widget $ qualificationName quali let heading = citext2widget $ qualificationName quali
siteLayout heading $ do 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 ic | isLmsSuccess ls = IconOK
| otherwise = IconNotOK | 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 :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
qualificationBlockedCell Nothing = mempty qualificationBlockedCell Nothing = mempty
qualificationBlockedCell (Just QualificationBlocked{..}) 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)] update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
updateBy (UniqueQualificationUser qid (lmsUserUser luser)) updateBy (UniqueQualificationUser qid (lmsUserUser luser))
[QualificationUserBlockedDue =. Just (QualificationBlocked { qualificationBlockedDay = blockedDay [QualificationUserBlockedDue =. Just (QualificationBlocked { qualificationBlockedDay = blockedDay
, qualificationBlockedReason = "LMS" } )] , qualificationBlockedReason = "E-Learning durchgefallen" } )]
queueDBJob JobSendNotification queueDBJob JobSendNotification
{ jRecipient = lmsUserUser luser { jRecipient = lmsUserUser luser
, jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay } , 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 LmsSuccess{} = True
isLmsSuccess _other = False 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 -- 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 instance Semigroup LmsStatus where
a <> b = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess 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 (LmsBlocked d) = "Failure: " <> Csv.toField d
toField (LmsSuccess d) = "Success: " <> Csv.toField d toField (LmsSuccess d) = "Success: " <> Csv.toField d
data QualificationBlocked = QualificationBlocked { qualificationBlockedDay :: Day data QualificationBlocked = QualificationBlocked { qualificationBlockedDay :: Day
, qualificationBlockedReason :: Text , qualificationBlockedReason :: Text
} }
deriving (Eq, Ord, Read, Show, Generic, NFData) deriving (Eq, Ord, Read, Show, Generic, NFData)
makeLenses_ ''QualificationBlocked
deriveJSON defaultOptions deriveJSON defaultOptions
{ tagSingleConstructors = False { tagSingleConstructors = False
, fieldLabelModifier = camelToPathPiece' 2 , fieldLabelModifier = camelToPathPiece' 2

2
src/Utils/Icon.hs
View File

@ -106,6 +106,7 @@ data Icon
| IconLetter | IconLetter
| IconAt | IconAt
| IconSupervisor | IconSupervisor
| IconWaitingForUser
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
deriving anyclass (Universe, Finite, NFData) deriving anyclass (Universe, Finite, NFData)
@ -190,6 +191,7 @@ iconText = \case
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"
IconSupervisor -> "head-side" -- must be notably different to user IconSupervisor -> "head-side" -- must be notably different to user
IconWaitingForUser -> "user-cog" -- Waiting on a user to do something
nullaryPathPiece ''Icon $ camelToPathPiece' 1 nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon deriveLift ''Icon

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

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

2
templates/mail/qualificationExpired.hamlet
View File

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

2
templates/mail/qualificationExpiry.hamlet
View File

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

8
templates/profileData.hamlet
View File

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

5
test/Database/Fill.hs
View File

@ -512,8 +512,9 @@ fillDb = do
, UserSupervisor svaupel fhamann True , UserSupervisor svaupel fhamann True
, UserSupervisor sbarth tinaTester True , UserSupervisor sbarth tinaTester True
, UserSupervisor gkleen fhamann False , 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 [] [] []
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok
-- insertMany_ supvs -- NOTE: multiple calls like this throw an error! -- insertMany_ supvs -- NOTE: multiple calls like this throw an error!