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

Merge branch 'fradrive/newletter'

Browse Source
This commit is contained in:
Steffen Jost 2024-07-04 14:40:03 +02:00
commit 6ea3a30afc
17 changed files with 196 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -9,6 +9,7 @@ QualificationValidIndicator: Gültigkeit
QualificationValidDuration: Gültigkeitsdauer
QualificationAuditDuration: Aufbewahrung Audit Log
QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hinweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen, aber spätestens #{n} Tage nach Abschluss.
QualificationAuditDurationReuseError: Diese Qualifikation nutzt das E‑Learning einer anderen Qualifikation, für die derzeit keinen Löschzeitraum konfiguriert wurde.
QualificationRefreshWithin: Erneurerungszeitraum
QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
QualificationRefreshReminder: 2. Erinnerung
@ -20,6 +21,8 @@ QualificationExpiryNotificationTooltip: Nutzer werden benachrichtigt, wenn die Q
TableQualificationCountActive: Aktive
TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation
TableQualificationCountTotal: Gesamt
TableQualificationLmsReuses: LMS nutzt
TableQualificationLmsReusesTooltip: Diese Qualifikation hat kein eigenes E‑Learning, sondern wird über das E‑Learning der angegebenen Qualifikation abgewickelt.
TableQualificationIsAvsLicence: AVS
TableQualificationIsAvsLicenceTooltip: Unter welchem Namen wird diese Qualifikation mit dem Ausweisverwaltungssystem (AVS) synchronisiert? Betrifft nur Benutzer mit AVS PersonenID.
TableQualificationSapExport: SAP

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

@ -9,6 +9,7 @@ QualificationValidIndicator: Validity
QualificationValidDuration: Validity period
QualificationAuditDuration: Audit log retention period
QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing.
QualificationAuditDurationReuseError: This qualification reuses the e‑learning from another qualification, which has no audit duration configured.
QualificationRefreshWithin: Refresh within
QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
QualificationRefreshReminder: 2. Reminder
@ -20,6 +21,8 @@ QualificationExpiryNotificationTooltip: Qualification holder are notfied upon in
TableQualificationCountActive: Active
TableQualificationCountActiveTooltip: Number of currently valid qualification holders
TableQualificationCountTotal: Total
TableQualificationLmsReuses: Reuse LMS
TableQualificationLmsReusesTooltip: This qualification reuses the e‑learning of the given qualification, instead of having a separate e‑learning of its own.
TableQualificationIsAvsLicence: AVS driving license
TableQualificationIsAvsLicenceTooltip: Under which name is this qualification synchronized with AVS, if any? Only applies to qualification holders having an AVS PersonID.
TableQualificationSapExport: Sent to SAP

7
models/lms.model
View File

@ -14,13 +14,14 @@ Qualification
refreshReminder CalendarDiffDays Maybe -- send a second notification about renewal within this number of month/days before expiry
elearningStart Bool -- automatically schedule e-refresher
elearningRenews Bool default=true -- successful E-learing automatically increases validity automatically by validDuration
lmsReuses QualificationId Maybe -- if set, lms is also included within the given qualification's lms, but only for direct routes. AuditDuration is used from this Qualification instead.
expiryNotification Bool default=true -- should expiryNotification be generated for this qualification?
avsLicence AvsLicence Maybe -- if set, valid QualificationUsers are synchronized to AVS as a driving licence
sapId Text Maybe -- if set, valid QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id
sapId Text Maybe -- if set, valid QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id
SchoolQualificationShort school shorthand -- must be unique per school and shorthand
SchoolQualificationName school name -- must be unique per school and name
-- across all schools, only one qualification may be a driving licence:
UniqueQualificationAvsLicence avsLicence !force -- either empty or unique
-- across all schools, only one qualification may be a driving licence -- NO LONGER TRUE
-- UniqueQualificationAvsLicence avsLicence !force -- either empty or unique
-- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
deriving Show Eq Generic

1
src/Handler/Admin.hs
View File

@ -311,6 +311,7 @@ resultUser = _dbrOutput . _3 . _Just
mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget)
mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
where
-- TODO: query to collect all occurring problem types to use as tooltip for the problem filter, so that these don't run out of synch
dbtIdent = "problem-log" :: Text
dbtSQLQuery = \(problem `E.LeftOuterJoin` solver `E.LeftOuterJoin` usr) -> do
-- EL.on (usr E.?. UserId E.==. E.text2num (problem E.^. ProblemLogInfo E.->>. "user")) -- works

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

