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  
   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,7 +129,7 @@ _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)

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
@@ -175,13 +176,16 @@ 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
+  (lms_users,cutoff,qshs) <- runDB $ do
     (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]
-    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
@@ -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
@@ -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
@@ -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

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

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}
@@ -43,6 +55,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)}
       $if (qualificationElearningStart quali) && isNothing (qualificationRefreshWithin 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)