diff --git a/assets/icons-src/fontawesome.json b/assets/icons-src/fontawesome.json index 8a21484c1..538588abc 100644 --- a/assets/icons-src/fontawesome.json +++ b/assets/icons-src/fontawesome.json @@ -101,6 +101,7 @@ "wildcard": "asterisk", "user-unknown": "user-slash", "user-badge": "id-badge", -"glasses": "glasses" +"glasses": "glasses", +"missing": "question" } diff --git a/frontend/src/icons.scss b/frontend/src/icons.scss index e0b3cbf30..862f9fff0 100644 --- a/frontend/src/icons.scss +++ b/frontend/src/icons.scss @@ -103,6 +103,7 @@ $icons: new, glasses, user-badge, user-unknown, + missing, loading; diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 2d93bf47c..bb5d645c5 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -129,8 +129,7 @@ LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im ange LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden. Bitte setzen Sie sich mit uns in Verbindung, wenn Sie die Qualifikation verlängern möchten und noch nicht wissen, wie Sie das tun können. Ignorieren Sie diese automatisch generierte Erinnerung, falls Sie sich bereits um die Verlängerung gekümmert haben LmsRenewalReminder: Erinnerung LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden -LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen -LmsActRenewNotify: Neue zufällige E‑Learning Passwort zuweisen und Benachrichtigung per Post oder E-Mail versenden +LmsActRenewNotify: Neues zufälliges E‑Learning Passwort zuweisen und Benachrichtigung per Post oder E-Mail versenden LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren LmsActResetInfo: E‑Learning Login, Passwort und Fortschritt bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat. LmsActResetFeedback n@Int m@Int: Für #{n}/#{m} E‑Learning Nutzer wurden alle Fehlversuche zurückgesetzt. @@ -139,6 +138,10 @@ LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E‑Learning Nutzer wurden komplett neu gestartet mit neuem Login und Passwort. LmsActRestartExtend: Gültig bis ggf. erhöhen für die nächsten # Tage LmsActRestartUnblock: Entzug ggf. aufheben +LmsActTerminate: E‑Learning abbrechen +LmsActTerminateInfo: Ein späterer automatischer Neustart des E‑Learning wird dadurch nicht verhindert, wenn eine gültige Qualifikation bald abläuft und E‑Learning für diese Qualifikation generell automatisch startet. +LmsActTerminateFeedback n@Int m@Int: #{n}/#{m} E‑Learning Nutzer wurden zur Löschung freigegeben. +LmsActTerminateWarning: ACHTUNG: Ein Ergebnis würde ohne Warnung verworfen, sollte ein Nutzer sein E‑Learning absolvieren, bevor die Löschung beim E‑learning Server effektiv wurde. LmsStateOpen: E‑Learning offen LmsStatusLocked: E‑Learning gesperrt, wird ggf. bald geöffnet LmsStatusUnlocked: E‑Learning offen, wird ggf. bald gesperrt diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 7c6435860..a31f86360 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -129,7 +129,6 @@ LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclose LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only. Please contact us, if you do not yet know how to renew this qualification. Ignore this automatically generated reminder email, if you have made arrangements for the renewal of this qualification already. LmsRenewalReminder: Reminder LmsActNotify: Resend e‑learning notification by post or email -LmsActRenewPin: Randomly replace e‑learning password LmsActRenewNotify: Randomly replace e‑learning password and re-send notification by post or email LmsActReset: Reset and unlock e‑learning LmsActResetInfo: E‑learning login, password and progress remain unchanged; a notification is thus not necessary. This is only possible for already failed learners. Note that the reset procedure may take up to 2 hours. @@ -138,7 +137,11 @@ LmsActRestart: Restart e‑learning LmsActRestartWarning: The existing e‑learning will be erased immediately! For drivers with a valid licence, user and password will later be generated anew and a notification will be queued as usual, which may take several hours. LmsActRestartExtend: Ensure validity for the next # days LmsActRestartUnblock: Undo any revocations -LmsActRestartFeedback n@Int m@Int: #{n}/#{m} e-learnings were completely restarted with new login credentials. +LmsActRestartFeedback n m: #{n}/#{m} e-learnings were completely restarted with new login credentials. +LmsActTerminate: Abort e‑learning +LmsActTerminateInfo: E‑learning may restart later, if a valid qualification is about to expire and e-learning starting automatically for this qualification. +LmsActTerminateFeedback n m: #{n}/#{m} e‑learnings marked for termination. +LmsActTerminateWarning: WARNING: Results will be discarded without warning if a user completes their e-learning in the meantime, before the deletion became effective on the e‑learning server. LmsStateOpen: E‑learning open LmsStatusLocked: E‑learning locked, may be opened soon LmsStatusUnlocked: E‑learning still open, may be locked soon diff --git a/models/lms.model b/models/lms.model index 996094e18..fdc7a33c8 100644 --- a/models/lms.model +++ b/models/lms.model @@ -171,7 +171,8 @@ LmsOrphan ident LmsIdent -- must be unique accross all LMS courses! seenFirst UTCTime default=now() -- first time reported by LMS seenLast UTCTime default=now() -- last acknowledgement by LMS, deletion uses QualificationAuditDuration - deletedLast UTCTime Maybe -- last deletion request sent to LMS - reason Text Maybe -- to mark explicit e-learning deletions, etc + deletedLast UTCTime Maybe -- last deletion request sent to LMS + resultLast LmsState -- last received learning state + reason Text Maybe -- to mark explicit e-learning deletions, etc UniqueLmsOrphan qualification ident -- unlike other tables, LMS Idents must only be unique within qualification, allowing orphans to be handled independently deriving Generic Show \ No newline at end of file diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 74598dee9..fa493f97e 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -355,9 +355,9 @@ instance HasQualificationUser LmsTableData where data LmsTableAction = LmsActNotify | LmsActRenewNotify - | LmsActRenewPin | LmsActReset | LmsActRestart + | LmsActTerminate deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -366,7 +366,7 @@ embedRenderMessage ''UniWorX ''LmsTableAction id data LmsTableActionData = LmsActNotifyData | LmsActRenewNotifyData - | LmsActRenewPinData -- no longer used + | LmsActTerminateData | LmsActResetData { lmsActRestartExtend :: Maybe Integer , lmsActRestartUnblock :: Maybe Bool @@ -386,7 +386,6 @@ isNotifyAct _ = False isRenewPinAct :: LmsTableActionData -> Bool isRenewPinAct LmsActRenewNotifyData = True -isRenewPinAct LmsActRenewPinData = True isRenewPinAct _ = False isResetAct :: LmsTableActionData -> Bool @@ -601,15 +600,15 @@ postLmsR sid qsh = do let nowaday = utctDay now msgResetInfo <- messageIconI Info IconNotificationNonactive MsgLmsActResetInfo msgRestartWarning <- messageIconI Warning IconWarning MsgLmsActRestartWarning + msgTerminateInfo <- messageIconI Info IconNotificationNonactive MsgLmsActTerminateInfo ((lmsRes, lmsTable), Entity qid quali, lmsQualiReused) <- runDB $ do - qent@Entity{entityVal=Qualification{qualificationLmsReuses = reuseQuali}} <- getBy404 $ SchoolQualificationShort sid qsh + qent@Entity{entityVal=Qualification{qualificationLmsReuses = reuseQuali, qualificationElearningStart = elearnStart, qualificationRefreshWithin = refreshWithin}} <- getBy404 $ SchoolQualificationShort sid qsh lmsQualiReused <- traverseJoin get reuseQuali let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) acts = mconcat [ singletonMap LmsActNotify $ pure LmsActNotifyData , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData - -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData , singletonMap LmsActReset $ LmsActResetData <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing @@ -621,6 +620,7 @@ postLmsR sid qsh = do <*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing <* aformMessage msgRestartWarning + , singletonMap LmsActTerminate $ bool pure (<$ aformMessage msgTerminateInfo) (elearnStart && isJust refreshWithin) LmsActTerminateData ] colChoices getCompanyName = mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) @@ -702,6 +702,14 @@ postLmsR sid qsh = do formResult lmsRes $ \case _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page + (LmsActTerminateData, selectedUsers) -> do + let usersList = Set.toList selectedUsers + numUsers = Set.size selectedUsers + numDel <- runDB $ terminateLms LmsOrphanReasonManualTermination qid usersList -- calls audit by itself + let mStatus = bool Success Warning $ numDel < numUsers + addMessageI mStatus $ someMessages [MsgLmsActTerminateFeedback numDel numUsers, MsgLmsActTerminateWarning] + reloadKeepGetParams $ LmsR sid qsh + (action, selectedUsers) | isResetRestartAct action -> do let usersList = Set.toList selectedUsers numUsers = Set.size selectedUsers diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index bb2069720..7f42d2b59 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -280,17 +280,19 @@ getLmsOrphansR sid qsh = do dbtRowKey = (E.^. LmsOrphanId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanIdent . _getLmsIdent -> lid) -> textCell lid - , sortable (Just "seen-first") (i18nCell MsgLmsOrphanSeenFirst) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenFirst -> d) -> dateTimeCell d - , sortable (Just "seen-last") (i18nCell MsgLmsOrphanSeenLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenLast -> d) -> dateTimeCell d - , sortable (Just "deleted-last") (i18nCell MsgLmsOrphanDeletedLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanDeletedLast -> d) -> foldMap dateTimeCell d - , sortable (Just "reason") (i18nCell MsgLmsOrphanReason) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanReason -> t) -> foldMap textCell t + [ sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanIdent . _getLmsIdent -> lid) -> textCell lid + , sortable (Just "seen-first") (i18nCell MsgLmsOrphanSeenFirst) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenFirst -> d) -> dateTimeCell d + , sortable (Just "seen-last") (i18nCell MsgLmsOrphanSeenLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenLast -> d) -> dateTimeCell d + , sortable (Just "deleted-last") (i18nCell MsgLmsOrphanDeletedLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanDeletedLast -> d) -> cellMaybe dateTimeCell d + , sortable (Just "status") (i18nCell MsgTableLmsStatus) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanResultLast -> s) -> lmsStateCell s + , sortable (Just "reason") (i18nCell MsgLmsOrphanReason) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanReason -> t) -> cellMaybe textCell t ] dbtSorting = Map.fromList [ ("ident" , SortColumn (E.^. LmsOrphanIdent)) , ("seen-first" , SortColumn (E.^. LmsOrphanSeenFirst)) , ("seen-last" , SortColumn (E.^. LmsOrphanSeenLast)) , ("deleted-last" , SortColumn (E.^. LmsOrphanDeletedLast)) + , ("status" , SortColumn (E.^. LmsOrphanResultLast)) , ("reason" , SortColumn (E.^. LmsOrphanReason)) ] cachedNextOrphans = $(memcachedByHere) (Just $ Right $ 1 * diffMinute) ("cache-next-orphans" <> tshow qid) $ do @@ -300,6 +302,7 @@ getLmsOrphansR sid qsh = do return $ map fst next_orphans dbtFilter = Map.fromList [ ("ident" , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsOrphanIdent)) + , ("reason" , FilterColumn $ E.mkContainsFilterWith Just (E.^. LmsOrphanReason)) , ("preview" , FilterColumnHandler $ \case (x:_) | x == tshow True -> do @@ -315,6 +318,7 @@ getLmsOrphansR sid qsh = do dbtFilterUI mPrev = mconcat [ -- prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgLmsOrphanPreviewFltr) -- NOTE: anticipated checkBoxTextField-hack not needed here prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgLmsOrphanPreviewFltr) + , prismAForm (singletonFilter "reason" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgLmsOrphanReason) , prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index f0067fd0b..d4193a82b 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -31,7 +31,8 @@ module Handler.Utils.Memcached newtype Foo1 = Foo1 { someInt1 :: Int } deriving newtype (Binary) data Foo2 = Foo2 { someInt2 :: Int } deriving (Binary) type Foo3 = Int - Therefore it is best to use $(memcachedHere) or $(memcachedByHere) if possible or add another type + Therefore it is best to use $(memcachedHere) or $(memcachedByHere) if possible or add another type, + a newtype wrapper is NOT enough to distinguish keys! -} import Import.NoFoundation hiding (utc, exp) @@ -297,6 +298,8 @@ manageMemcachedLocalInvalidations localARC iQueue = PostgresqlChannelManager } -} +-- WARNING: newtype-wrapper is ignored by Binary instance, see Handlet.Utils.Qualification for the experiment! + newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a } deriving newtype (Eq, Ord, Show, Binary) instance NFData a => NFData (MemcachedUnkeyed a) where @@ -383,6 +386,7 @@ memcachedInvalidateClass mkc = maybeT_ $ do catchIfMaybeT Memcached.isKeyNotFound . flip Memcached.delete memcachedConn lift $ memcachedByInvalidate mkc (Proxy @MemcachedKeyClassStore) +-- WARNING: newtype-wrapper is ignored by Binary instance, see Handlet.Utils.Qualification for the experiment! newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a } deriving newtype (Eq, Ord, Show, Binary) instance NFData a => NFData (MemcachedUnkeyedLoc a) where @@ -400,6 +404,7 @@ memcachedHere = do loc <- location [e| \mExp -> withMemcachedUnkeyedLoc (memcachedBy mExp loc) |] +-- WARNING: newtype-wrapper is ignored by Binary instance, see Handlet.Utils.Qualification for the experiment! newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a } deriving newtype (Eq, Ord, Show, Binary) instance NFData a => NFData (MemcachedKeyedLoc a) where diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 0ed25fedd..718061741 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -13,13 +13,13 @@ import Import import qualified Data.Text as Text -- import Data.Time.Calendar (CalendarDiffDays(..)) --- import Database.Persist.Sql (updateWhereCount) +import Database.Persist.Sql (deleteWhereCount) -- (updateWhereCount) import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E import Handler.Utils.Widgets (statusHtml) import Handler.Utils.Memcached - +import Handler.Utils.DateTime (addLocalDays) retrieveQualification :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification) retrieveQualification qid = liftHandler $ $(memcachedByHere) (Just . Right $ 7 * diffHour) qid $ runDBRead $ get qid @@ -185,11 +185,11 @@ selectRelevantBlock :: UTCTime -> QualificationUserId -> DB (Maybe (Entity Quali selectRelevantBlock cutoff quid = selectFirst [QualificationUserBlockQualificationUser ==. quid, QualificationUserBlockFrom <=. cutoff] [Desc QualificationUserBlockFrom] + ------------------------ -- Complete Functions -- ------------------------ - upsertQualificationUser :: QualificationId -> UTCTime -> Day -> Maybe Bool -> Text -> UserId -> DB () -- ignores blocking upsertQualificationUser qualificationUserQualification startTime qualificationUserValidUntil mbScheduleRenewal reason qualificationUserUser = do let qualificationUserLastRefresh = utctDay startTime @@ -368,3 +368,55 @@ qualOpt (Entity qualId qual) = do , optionExternalValue = tshow cQualId } -} + + +----------------- +-- LMS related -- +----------------- + +data LmsOrphanReason + = LmsOrphanReasonManualTermination + | LmsOrphanReasonB + | LmsOrphanReasonC + deriving (Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (Universe, Finite, NFData) + +-- NOTE: it is intentional not to have an embedRenderMessage here; within the DB, we allow arbitrary text, but we do match on these ones to recognise certain functions +-- so do not change values here without a proper migration +instance Show LmsOrphanReason where + show LmsOrphanReasonManualTermination = "Manuell abgebrochen" + show LmsOrphanReasonB = "B" + show LmsOrphanReasonC = "C" + +-- | Remove user from e-learning for given qualification and add to LmsOrphan dated back for immediate deletion. Calls audit +terminateLms :: LmsOrphanReason -> QualificationId -> [UserId] -> DB Int +terminateLms _ _ [] = return 0 +terminateLms reason qid uids = do + now <- liftIO getCurrentTime + orphanDelDays <- getsYesod $ view $ _appLmsConf . _lmsOrphanDeletionDays + let delSeenFirst = addLocalDays (negate orphanDelDays) now + tReason = Just $ tshow reason + lusers <- selectList [LmsUserQualification ==. qid, LmsUserUser <-. uids] [] -- relies on UniqueLmsQualificationUser + if null lusers then return 0 else do + forM_ lusers $ \Entity{entityVal=LmsUser{..}} -> do + void $ upsertBy (UniqueLmsOrphan lmsUserQualification lmsUserIdent) LmsOrphan + { lmsOrphanQualification = lmsUserQualification + , lmsOrphanIdent = lmsUserIdent + , lmsOrphanSeenFirst = delSeenFirst -- ensure fast deletion, since users might still to e-learning + , lmsOrphanSeenLast = now -- ensure fast deletion -- fromMaybe now $ lmsUserLastReceived + , lmsOrphanDeletedLast = Nothing + , lmsOrphanResultLast = lmsUserStatus & lmsStatus2State + , lmsOrphanReason = tReason + } -- update should not happen, but just in case ensure fast deletion + [ LmsOrphanSeenFirst =. delSeenFirst + , LmsOrphanSeenLast =. now + , LmsOrphanReason =. tReason + ] + audit TransactionLmsTerminated + { transactionQualification = lmsUserQualification + , transactionLmsIdent = lmsUserIdent + , transactionLmsUser = lmsUserUser + , transactionNote = tReason + } + fromIntegral <$> deleteWhereCount [LmsUserId <-. fmap entityKey lusers] + diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 85f1fc68e..2a1064beb 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-24 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -52,6 +52,10 @@ writerCell act = mempty & cellContents %~ (<* act) cellMaybe :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b cellMaybe = foldMap +-- like cellMaybe, but explicitely indicating Nothing by a something-is-missing icon +cellMaybe' :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b +cellMaybe' = maybe (iconCell IconMissing) + -- for documentation purposes and better error message maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b maybeCell = flip foldMap diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 4caf5fad7..76b9c63a3 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -410,10 +410,12 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.<&> E.val now E.<&> E.val now E.<&> E.nothing + E.<&> (lreport E.^. LmsReportResult) E.<&> E.nothing ) - (\_old _new -> - [ LmsOrphanSeenLast E.=. E.val now + (\_old new -> + [ LmsOrphanSeenLast E.=. new E.^. LmsOrphanSeenLast + , LmsOrphanResultLast E.=. new E.^. LmsOrphanResultLast ] ) when (orv_upd > 0) ( $logInfoS "LMS" [st|Orphans upserted for #{qshort}: #{tshow orv_upd} |] ) diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index ac6419dfa..6d254e3e3 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -33,8 +33,8 @@ deriveJSON defaultOptions , omitNothingFields = True } ''LmsIdent --- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS? --- ...also see similar type QualificationBlocked +-- | Type to track E-Learning status, usually paired with a date within DB. +-- It is more fine grained than @LmsState as reported by LMS itself. data LmsStatus = LmsExpired | LmsBlocked | LmsSuccess @@ -127,6 +127,13 @@ deriveJSON defaultOptions derivePersistFieldJSON ''LmsState nullaryPathPiece ''LmsState $ camelToPathPiece' 1 +-- | Simplistic conversion used in LmsOrphan tracking +lmsStatus2State :: Maybe LmsStatus -> LmsState +lmsStatus2State Nothing = LmsOpen +lmsStatus2State (Just LmsSuccess) = LmsPassed +lmsStatus2State (Just LmsExpired) = LmsFailed +lmsStatus2State (Just LmsBlocked) = LmsFailed + -- | LMS interface requires day format not compliant with iso8601; also LMS uses LOCAL TIMEZONE newtype LmsDay = LmsDay { lms2day :: Day } diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 0bdb9a889..4399e5176 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -188,6 +188,7 @@ replaceEntity Entity{..} = replace entityKey entityVal -- Notes on upsertBy: -- * Unique denotes old record -- * Changes to fields involved in uniqueness work, but may throw an error if updated record already exists +-- * Use Database.Esqueleto.PostgreSQL.upsertBy for more elaborate conflict updates -- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint upsertBySafe :: ( MonadIO m diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index aa7576c22..c83a52909 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -133,6 +133,8 @@ data Icon | IconUserUnknown -- no info for user found, e.g. AVS lookup failed | IconUserBadge -- something about user-avs, e.g. badge in-/valid | IconGlasses -- user must wear glasses while driving + -- | IconPlaceholder -- reserved and sued by the frontend for actual missing errors + | IconMissing -- something is missing or not applicable, less obtrusive than IconPlaceholder deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index a3b8deba6..d4d21f0c8 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -796,12 +796,12 @@ fillDb = do void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just LmsBlocked) (Just $ n_day' (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing True True void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing False False - void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-1") now now Nothing (Just "should show, no transmit") - void . insert' $ LmsOrphan qid_f (LmsIdent "do-del-2") (n_day' (-128)) now Nothing (Just "should show, do transmit") - void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-3") (n_day' (-128)) (n_day' (-100)) Nothing (Just "should show, no transmit") - void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-4") (n_day' (-128)) now (Just now) (Just "should show, no transmit") - void . insert' $ LmsOrphan qid_f (LmsIdent "do-del-5") (n_day' (-128)) now (Just (n_day' (-100))) (Just "should show, do transmit") - void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-6") (n_day' ( -5)) now (Just (n_day' ( -3))) (Just "should show, no transmit") + void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-1") now now Nothing LmsOpen (Just "no transmit 1") + void . insert' $ LmsOrphan qid_f (LmsIdent "do-del-2") (n_day' (-128)) now Nothing LmsFailed (Just "do transmit 2") + void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-3") (n_day' (-128)) (n_day' (-100)) Nothing LmsOpen (Just "no transmit 3") + void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-4") (n_day' (-128)) now (Just now) LmsPassed (Just "no transmit 4") + void . insert' $ LmsOrphan qid_f (LmsIdent "do-del-5") (n_day' (-128)) now (Just (n_day' (-100))) LmsPassed (Just "do transmit 5") + void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-6") (n_day' ( -5)) now (Just (n_day' ( -3))) LmsFailed (Just "no transmit 6") void . insert $ PrintJob "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing void . insert $ PrintJob "TestJob2" "AckTestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing Nothing (Just qid_f) (Just $ LmsIdent "ijk")