From 09c4eb3a7bf2d5811512d83ed9a8e33020088745 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 15 Mar 2023 17:10:32 +0000 Subject: [PATCH] chore(qualifications): use blocking mechanism (WIP) --- .../uniworx/categories/avs/de-de-formal.msg | 5 ++- messages/uniworx/categories/avs/en-eu.msg | 5 ++- .../categories/qualification/de-de-formal.msg | 10 +++-- .../categories/qualification/en-eu.msg | 12 ++++-- src/Audit/Types.hs | 22 ++++++---- src/Handler/Admin/Avs.hs | 41 ++++++++++++------- src/Handler/Qualification.hs | 35 +++++++++++++--- src/Handler/Utils/Qualification.hs | 39 +++++++++++++++++- src/Jobs/Handler/LMS.hs | 10 ++--- src/Model/Types/Lms.hs | 21 ++++++++++ templates/letter/din5008.latex | 2 +- 11 files changed, 153 insertions(+), 49 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 7a63ec25d..33f266aed 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -22,10 +22,11 @@ AvsImportAmbiguous n@Int: Import für #{show n} uneindeutige AVS IDs fehlgeschla AvsImportUnknowns n@Int: Import für #{show n} unbekannte AVS IDs fehlgeschlagen AvsSetLicences alic@AvsLicence n@Int m@Int: _{alic} im AVS gesetzt: #{show n}/#{show m} SetFraDriveLicences q@String n@Int: #{q} in FRADrive gewährt für #{show n} Benutzer -RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive zum Vortag beendet für #{show n} Fahrer +RevokeFraDriveLicencesError alic@AvsLicence: Entzug der _{alic} Lizenzen komplett fehlgeschlagen +RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive entzogen für #{show n} Fahrer RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler. LicenceTableChangeAvs: Im AVS ändern LicenceTableGrantFDrive: In FRADrive erteilen -LicenceTableRevokeFDrive: In FRADrive zum Vortag entziehen \ No newline at end of file +LicenceTableRevokeFDrive: In FRADrive entziehen \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index 91efb95f9..cadb045af 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -22,10 +22,11 @@ AvsImportAmbiguous n@Int: Import failed for #{show n} ambiguous AVS Ids AvsImportUnknowns n@Int: Import failed for #{show n} unknown AVS Ids AvsSetLicences alic n m: _{alic} set in AVS: #{show n}/#{show m} SetFraDriveLicences q@String n@Int: #{q} granted in FRADrive for #{show n} users -RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} now ended yesterday in FRADrive for #{show n} drivers +RevokeFraDriveLicencesError alic@AvsLicence: Revoking licences _{alic} failed entirely +RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} revoked in FRADrive for #{show n} drivers RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details AvsCommunicationError: AVS interface returned an unexpected error. LicenceTableChangeAvs: Change in AVS LicenceTableGrantFDrive: Grant in FRADrive -LicenceTableRevokeFDrive: Revoke yesterday in FRADrive +LicenceTableRevokeFDrive: Revoke in FRADrive diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index e99f42ec6..a26725a9b 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -20,13 +20,14 @@ TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermitte LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert TableQualificationFirstHeld: Erstmalig -TableQualificationBlockedDue: Suspendiert +TableQualificationBlockedDue: Entzogen TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen? TableQualificationNoRenewal: Storniert TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein. QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. +QualificationBlockReason: Entzugsbegründung LmsUser: Inhaber TableLmsEmail: E-Mail TableLmsIdent: LMS Identifikation @@ -70,10 +71,13 @@ MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort MailBodyQualificationRenewal qname@Text: Sie müssen die Qualifikation #{qname} demnächst durch einen E-Learning Kurs erneuern, siehe Anhang. MailBodyQualificationExpiry: Diese Qualifikation läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden! MailBodyQualificationExpired: Diese Qualifikation is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E-Learning. -QualificationActExpire: Qualifikation ohne Benachrichtigung auslaufen lassen -QualificationActUnexpire: Benachrichtigung bei anstehender Erneuerung senden +QualificationActExpire: Stornieren - Qualifikation läuft ohne Benachrichtigung ab +QualificationActUnexpire: Stornierung aufheben - Benachrichtigung bei anstehender Erneuerung senden QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E-Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"} QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E-Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"} +QualificationActBlockSupervisor: Dauerhaft zurückgeben +QualificationActBlock: Entziehen +QualificationActUnblock: Entzug löschen LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort Ihre Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach. LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Learning verlängert werden. LmsActNotify: Benachrichtigung E-Learning erneut per Post oder E-Mail versenden diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 729511c76..101ce4b3e 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -20,13 +20,14 @@ TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? On LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed TableQualificationFirstHeld: First held -TableQualificationBlockedDue: Suspended +TableQualificationBlockedDue: Revoked TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons? -TableQualificationNoRenewal: Canceled +TableQualificationNoRenewal: Cancelled TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. QualificationUserNoRenewal: Expires without further notification QualificationUserNone: No registered qualifications for this person. +QualificationBlockReason: Reason for revoking LmsUser: Licensee TableLmsEmail: Email TableLmsIdent: LMS Identifier @@ -70,10 +71,13 @@ MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid MailBodyQualificationRenewal qname: You will soon need to renew qualification #{qname} by completing an e-learning course. For details see attachment. MailBodyQualificationExpiry: This qualification expires soon. You may then no longer execute any duties that require this qualification as a precondition! MailBodyQualificationExpired: This qualification is now expired. You may no longer execute any duties that require this qualification as a precondition! It is possible that the qualification expired prematurely, e.g. due to a failed compulsory e-learning. -QualificationActExpire: Qualification shall expire silently -QualificationActUnexpire: Notify upon due renewal +QualificationActExpire: Cancel - qualification expires silently +QualificationActUnexpire: Uncancel - notify upon due renewal QualificationSetExpire n: Expiry notification and e-learning deactivated for #{n} #{pluralENs n "person"} QualificationSetUnexpire n: Expiry notification and e-learning activated for #{n} #{pluralENs n "person"} +QualificationActBlockSupervisor: Waive permanently +QualificationActBlock: Revoke +QualificationActUnblock: Clear revocation LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with your chosen FRADrive PDF-Password. If you have not yet chosen a PDF-Password yet, then the password is your Fraport id card number, inkluding the punctuation mark and the Digit thereafter. LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only. LmsActNotify: Resend e-learning notification by post or email diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 1299a11ef..195f1d878 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -197,20 +197,24 @@ data Transaction , transactionNote :: Maybe Text , transactionReceived :: UTCTime -- when was the csv file received? } - - | TransactionQualificationUserEdit - { transactionQualificationUser :: QualificationUserId - , transactionQualification :: QualificationId - , transactionUser :: UserId -- qualification holder that is updated + | TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well! + { transactionUser :: UserId -- qualification holder that is updated + , transactionQualificationUser :: QualificationUserId + , transactionQualification :: QualificationId , transactionQualificationValidUntil :: Day , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration) } | TransactionQualificationUserDelete - { transactionQualificationUser :: QualificationUserId - , transactionQualification :: QualificationId - , transactionUser :: UserId + { transactionUser :: UserId + , transactionQualificationUser :: QualificationUserId + , transactionQualification :: QualificationId + } + | TransactionQualificationUserBlocking + { transactionUser :: UserId -- qualification holder that is updated + -- , transactionQualificationUser :: QualificationUserId -- not neccessary due to UniqueQualificationUser + , transactionQualification :: QualificationId + , transactionQualificationBlock :: Maybe QualificationBlocked -- Nothing indicates unblocking } - deriving (Eq, Ord, Read, Show, Generic) deriveJSON defaultOptions diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 6d2ed633e..27158c208 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -309,11 +309,15 @@ nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LicenceTableAction id data LicenceTableActionData = LicenceTableChangeAvsData - | LicenceTableRevokeFDriveData --TODO: add { licenceTableChangeFDriveQId :: QualificationId to avoid lookup later - | LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId - , licenceTableChangeFDriveEnd :: Day - , licenceTableChangeFDriveRenew :: Maybe Bool - } + | LicenceTableRevokeFDriveData + { licenceTableChangeFDriveQId :: QualificationId + , licenceTableChangeFDriveReason :: Text + } + | LicenceTableGrantFDriveData + { licenceTableChangeFDriveQId :: QualificationId + , licenceTableChangeFDriveEnd :: Day + , licenceTableChangeFDriveRenew :: Maybe Bool + } deriving (Eq, Ord, Read, Show, Generic) @@ -393,19 +397,26 @@ getProblemAvsSynchR = do addMessageI mkind $ MsgAvsSetLicences aLic oks no_req redirect ProblemAvsSynchR -- reload to update all tables - procRes alic (LicenceTableRevokeFDriveData, apids) = do - nups <- runDB $ do + procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do + oks <- runDB $ do qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic - selectedUsers <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] - forM_ selectedUsers $ upsertQualificationUser qId nowaday (pred nowaday) Nothing - return $ length selectedUsers - addMessageI Success $ MsgRevokeFraDriveLicences alic nups + if qId /= licenceTableChangeFDriveQId + then return (-1) + else do + uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] + qualificationUserBlocking licenceTableChangeFDriveQId uids $ + Just $ QualificationBlocked + { qualificationBlockedDay = nowaday + , qualificationBlockedReason = licenceTableChangeFDriveReason + } + if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic + | oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks + | otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks redirect ProblemAvsSynchR -- must be outside runDB procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do (n, Qualification{qualificationShorthand}) <- runDB $ do - uas <- selectList [UserAvsPersonId <-. Set.toList apids] [] - let uids = view _userAvsUser <$> uas + uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew (length uids,) <$> get404 licenceTableChangeFDriveQId @@ -547,7 +558,9 @@ mkLicenceTable dbtIdent aLic apids = do acts = mconcat [ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData , if aLic == AvsNoLicence - then singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData + then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData + <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid + <*> apreq textField (fslI MsgQualificationBlockReason) Nothing else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?! diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 6b8ac748d..2aee9284a 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -236,7 +236,12 @@ instance HasEntity QualificationTableData User where instance HasUser QualificationTableData where hasUser = resultUser . _entityVal -data QualificationTableAction = QualificationActExpire | QualificationActUnexpire +data QualificationTableAction + = QualificationActExpire + | QualificationActUnexpire + | QualificationActBlockSupervisor + | QualificationActBlock + | QualificationActUnblock deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe QualificationTableAction @@ -245,12 +250,24 @@ nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''QualificationTableAction id -- Not yet needed, since there is no additional data for now: -data QualificationTableActionData = QualificationActExpireData | QualificationActUnexpireData +data QualificationTableActionData + = QualificationActExpireData + | QualificationActUnexpireData + | QualificationActBlockSupervisorData + | QualificationActBlockData { qualTableActBlockReason :: Text} + | QualificationActUnblockData deriving (Eq, Ord, Read, Show, Generic) -isExpiryAct :: QualificationTableActionData -> Bool -- const true, but this may change in the future +isExpiryAct :: QualificationTableActionData -> Bool isExpiryAct QualificationActExpireData = True isExpiryAct QualificationActUnexpireData = True +isExpiryAct _ = False + +isBlockAct :: QualificationTableActionData -> Bool +isBlockAct QualificationActBlockSupervisorData = True +isBlockAct QualificationActBlockData{} = True +isBlockAct QualificationActUnblockData = True +isBlockAct _ = False qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) @@ -400,10 +417,15 @@ postQualificationR sid qsh = do ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) - acts = mconcat + acts = mconcat $ [ singletonMap QualificationActExpire $ pure QualificationActExpireData , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData - ] + ] ++ bool + [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin Supervisor + [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData + , singletonMap QualificationActBlock $ QualificationActBlockData + <$> apreq textField (fslI MsgQualificationBlockReason) Nothing + ] isAdmin linkLmsUser = toMaybe isAdmin LmsUserR colChoices = mconcat [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) @@ -426,6 +448,7 @@ postQualificationR sid qsh = do return (tbl, qent) formResult lmsRes $ \case + -- TODO: continue here _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now (action, selectedUsers) | isExpiryAct action -> do let isUnexpire = action == QualificationActUnexpireData @@ -436,7 +459,7 @@ postQualificationR sid qsh = do msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire addMessageI msgKind msgVal redirect currentRoute - _ -> return () + _ -> addMessageI Error MsgUnauthorized -- TODO continue here let heading = citext2widget $ qualificationName quali siteLayout heading $ do diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index ecb1236f4..1e8302ecf 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -10,6 +10,7 @@ module Handler.Utils.Qualification import Import -- import Data.Time.Calendar (CalendarDiffDays(..)) +import Database.Persist.Sql (updateWhereCount) import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E @@ -100,4 +101,40 @@ renewValidQualificationUsers qid uids = , transactionQualificationScheduleRenewal = Nothing } return $ length quEnts - _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc. \ No newline at end of file + _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc. + + +-- qualificationUserBlocking :: QualificationId -> [UserId] -> Maybe QualificationBlocked -> DB Int64 +qualificationUserBlocking :: + ( AuthId (HandlerSite m) ~ Key User + , IsPersistBackend (YesodPersistBackend (HandlerSite m)) + , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend + , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m)) + , PersistQueryWrite (YesodPersistBackend (HandlerSite m)) + , PersistUniqueWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , HasAppSettings (HandlerSite m) + , MonadHandler m + , MonadCatch m + , Num n + ) => QualificationId -> [UserId] -> Maybe QualificationBlocked -> ReaderT (YesodPersistBackend (HandlerSite m)) m n + +qualificationUserBlocking qid uids qb = do + oks <- updateWhereCount -- prevents storage of transactionQualificatioUser + ( [ QualificationUserBlockedDue !=. Nothing | isNothing qb -- only unblock blocked qualification; allow overwrite for existing blocks + ] ++ + [ QualificationUserQualification ==. qid + , QualificationUserUser <-. uids + ] + ) + [ QualificationUserBlockedDue =. qb + ] + forM_ uids $ \uid -> do + audit TransactionQualificationUserBlocking + { -- transactionQualificationUser = quid + transactionQualification = qid + , transactionUser = uid + , transactionQualificationBlock = qb + } + return $ fromIntegral oks \ No newline at end of file diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 74e22651f..a860c8d6a 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -28,13 +28,11 @@ import qualified Data.Set as Set import qualified Data.Time.Zones as TZ import Handler.Utils.DateTime import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries) +import Handler.Utils.Qualification import qualified Data.CaseInsensitive as CI -blockedByElearning :: Text -blockedByElearning = "E-Learning durchgefallen" - dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue @@ -219,7 +217,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act , QualificationUserLastRefresh =. lmsResultSuccess ] -- WORKAROUND LMS-Bug: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning - when (Just blockedByElearning == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $ + when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $ update quid [ QualificationUserBlockedDue =. Nothing ] update luid [ LmsUserStatus =. Just newStatus , LmsUserReceived =. Just lmsResultTimestamp @@ -295,9 +293,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act , transactionReceived = lReceived } update luid [LmsUserStatus =. (oldStatus <> Just newStatus)] - updateBy (UniqueQualificationUser qid (lmsUserUser luser)) - [QualificationUserBlockedDue =. Just (QualificationBlocked { qualificationBlockedDay = blockedDay - , qualificationBlockedReason = blockedByElearning } )] + void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning blockedDay queueDBJob JobSendNotification { jRecipient = lmsUserUser luser , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay } diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index db6f263ca..a191f248b 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -11,6 +11,8 @@ module Model.Types.Lms ) where import Import.NoModel +import qualified Data.Map as Map +import Data.Map ((!)) import Database.Persist.Sql import qualified Database.Esqueleto.Experimental as E import qualified Data.Csv as Csv @@ -87,6 +89,25 @@ instance Csv.ToField QualificationBlocked where -- instance ToMessage QualificationBlocked where -- no longer used -- toMessage QualificationBlocked{..} = qualificationBlockedReason +data QualificationBlockStandardReason + = QualificationBlockFailedELearning + | QualificationBlockReturnedByCompany + deriving (Eq, Ord, Enum, Bounded, Universe, Finite) + +instance Show QualificationBlockStandardReason where + show QualificationBlockFailedELearning = "E-Learning durchgefallen" + show QualificationBlockReturnedByCompany = "Zurückgebeben durch Firma" + +qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text +qualificationBlockedReasonText = + let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF] + in (dictionary !) -- cannot fail due to universeF + +mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> QualificationBlocked +mkQualificationBlocked reason qualificationBlockedDay = QualificationBlocked{..} + where + qualificationBlockedReason = qualificationBlockedReasonText reason + -- | LMS interface requires Bool to be encoded by 0 or 1 only newtype LmsBool = LmsBool { lms2bool :: Bool } deriving (Eq, Ord, Read, Show, Generic) diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex index 9ad2d8280..992dcf871 100644 --- a/templates/letter/din5008.latex +++ b/templates/letter/din5008.latex @@ -145,7 +145,7 @@ $endif$ \begin{textblock}{65}(84,232)%hpos,vpos \textcolor{black!39}{ - \begin{labeling}{Password:} + \begin{labeling}{Password:}%Achtung! Die Position des Logins muss sprachunabhängig immer an der gleichen Position sein, sonst kannn die Rückmeldung der Druckerei den Ident nicht mehr identifizieren! $if(is-de)$ \item[Benutzer:] \texttt{$login$} \item[Passwort:] \texttt{$pin$}