@ -450,8 +450,8 @@ getProblemAvsSynchR = do
procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do
oks <- runDB $ do
qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
if qId /= licenceTableChangeFDriveQId
qIds <- selectKeysList [QualificationAvsLicence ==. Just alic] [] -- sanity check
if licenceTableChangeFDriveQId `notElem` qIds
then return (-1)
else do
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []

18
src/Handler/Course/Users.hs
View File

@ -129,11 +129,11 @@ _userSheets = _dbrOutput . _7
-- _userQualifications :: Traversal' UserTableData [Entity Qualification]
-- _userQualifications = _dbrOutput . _8 . (traverse _1)
-- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualfications -> f UserTableQualifications
-- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualifications -> f UserTableQualifications
_userQualifications :: Getter UserTableData [Entity Qualification]
_userQualifications = _dbrOutput . _8 . to (fmap fst3)
-- _userQualifications = _dbrOutput . _8 . each . _1 -- TODO: how to make this work
-- _userQualifications = _dbrOutput . _8 . each . _1 -- TODO: how to make this work
_userCourseQualifications :: Lens' UserTableData UserTableQualifications
@ -194,7 +194,7 @@ colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTab
colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Colonnade Sortable UserTableData (DBCell m c)
colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $
let qualNamedReasonCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidReasonCell' Nothing isAdmin cutoff qb qu
in \(view _userCourseQualifications -> qualis) ->
in \(view _userCourseQualifications -> qualis) ->
(cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedReasonCell
data UserTableCsv = UserTableCsv
@ -420,12 +420,12 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
)
)
qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser `E.LeftOuterJoin` qualificationBlock) -> do
E.on $ qualificationUser E.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser
E.on $ qualificationUser E.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser
E.&&. qualificationBlock `isLatestBlockBefore` E.now_
E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId
E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId
E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val (entityKey user)
E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids
E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here
E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids
E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here
return (qualification, qualificationUser, qualificationBlock)
let
regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
@ -739,7 +739,7 @@ postCUsersR tid ssh csh = do
redirect $ CourseR tid ssh csh CUsersR
(CourseUserRegisterExamData{..}, selectedUsers) -> do
Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do
guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
let (exam, mOccurrence) = registerExam
mExamReg <- lift $ insertUnique ExamRegistration
{ examRegistrationExam = exam
@ -763,7 +763,7 @@ postCUsersR tid ssh csh = do
Just _ -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet
redirect $ CourseR tid ssh csh CUsersR
(CourseUserReRegisterData, selectedUsers) -> do
(CourseUserReRegisterData, selectedUsers) -> do
Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do
didUpdate <- lift $ updateWhereCount
[ CourseParticipantUser ==. uid

30
src/Handler/Firm.hs
View File

@ -325,9 +325,9 @@ addDefaultSupervisorsAll mutualSupervision cids = do
------------------------------
-- repeatedly useful queries
usrSuperiorCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
-- usrSuperiorCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
usrSuperiorCompanies cmp usr = do
usrPrimaryCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
-- usrPrimaryCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
usrPrimaryCompanies cmp usr = do
othr <- E.from $ E.table @UserCompany
E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
@ -346,12 +346,12 @@ firmCountUsers = E.subSelectCount . fromUserCompany Nothing
firmCountUsersPrimary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsersPrimary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
where
primFltr = E.notExists . usrSuperiorCompanies cmp
primFltr = E.notExists . usrPrimaryCompanies cmp
firmCountUsersSecondary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsersSecondary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
where
primFltr = E.exists . usrSuperiorCompanies cmp
primFltr = E.exists . usrPrimaryCompanies cmp
firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
@ -1164,6 +1164,7 @@ querySuperUserCompany = $(sqlLOJproj 2 2)
type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64
, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
, E.Value (Maybe Bool), E.Value (Maybe Bool) -- Maybe (Entity UserCompany)
, E.Value Bool
)
resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
@ -1184,6 +1185,9 @@ resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue
resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool)
resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue
resultSuperCompanySuperior :: Lens' SuperCompanyTableData Bool
resultSuperCompanySuperior = _dbrOutput . _7 . _unValue
instance HasEntity SuperCompanyTableData User where
hasEntity = resultSuperUser
@ -1195,6 +1199,7 @@ mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Se
mkFirmSuperTable isAdmin cid = do
msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
let
reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
-- fsh = unCompanyKey cid
resultDBTable = DBTable{..}
where
@ -1207,15 +1212,16 @@ mkFirmSuperTable isAdmin cid = do
, usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
, usrCmp E.?. UserCompanySupervisor
, usrCmp E.?. UserCompanySupervisorReroute
, E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.val reasonSuperior)) usr)
)
dbtRowKey = querySuperUser >>> (E.^. UserId)
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute, isSuperior) -> do
cmps <- E.select $ do
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr)
E.orderBy [E.asc $ cmp E.^. CompanyName]
return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor)
return (usr, supervised, rerouted, cmps, supervisor, reroute)
return (usr, supervised, rerouted, cmps, supervisor, reroute, isSuperior)
dbtColonnade = formColonnade $ mconcat
[ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
, colUserNameModalHdr MsgTableSupervisor ForProfileDataR
@ -1227,7 +1233,15 @@ mkFirmSuperTable isAdmin cid = do
, colUserEmail
, sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
, sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr
, sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
-- , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
, sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \row ->
let mb = row ^. resultSuperCompanyDefaultSuper
sp = row ^. resultSuperCompanySuperior
in case (mb,sp) of
(_ , True) -> iconCell IconSuperior
(Nothing ,_) -> iconCell IconSupervisorForeign
(Just True ,_) -> iconCell IconSupervisor
(Just False,_) -> iconSpacerCell
, sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
]

