diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index a8315ef26..7be390ddd 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 3eaae500d..6ca8734a7 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -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 diff --git a/routes b/routes index 3cf767103..f121dfbc9 100644 --- a/routes +++ b/routes @@ -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 diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 9b4daf552..0f44e4271 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 6b7b67b71..240a900f6 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 434aaea24..9f94c00e4 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 8690f8cae..d700aff73 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -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| -

- _{MsgPrintJobAcknowledgements} ^{userWidget recipient} -