chore(lms): implement lms termination action
also: - track last LmsSate for orphans - make note searchable towards #2605
This commit is contained in:
parent
f3f2f397fc
commit
38606949b0
@ -101,6 +101,7 @@
|
||||
"wildcard": "asterisk",
|
||||
"user-unknown": "user-slash",
|
||||
"user-badge": "id-badge",
|
||||
"glasses": "glasses"
|
||||
"glasses": "glasses",
|
||||
"missing": "question"
|
||||
}
|
||||
|
||||
|
||||
@ -103,6 +103,7 @@ $icons: new,
|
||||
glasses,
|
||||
user-badge,
|
||||
user-unknown,
|
||||
missing,
|
||||
loading;
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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 }
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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]
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-24 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2022-25 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -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} |] )
|
||||
|
||||
@ -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 }
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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")
|
||||
|
||||
Loading…
Reference in New Issue
Block a user