26
src/Handler/LMS/Learners.hs
View File

@ -19,6 +19,7 @@ import Handler.Utils.LMS
import qualified Data.Map as Map
import qualified Data.Csv as Csv
import qualified Data.Text as Text
import qualified Data.Conduit.List as C
-- import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E
@ -38,7 +39,7 @@ lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv
lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
{ csvLUTident = lmsUserIdent
, csvLUTpin = lmsUserPin
, csvLUTresetPin = LmsBool lmsUserResetPin
, csvLUTresetPin = LmsBool lmsUserResetPin
, csvLUTdelete = LmsBool (lmsUserToDelete cutoff lu)
, csvLUTstaff = LmsBool (lmsUserStaff lu)
, csvLUTresetTries= LmsBool (lmsUserToResetTries lu) -- TODO: verify this works as intended!
@ -92,7 +93,7 @@ instance CsvColumnsExplained LmsUserTableCsv where
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget)
mkUserTable _sid qsh qid cutoff = do
dbtCsvName <- csvFilenameLmsUser qsh
dbtCsvName <- csvFilenameLmsUser qsh
let dbtCsvSheetName = dbtCsvName
let
userDBTable = DBTable{..}
@ -166,7 +167,7 @@ getQidCutoff sid qsh = do
getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsLearnersR sid qsh = do
lmsTable <- runDB $ do
(qid, cutoff) <- getQidCutoff sid qsh
(qid, cutoff) <- getQidCutoff sid qsh
view _2 <$> mkUserTable sid qsh qid cutoff
siteLayoutMsg MsgMenuLmsLearners $ do
setTitleI MsgMenuLmsLearners
@ -174,14 +175,17 @@ getLmsLearnersR sid qsh = do
getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsLearnersDirectR sid qsh = do
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
(lms_users,cutoff) <- runDB $ do
(qid, cutoff) <- getQidCutoff sid qsh
lms_users <- selectList [ LmsUserQualification ==. qid
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
(lms_users,cutoff,qshs) <- runDB $ do
(qid, cutoff) <- getQidCutoff sid qsh
qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
let qids = qid : (entityKey <$> qidsReuse)
qshs = qsh : (qualificationShorthand . entityVal <$> qidsReuse)
lms_users <- selectList [ LmsUserQualification <-. qids
, LmsUserEnded ==. Nothing
-- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
] [Asc LmsUserStarted, Asc LmsUserIdent]
return (lms_users, cutoff)
] [Asc LmsUserStarted, Asc LmsUserIdent]
return (lms_users, cutoff, qshs)
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
Ex.select $ do
@ -196,7 +200,7 @@ getLmsLearnersDirectR sid qsh = do
, csvLUTstaff = LmsBool False
}
-}
LmsConf{..} <- getsYesod $ view _appLmsConf
LmsConf{..} <- getsYesod $ view _appLmsConf
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
--csvRenderedHeader = lmsUserTableCsvHeader
--cvsRendered = CsvRendered {..}
@ -209,7 +213,7 @@ getLmsLearnersDirectR sid qsh = do
csvOpts = def { csvFormat = fmtOpts }
csvSheetName <- csvFilenameLmsUser qsh
let nr = length lms_users
msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs)
$logInfoS "LMS" msg
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered

