diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index bedf81517..bd5b82662 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index f6f869fe3..a3dd39375 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -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 diff --git a/models/lms.model b/models/lms.model index 9a78d2560..dd1606611 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index e4ddc8cf1..e69f4ec98 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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 diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index b8c0926fc..e508a0a7f 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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] [] diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 4a4e11e9d..b8a04f31e 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -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 diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 666f4968d..39cc90d29 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -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 ] diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 1b149b95f..144d8f9bb 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -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 diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index 2e3ffb00b..c360c3eb9 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -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
- ^{widget} + ^{widget} |] @@ -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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 2e15d90ee..77533b334 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -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 diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 37ecb64fe..8389ef276 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 1c62f37a8..62d147f4b 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -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 diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 02e2fc173..0be567c66 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -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 diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index d38d37111..895b4b448 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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] diff --git a/templates/i18n/pitch/en-eu.hamlet b/templates/i18n/pitch/en-eu.hamlet index 444679976..d42ddfad6 100644 --- a/templates/i18n/pitch/en-eu.hamlet +++ b/templates/i18n/pitch/en-eu.hamlet @@ -12,4 +12,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

FRADrive supports training courses by handling # registration, correspondence, course homepages, examinations and # - managing the gained qualfications. + managing the gained qualifications. diff --git a/templates/qualification.hamlet b/templates/qualification.hamlet index 84d1547d2..3fb868c8e 100644 --- a/templates/qualification.hamlet +++ b/templates/qualification.hamlet @@ -17,7 +17,19 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $maybe daudit <- qualificationAuditDuration quali

_{MsgQualificationAuditDuration} -
_{MsgMonths (fromIntegral daudit)} +
+ $maybe lqre <- lmsQualiReused + $maybe daudit <- qualificationAuditDuration lqre + _{MsgMonths (fromIntegral daudit)} + $nothing + _{MsgQualificationAuditDurationReuseError} + $nothing + _{MsgMonths (fromIntegral daudit)} + $nothing + $maybe lqre <- lmsQualiReused + $maybe daudit <- qualificationAuditDuration lqre +
_{MsgQualificationAuditDuration} +
_{MsgMonths (fromIntegral daudit)} $maybe drefresh <- qualificationRefreshWithin quali
_{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 +
_{MsgTableQualificationLmsReusesTooltip} +
^{simpleLink (citext2widget (qualificationName lqre)) (QualificationR (qualificationSchool lqre) (qualificationShorthand lqre))}
_{MsgQualificationElearningStart}
#{boolSymbol (qualificationElearningStart quali)} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8613a76b3..fa4e426b5 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -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|

Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] let l_descr = Just $ htmlToStoredMarkup [shamlet|

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)