Merge branch 'fradrive/newletter'

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

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

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:
+    -- across all schools, only one qualification may be a driving licence -- NO LONGER TRUE
-  UniqueQualificationAvsLicence avsLicence      !force -- either empty or unique
+    -- UniqueQualificationAvsLicence avsLicence      !force -- either empty or unique 
     -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
   deriving Show Eq Generic
 

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

src/Handler/Admin/Avs.hs

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

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.&&. 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.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

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 ()
+usrPrimaryCompanies :: 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
+-- usrPrimaryCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
-usrSuperiorCompanies cmp usr = do
+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
           ]

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  
+  $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
-  (lms_users,cutoff) <- runDB $ do
+  (lms_users,cutoff,qshs) <- runDB $ do
-    (qid, cutoff) <- getQidCutoff sid qsh    
+    (qid, cutoff) <- getQidCutoff sid qsh
-    lms_users <- selectList [ LmsUserQualification ==. qid
+    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]    
+                            ] [Asc LmsUserStarted, Asc LmsUserIdent]
-    return (lms_users, cutoff)
+    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

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 :: UTCTime -> NonEmpty QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
-saveReportCsv now qid i LmsReportTableCsv{..} = do    
+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        
+                .| foldMC (saveReportCsv now qids) 0
-        return (nr, qid)
+        return (nr, qids, qshs)
-      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
+      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

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

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

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

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 -> 
+    (\current excluded ->
-        [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)  
+        [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)
-        , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] 
+        , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
-        , UserSupervisorReason  E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] 
+        , 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] 
+        , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
-        , UserSupervisorReason  E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] 
+        , 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  
+  mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId
-  case (mbOldAvsId,mbNewAvsId) of 
+  case (mbOldAvsId,mbNewAvsId) of
-    (Nothing, _) 
+    (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

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]

templates/i18n/pitch/en-eu.hamlet

@@ -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.

templates/qualification.hamlet

@@ -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)}

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|<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_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 False (Just AvsLicenceRollfeld) $ Just "R2801"
+  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_l  <- insert' $ Qualification ifi "L" "Lehrbefähigung"       l_descr Nothing   (Just 6) Nothing Nothing True False True Nothing Nothing
+  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_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_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_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)