64
src/Handler/LMS/Report.hs
View File

@ -3,6 +3,7 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{-# LANGUAGE TypeApplications #-}
module Handler.LMS.Report
( getLmsReportR, postLmsReportR
@ -17,10 +18,13 @@ import Handler.Utils
import Handler.Utils.Csv
import Handler.Utils.LMS
import qualified Data.Text as Text
import qualified Data.Map as Map
import qualified Data.Csv as Csv
import qualified Data.Conduit.List as C
import qualified Database.Esqueleto.Legacy as E
-- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E
import Jobs.Queue
@ -121,7 +125,7 @@ mkReportTable sid qsh qid = do
]
dbtFilter = Map.fromList
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsReportIdent))
, (csvLmsDate , FilterColumn $ E.mkExactFilter (E.^. LmsReportDate))
, (csvLmsDate , FilterColumn $ E.mkExactFilter (E.^. LmsReportDate))
]
dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
@ -199,7 +203,7 @@ mkReportTable sid qsh qid = do
, LmsReportResult =. lmsReportCsvResult actionData
, LmsReportLock =. lmsReportCsvLock actionData
, LmsReportTimestamp =. eanow
]
]
lift . queueDBJob $ JobLmsReports qid
return $ LmsReportR sid qsh
, dbtCsvRenderKey = const $ \case
@ -246,8 +250,8 @@ postLmsReportR sid qsh = do
-- Direct File Upload/Download
saveReportCsv :: UTCTime -> QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
saveReportCsv now qid i LmsReportTableCsv{..} = do
saveReportCsv :: UTCTime -> NonEmpty QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
saveReportCsv now (qid :| []) i LmsReportTableCsv{..} = do
void $ upsert
LmsReport
{ lmsReportQualification = qid
@ -263,6 +267,30 @@ saveReportCsv now qid i LmsReportTableCsv{..} = do
, LmsReportTimestamp =. now
]
return $ succ i
saveReportCsv now qids@(qid :| _) i lrtc@LmsReportTableCsv{..} = do
ok <- E.insertSelectWithConflictCount UniqueLmsReport
(do
lusr <- E.from $ E.table @LmsUser
E.where_ $ lusr E.^. LmsUserIdent E.==. E.val csvLRident
E.&&. lusr E.^. LmsUserQualification `E.in_` E.vals qids
return $ LmsReport
E.<# (lusr E.^. LmsUserQualification)
E.<&> E.val csvLRident
E.<&> E.val (csvLRdate <&> lms2timestamp)
E.<&> E.val csvLRresult
E.<&> E.val (csvLRlock & lms2bool)
E.<&> E.val now
)
(\_old _new ->
[ LmsReportDate E.=. E.val (csvLRdate <&> lms2timestamp)
, LmsReportResult E.=. E.val csvLRresult
, LmsReportLock E.=. E.val (csvLRlock & lms2bool)
, LmsReportTimestamp E.=. E.val now
]
)
if ok > 0
then return $ succ i
else saveReportCsv now (qid :| []) i lrtc -- save unknown LmsIdent to primary qid regardless, so that the error can be tracked
makeReportUploadForm :: Form FileInfo
makeReportUploadForm = renderAForm FormStandard $ fileAFormReq "Report CSV"
@ -276,15 +304,18 @@ postLmsReportUploadR sid qsh = do
FormSuccess file -> do
-- content <- fileSourceByteString file
-- return $ Just (fileName file, content)
(nr, qid) <- runDBJobs $ do
(nr, qids, qshs) <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
let qids = qid :| (entityKey <$> qidsReuse)
qshs = qsh : (qualificationShorthand . entityVal <$> qidsReuse)
nr <- runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveReportCsv now qid) 0
return (nr, qid)
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
.| foldMC (saveReportCsv now qids) 0
return (nr, qids, qshs)
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") <> " für Qualifikationen: " <> Text.intercalate ", " (ciOriginal <$> qshs)
-- redirect $ LmsReportR sid qsh
getLmsReportR sid qsh <* queueJob' (JobLmsReports qid) -- show uploaded data before processing
getLmsReportR sid qsh <* forM_ qids (queueJob' . JobLmsReports) -- show uploaded data before processing
FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml
@ -294,7 +325,7 @@ postLmsReportUploadR sid qsh = do
setTitleI MsgMenuLmsUpload
[whamlet|$newline never
<form method=post enctype=#{enctype}>
^{widget}
^{widget}
<input type=submit>
|]
@ -308,18 +339,21 @@ postLmsReportDirectR sid qsh = do
lmsDecoder <- getLmsCsvDecoder
runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
let qids = qid :| (entityKey <$> qidsReuse)
qshs = qsh : (qualificationShorthand . entityVal <$> qidsReuse)
enr <- try $ runConduit $ fileSource file
.| lmsDecoder
.| foldMC (saveReportCsv now qid) 0
.| foldMC (saveReportCsv now qids) 0
case enr of
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
$logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e
$logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e <> " for Qualification: " <> Text.intercalate ", " (ciOriginal <$> qshs)
logInterface "LMS" (ciOriginal qsh) False Nothing ""
return (badRequest400, "Exception: " <> tshow e)
Right nr -> do
let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". "
let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> " and Qualifications: " <> Text.intercalate ", " (ciOriginal <$> qshs)
$logInfoS "LMS" msg
when (nr > 0) $ queueDBJob $ JobLmsReports qid
when (nr > 0) $ forM_ qids (queueDBJob . JobLmsReports)
logInterface "LMS" (ciOriginal qsh) True (Just nr) ""
return (ok200, msg)
[] -> do

9
src/Handler/Qualification.hs
View File

@ -106,6 +106,8 @@ mkQualificationAllTable isAdmin = do
$ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
$ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification)
, sortable Nothing (i18nCell MsgTableQualificationLmsReuses & cellTooltip MsgTableQualificationLmsReusesTooltip)
$ \(view (resultAllQualification . _qualificationLmsReuses) -> reuseQid) -> maybeCell reuseQid qualificationIdShortCell
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
@ -528,14 +530,15 @@ postQualificationR sid qsh = do
msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning
now <- liftIO getCurrentTime
let nowaday = utctDay now
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
((lmsRes, qualificationTable), Entity qid quali, lmsQualiReused) <- runDB $ do
qent@Entity{
entityKey=qid
, entityVal=Qualification{
qualificationAuditDuration=auditMonths
, qualificationValidDuration=validMonths
, qualificationLmsReuses =reuseQuali
}} <- getBy404 $ SchoolQualificationShort sid qsh
lmsQualiReused <- traverseJoin get reuseQuali
-- Block copied to Handler/Qualifications TODO: refactor
let getBlockReasons unblk = Ex.select $ do
(quser :& qblock) <- Ex.from $ Ex.table @QualificationUser
@ -608,7 +611,7 @@ postQualificationR sid qsh = do
]
psValidator = def & defaultSorting [SortDescBy "last-refresh"]
tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
return (tbl, qent)
return (tbl, qent, lmsQualiReused)
formResult lmsRes $ \case
(QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do

2
src/Handler/SAP.hs
View File

@ -57,7 +57,7 @@ instance ToNamedRecord SapUserTableCsv where
, "Ausprägung" Csv..= csvSUTausprägung
]
-- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
-- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualifications with sap id and users with internal personnel number must be transmitted)
-- temporary suspensions are transmitted to SAP in multiple rows: firstheld->suspension1, reinstate1->suspension2, reinstate2->validTo
sapRes2csv :: [(E.Value (Maybe Text), E.Value (Maybe Text), E.Value Day, E.Value Day, E.Value (Maybe [Maybe Day]), E.Value (Maybe [Maybe Bool]))] -> [SapUserTableCsv]
sapRes2csv = concatMap procRes

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

@ -378,6 +378,25 @@ companyIdCell cid = companyCell csh csh False
where
csh = unCompanyKey cid
-- | Uses DB Lookup to link to a qualification by id only, use sparingly!
qualificationIdCell :: (IsDBTable m c) => QualificationId -> DBCell m c
qualificationIdCell qid = anchorCellM' qual link name
where
qual = liftHandler $ runDBRead $ get qid
link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand
link Nothing = HelpR
name Nothing = text2widget "Error: unknown QID"
name (Just Qualification{..}) = citext2widget qualificationName
qualificationIdShortCell :: (IsDBTable m c) => QualificationId -> DBCell m c
qualificationIdShortCell qid = anchorCellM' qual link name
where
qual = liftHandler $ runDBRead $ get qid
link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand
link Nothing = HelpR
name Nothing = text2widget "Error: unknown QID"
name (Just Qualification{..}) = citext2widget qualificationShorthand
qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name
where

68
src/Handler/Utils/Users.hs
View File

@ -89,7 +89,7 @@ getUserPrimaryCompanyAddress uid prj = runMaybeT $ do
company <- MaybeT $ get cid
-- hoistMaybe $ prj company
MaybeT $ pure $ prj company
-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail)
@ -111,18 +111,18 @@ getPostalPreferenceAndAddress' usr = do
finalPref = (usrPrefPost && isJust (fst pa)) || isNothing (fst em)
-- finalPref = isJust (fst pa) && (usrPrefPost || isNothing (fst em))
return (finalPref, pa, em)
getEmailAddressFor :: UserId -> DB (Maybe Address)
getEmailAddressFor = maybeM (return Nothing) getEmailAddress . getEntity
getJustEmailAddressFor :: UserId -> DB Address
getJustEmailAddressFor = maybeThrowM ExceptionUserHasNoEmail . getEmailAddressFor
getJustEmailAddress :: Entity User -> DB Address
getJustEmailAddress = maybeThrowM ExceptionUserHasNoEmail . getEmailAddress
getEmailAddress :: Entity User -> DB (Maybe Address)
getEmailAddress usr@Entity{entityVal=User{userDisplayName}} = toAddress <<$>> getUserEmail usr
getEmailAddress usr@Entity{entityVal=User{userDisplayName}} = toAddress <<$>> getUserEmail usr
where toAddress = Address (Just userDisplayName) . CI.original
getUserEmail :: Entity User -> DB (Maybe UserEmail)
@ -159,12 +159,12 @@ getPostalAddress Entity{entityKey=uid, entityVal=User{..}}
getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
(Just pa)
-> prefixMarkupName pa
Nothing
Nothing
| Just abt <- userCompanyDepartment
-> return $ Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
| otherwise -> [userDisplayName, abt, "Hausbriefkasten" ]
| otherwise -> return Nothing
where
where
prefixMarkupName = return . Just . (userDisplayName :) . html2textlines
-- primed variant returns storedMarkup without prefixed userDisplayName and whether updates are automatic
@ -174,15 +174,15 @@ getPostalAddress' Entity{entityKey=uid, entityVal=User{..}}
= do
muavs <- getBy $ UniqueUserAvsUser uid
let auto = userPostAddress == muavs ^? _Just . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just -- Recall: using _Just with ^. on Nothing yields mempty
return (userPostAddress, auto)
return (userPostAddress, auto)
| otherwise
= do
getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
res@(Just _)
-> return (res, True)
Nothing
Nothing
| Just abt <- userCompanyDepartment
-> return $ (,True) $ Just $ plaintextToStoredMarkup $ textUnlines $
-> return $ (,True) $ Just $ plaintextToStoredMarkup $ textUnlines $
if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
| otherwise -> [userDisplayName, abt, "Hausbriefkasten" ]
| otherwise -> return (Nothing, True)
@ -214,10 +214,10 @@ getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do
-- | return underlings for currently logged in user
getSupervisees :: DB (Set UserId)
getSupervisees = do
getSupervisees = do
uid <- requireAuthId
svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser]
return $ Set.insert uid $ Set.fromAscList svs
return $ Set.insert uid $ Set.fromAscList svs
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
@ -408,10 +408,10 @@ assimilateUser :: UserId -- ^ @newUserId@
-- Fatal errors are thrown, non-fatal warnings are returned
assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
-- retrieve user entities first, to ensure they both exist
(oldUserEnt, newUserEnt) <- do
(oldUserEnt, newUserEnt) <- do
oldUser <- getEntity oldUserId
newUser <- getEntity newUserId
case (oldUser, newUser) of
case (oldUser, newUser) of
(Just old, Just new) -> return (old,new)
_ -> tellError UserAssimilateCouldNotDetermineUserIdents
let oldUser = oldUserEnt ^. _entityVal
@ -914,7 +914,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
-- Qualifications and ongoing LMS
-- LmsUser: insertSelectWithConflict impossible due to 2 simultaneous uniqueness constraints; UniqueLmsIdent requires proper update, prohibits insert and then delete
-- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualficationUuser
-- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualificationUuser
oldLms <- selectList [ LmsUserUser ==. oldUserId ] [ Asc LmsUserQualification ]
newLms <- selectList [ LmsUserUser ==. newUserId ] [ Asc LmsUserQualification ]
let projQ = lmsUserQualification . entityVal
@ -931,13 +931,13 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
EL.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId
)
E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId
E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId
return (oldQual, newQual)
forM_ usrQualis $ \case
forM_ usrQualis $ \case
(Entity oldQKey _, Nothing) -> update oldQKey [ QualificationUserUser =. newUserId ] -- update must succeed if there is not RHS in the join
(Entity oldQKey oldQUsr, Just (Entity newQKey newQUsr)) -> do
updateWhere [ QualificationUserBlockQualificationUser ==. oldQKey ] [ QualificationUserBlockQualificationUser =. newQKey ]
update newQKey
update newQKey
[ QualificationUserValidUntil =. (max `on` view _qualificationUserValidUntil ) oldQUsr newQUsr
, QualificationUserLastRefresh =. (max `on` view _qualificationUserLastRefresh ) oldQUsr newQUsr
, QualificationUserFirstHeld =. (min `on` view _qualificationUserFirstHeld ) oldQUsr newQUsr
@ -945,7 +945,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
, QualificationUserLastNotified =. (max `on` view _qualificationUserLastNotified ) oldQUsr newQUsr
]
delete oldQKey
-- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed
-- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed
-- PrintJobs
updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ]
@ -963,10 +963,10 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
E.<&> (userSupervisor E.^. UserSupervisorCompany)
E.<&> (userSupervisor E.^. UserSupervisorReason)
)
(\current excluded ->
[ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)
, UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason]
(\current excluded ->
[ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)
, UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason]
] )
deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
@ -981,10 +981,10 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
E.<&> (userSupervisor E.^. UserSupervisorCompany)
E.<&> (userSupervisor E.^. UserSupervisorReason)
)
(\current excluded ->
(\current excluded ->
[ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)
, UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason]
, UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason]
] )
deleteWhere [ UserSupervisorUser ==. oldUserId]
@ -1001,7 +1001,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
E.<&> (userCompany E.^. UserCompanyPriority)
E.<&> (userCompany E.^. UserCompanyUseCompanyAddress)
)
(\current excluded ->
(\current excluded ->
[ UserCompanySupervisor E.=. E.greatest (current E.^. UserCompanySupervisor) (excluded E.^. UserCompanySupervisor) -- t > f
, UserCompanyPriority E.=. E.greatest (current E.^. UserCompanyPriority) (excluded E.^. UserCompanyPriority)
, UserCompanyUseCompanyAddress E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress)
@ -1010,13 +1010,13 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
deleteWhere [ UserCompanyUser ==. oldUserId]
mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId
mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId
case (mbOldAvsId,mbNewAvsId) of
(Nothing, _)
mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId
case (mbOldAvsId,mbNewAvsId) of
(Nothing, _)
-> return ()
(Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _)
(Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _)
-> deleteBy (UniqueUserAvsId oldAvsId)
(Just Entity{entityVal=oldUserAvs}, Nothing)
(Just Entity{entityVal=oldUserAvs}, Nothing)
-> void $ upsertBySafe (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} (_userAvsUser .~ newUserId)
-- merge some optional / incomplete user fields
@ -1025,7 +1025,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
oldV = oldUserEnt ^. ufl
newV = newUserEnt ^. ufl
in toMaybe (cmp oldV newV) (uf =. oldV)
mergeMaybe :: forall b . PersistField b => EntityField User (Maybe b) -> Maybe (Update User)
mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV)
@ -1045,14 +1045,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
(UserPostLastUpdate =. oldUser ^. _userPostLastUpdate)
, toMaybe ((isJust (newUser ^. _userPostAddress) || isJust (oldUser ^. _userPostAddress))
&& (newUser ^. _userPrefersPostal || oldUser ^. _userPrefersPostal))
(UserPrefersPostal =. True)
(UserPrefersPostal =. True)
, mergeMaybe UserPinPassword
, mergeMaybe UserLanguages
, mergeMaybe UserSex
, mergeMaybe UserBirthday
, mergeMaybe UserTelephone
, mergeMaybe UserMobile
]
]
delete oldUserId
let oldUsrIdent = oldUser ^. _userIdent

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

@ -265,7 +265,7 @@ dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
dispatchJobLmsReports qid = JobHandlerAtomic act
where
-- act :: YesodJobDB UniWorX ()
act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise)
act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (E fails otherwise)
now <- liftIO getCurrentTime
-- DEBUG 2rows; remove later
totalrows <- count [LmsReportQualification ==. qid]

2
templates/i18n/pitch/en-eu.hamlet
View File

@ -12,4 +12,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<p>
FRADrive supports training courses by handling #
registration, correspondence, course homepages, examinations and #
managing the gained qualfications.
managing the gained qualifications.

18
templates/qualification.hamlet
View File

@ -17,7 +17,19 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$maybe daudit <- qualificationAuditDuration quali
<dt .deflist__dt>_{MsgQualificationAuditDuration}
<dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}
<dd .deflist__dd>
$maybe lqre <- lmsQualiReused
$maybe daudit <- qualificationAuditDuration lqre
_{MsgMonths (fromIntegral daudit)}
$nothing
_{MsgQualificationAuditDurationReuseError}
$nothing
_{MsgMonths (fromIntegral daudit)}
$nothing
$maybe lqre <- lmsQualiReused
$maybe daudit <- qualificationAuditDuration lqre
<dt .deflist__dt>_{MsgQualificationAuditDuration}
<dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}
$maybe drefresh <- qualificationRefreshWithin quali
<dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
@ -42,6 +54,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
, #
$if drd > 0
_{MsgDays (fromIntegral drd)}
$maybe lqre <- lmsQualiReused
<dt .deflist__dt>_{MsgTableQualificationLmsReusesTooltip}
<dd .deflist__dd>^{simpleLink (citext2widget (qualificationName lqre)) (QualificationR (qualificationSchool lqre) (qualificationShorthand lqre))}
<dt .deflist__dt>_{MsgQualificationElearningStart}
<dd .deflist__dd>#{boolSymbol (qualificationElearningStart quali)}

16
test/Database/Fill.hs
View File

@ -701,7 +701,7 @@ fillDb = do
]
++ take 444 [ UserSupervisor fhamann uid True Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- matUsers, uid /= jost]
++ take 123 [ UserSupervisor gkleen uid True Nothing Nothing | Entity uid _ <- drop 369 matUsers ]
++ take 11 [ UserSupervisor jost uid False Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- drop 501 matUsers ]
++ take 11 [ UserSupervisor jost uid False Nothing (Just $ tshow SupervisorReasonAvsSuperior) | Entity uid _ <- drop 501 matUsers ]
upsertManyWhere supvs [] [] []
-- insertMany_ supvs -- NOTE: multiple calls like this throw a runtime error!
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok
@ -753,18 +753,20 @@ fillDb = do
let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
let l_descr = Just $ htmlToStoredMarkup [shamlet|<p>für unhabilitierte|]
qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) (Just $ CalendarDiffDays 0 14) True True True (Just AvsLicenceVorfeld) $ Just "F4466"
qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) Nothing False False False (Just AvsLicenceRollfeld) $ Just "R2801"
qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing Nothing True False True Nothing Nothing
qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 8) (Just $ CalendarDiffDays 0 60) (Just $ CalendarDiffDays 0 14) True True Nothing True (Just AvsLicenceVorfeld) $ Just "F4466"
qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) Nothing False False Nothing False (Just AvsLicenceRollfeld) $ Just "R2801"
qid_rp <- insert' $ Qualification avn "R+" "Rollfeldführerschein-Plus" r_descr (Just 12) (Just 4) (Just $ CalendarDiffDays 2 3) Nothing False False (Just qid_r) False (Just AvsLicenceRollfeld) $ Just "R2802"
qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing Nothing True False Nothing True Nothing Nothing
qfjost <- insert' $ QualificationUser jost qid_f (n_day 11) (n_day $ -1) (n_day $ -22) True (n_day' $ -9) -- TODO: better dates!
void . insert $ QualificationUserBlock qfjost False (n_day' $ -6) "First block" (Just svaupel)
void . insert $ QualificationUserBlock qfjost True (n_day' $ -5) "Second unblock" (Just gkleen)
void . insert $ QualificationUserBlock qfjost False (n_day' $ -4) "Third block" Nothing
void . insert $ QualificationUserBlock qfjost True (n_day' $ -3) "Fourth unblock" (Just sbarth)
void . insert $ QualificationUserBlock qfjost False (n_day' $ -1) "Fifth block" (Just svaupel)
void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) True (n_day' $ -9) -- TODO: better dates!
void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day 33) (n_day $ -4) (n_day $ -20) True (n_day' $ -9)
void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) True (n_day' $ -9) -- TODO: better dates!
void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
void . insert' $ QualificationUser jost qid_rp (n_day 999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day 33) (n_day $ -4) (n_day $ -20) True (n_day' $ -9)
void . insert $ QualificationUserBlock qfkleen False (n_day' 1) "Future block" (Just svaupel)
void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) False (n_day' $ -1)
qfvaupel <- insert' $ QualificationUser svaupel qid_f (n_day 2) (n_day $ -1) (n_day $ -2) True (n_day' $ -9)