From fcc802753a75f0829238e3cbdce46dfc0d7ca4e7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 18:11:02 +0100 Subject: [PATCH] chore(lms): remove obsolete lms handlers v1 --- .../categories/qualification/de-de-formal.msg | 6 - .../categories/qualification/en-eu.msg | 6 - .../utils/navigation/menu/de-de-formal.msg | 2 - .../uniworx/utils/navigation/menu/en-eu.msg | 2 - models/lms.model | 37 +-- routes | 9 - src/Foundation/Navigation.hs | 30 +- src/Handler/LMS.hs | 12 +- src/Handler/LMS/Result.hs | 293 ------------------ src/Handler/LMS/Userlist.hs | 288 ----------------- src/Handler/Utils/LMS.hs | 10 - src/Jobs/Handler/LMS.hs | 127 +------- src/Jobs/Types.hs | 6 +- src/Utils/Lens.hs | 2 - test/Database/Fill.hs | 6 - 15 files changed, 11 insertions(+), 825 deletions(-) delete mode 100644 src/Handler/LMS/Result.hs delete mode 100644 src/Handler/LMS/Userlist.hs diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 1571d7ac1..e0fee7cb8 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -84,14 +84,8 @@ CsvColumnLmsDate: Datum des E‑Learning Ereignisses CsvColumnLmsResetTries: Anzahl der bisher verbrauchten E‑Learning Prüfungsversuche zurücksetzen CsvColumnLmsLock: E‑Learning Login gesperrt CsvColumnLmsResult !ident-ok: LMS Status -LmsUserlistInsert: Neuer LMS User -LmsUserlistUpdate: LMS User Aktualisierung -LmsResultInsert: Neues LMS Ergebnis -LmsResultUpdate: LMS Ergebnis Aktualisierung LmsReportInsert: Neues LMS Ereignis LmsReportUpdate: LMS Ereignis Aktualisierung -LmsResultCsvExceptionDuplicatedKey: CSV-Import LmsResult fand uneindeutigen Schlüssel -LmsUserlistCsvExceptionDuplicatedKey: CSV-Import LmsUserlist fand uneindeutigen Schlüssel LmsReportCsvExceptionDuplicatedKey: CSV-Import LmsReport fand uneindeutigen Schlüssel LmsDirectUpload: Direkter Upload für automatisierte Systeme LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 5d466355b..c886cb843 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -84,14 +84,8 @@ CsvColumnLmsResetTries: Reset number of used up e‑learning exam attempts CsvColumnLmsDate: Date of e‑learning event CsvColumnLmsResult: LMS Status CsvColumnLmsLock: E‑learning login is not permitted -LmsUserlistInsert: New LMS user -LmsUserlistUpdate: Update of LMS user -LmsResultInsert: New LMS result -LmsResultUpdate: Update of LMS result LmsReportInsert: New LMS event LmsReportUpdate: Update of LMS event -LmsResultCsvExceptionDuplicatedKey: CSV import LmsResult with ambiguous key -LmsUserlistCsvExceptionDuplicatedKey: CSV import LmsUserlist with ambiguous key LmsReportCsvExceptionDuplicatedKey: CSV Import LmsReport with ambiguous key LmsDirectUpload: Direct upload for automated systems LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set. diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index b306bfdfc..d7d246ed3 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -124,8 +124,6 @@ MenuLmsUser: Benutzerqualifikationen MenuLmsUserSchool: Bereichs Benutzerqualifikationen MenuLmsUserAll: Alle Benutzerqualifikationen MenuLmsUsers: Veralteter Export E‑Learning Benutzer -MenuLmsUserlist: Veraltetes Melden E‑Learning Benutzer -MenuLmsResult: Veralteter Melden Ergebnisse E‑Learning MenuLmsUpload: Hochladen MenuLmsDirectUpload: Direkter Upload MenuLmsDirectDownload: Direkter Download diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index c8c18365f..02e25ca1e 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -125,8 +125,6 @@ MenuLmsUser: User Qualifications MenuLmsUserSchool: Institute User Qualifications MenuLmsUserAll: All User Qualifications MenuLmsUsers: Legacy download e‑learning users -MenuLmsUserlist: Legacy upload e‑learning users -MenuLmsResult: Legacy upload r‑learning results MenuLmsUpload: Upload MenuLmsDirectUpload: Direct Upload MenuLmsDirectDownload: Direct Download diff --git a/models/lms.model b/models/lms.model index 4ba0f3927..d9f4c1b7e 100644 --- a/models/lms.model +++ b/models/lms.model @@ -95,25 +95,20 @@ QualificationUserBlock -- - delete-flag: isJust LmsUserStatus -- Note: REST means that LmsUserResetPin and LmsUserDelete remain unchanged by this GET request! -- - -- 3. REST POST Userlist.csv: just save as is to LmsUserlist + -- 3. REST POST Report.csv: just save as is to LmsReport for later processing -- - -- 4. REST POST Ergebnisse.csv: just save as is to LmsResult - -- - -- 5. When received: Job LmsUserlist: -- Note: containment needs at-once processing + -- 4. When received: Job LmsReport: -- Note: containment needs at-once processing -- - For all LmsUser: -- + if contained: -- set LmsUserReceived to Just now() - -- if LmsUserlistFailed: set LmsUserStatus to Just LmsBlocked now + -- if Failed: set LmsUserStatus to Just LmsBlocked now + -- if Success: set LmsUserStatus to Just LmsSuccess now + -- and renew QualificationValidTo -- + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now() -- - move row to LmsAudit -- - -- 6. When received: Daily Job LmsResult: - -- - set LmsUserReceived to Just now() -- always - -- - set LmsUserStatus to Just LmsSuccess now -- conditional - -- - and renew QualificationValidTo - -- - move row to LmsAudit - -- - -- 7. Daily Job: dequeue LMS Users + -- 5. Daily Job: dequeue LMS Users + -- - fail and mark expired LmsUser -- - remove from LmsUser after audit Period has passed LmsUser @@ -144,24 +139,6 @@ LmsUser -- UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history -- deriving Generic --- DEPRECATED V1 LmsUserlist stores LMS upload for later processing only -LmsUserlist - qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent - failed Bool - timestamp UTCTime default=now() - UniqueLmsUserlist qualification ident - deriving Generic Show - --- DEPRECATED V1 LmsResult stores LMS upload for later processing only -LmsResult - qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent - success Day -- BEWARE: timezone is local as submitted by LMS - timestamp UTCTime default=now() - UniqueLmsResult qualification ident -- required by DBTable - deriving Generic - -- V2 Stores LMS upload for processing in Background Job LmsReport qualification QualificationId OnDeleteCascade OnUpdateCascade diff --git a/routes b/routes index 0ea40300c..34891b367 100644 --- a/routes +++ b/routes @@ -279,15 +279,6 @@ /lms/#SchoolId LmsSchoolR GET /lms/#SchoolId/#QualificationShorthand LmsR GET POST /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST --- old V1 LMS Interface -/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS -/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST -/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development -/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS, also remove JobLmsUserlist constructor -/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development -/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS, also remove JobLmsResults constructor -- new V2 LMS Interface /lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET /lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 1d0258e31..59e430487 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -185,14 +185,6 @@ breadcrumb (LmsR ssh qsh) = useRunDB . maybeT (i18nCrumb MsgBrea guardM . lift . existsBy $ SchoolQualificationShort ssh qsh return (CI.original qsh, Just $ LmsSchoolR ssh) breadcrumb (LmsEditR ssh qsh) = i18nCrumb MsgMenuLmsEdit $ Just $ LmsR ssh qsh -breadcrumb (LmsUsersR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR ssh qsh -breadcrumb (LmsUsersDirectR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsUsersR ssh qsh -- never displayed, TypedContent -breadcrumb (LmsUserlistR ssh qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR ssh qsh -breadcrumb (LmsUserlistUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh -breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh -- never displayed -breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh -breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed -- v2 breadcrumb (LmsLearnersR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsR ssh qsh breadcrumb (LmsLearnersDirectR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsLearnersR ssh qsh -- never displayed, TypedContent @@ -2375,27 +2367,7 @@ pageActions (LmsR sid qsh) = return [ defNavLink MsgMenuLmsUpload $ LmsReportUploadR sid qsh , defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh ] - } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh - -- ] - } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh - -- , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh - -- ] - } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh - -- , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh - -- ] - } + } , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh } diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 5bf9beb94..abc8d8bd6 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -11,13 +11,7 @@ module Handler.LMS , getLmsR , postLmsR , getLmsIdentR , getLmsEditR , postLmsEditR - -- V1 - , getLmsUsersR , getLmsUsersDirectR - , getLmsUserlistR , postLmsUserlistR - , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR - , getLmsResultR , postLmsResultR - , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR - -- V1 + -- V2 , getLmsLearnersR , getLmsLearnersDirectR , getLmsReportR , postLmsReportR , getLmsReportUploadR , postLmsReportUploadR , postLmsReportDirectR @@ -50,10 +44,6 @@ import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Database.Persist.Sql (deleteWhereCount, updateWhereCount) --- V1 -import Handler.LMS.Users as Handler.LMS -import Handler.LMS.Userlist as Handler.LMS -import Handler.LMS.Result as Handler.LMS -- V2 import Handler.LMS.Learners as Handler.LMS import Handler.LMS.Report as Handler.LMS diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs deleted file mode 100644 index aca551ab6..000000000 --- a/src/Handler/LMS/Result.hs +++ /dev/null @@ -1,293 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances - -module Handler.LMS.Result - ( getLmsResultR, postLmsResultR - , getLmsResultUploadR, postLmsResultUploadR - , postLmsResultDirectR - ) - where - -import Import - -import Handler.Utils -import Handler.Utils.Csv -import Handler.Utils.LMS - -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 qualified Database.Esqueleto.Utils as E - -import Jobs.Queue - - -data LmsResultTableCsv = LmsResultTableCsv - { csvLRTident :: LmsIdent - , csvLRTsuccess :: LmsDay - } - deriving Generic -makeLenses_ ''LmsResultTableCsv - --- csv without headers -instance Csv.ToRecord LmsResultTableCsv -- default suffices -instance Csv.FromRecord LmsResultTableCsv -- default suffices - --- csv with headers -lmsResultTableCsvHeader :: Csv.Header -lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ] - -instance ToNamedRecord LmsResultTableCsv where - toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord - [ csvLmsIdent Csv..= csvLRTident - , csvLmsSuccess Csv..= csvLRTsuccess - ] - -instance FromNamedRecord LmsResultTableCsv where - parseNamedRecord (lsfHeaderTranslate -> csv) - = LmsResultTableCsv - <$> csv Csv..: csvLmsIdent - <*> csv Csv..: csvLmsSuccess - -instance CsvColumnsExplained LmsResultTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsSuccess MsgCsvColumnLmsSuccess - ] - where - single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget - single k v = singletonMap k [whamlet|_{v}|] - -data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate - deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) -embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id - --- By coincidence the action type is identical to LmsResultTableCsv -data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } - | LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } - deriving (Eq, Ord, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert - , fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success - , sumEncoding = TaggedObject "action" "data" - } ''LmsResultCsvAction - -data LmsResultCsvException - = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! - deriving (Show, Generic) - -instance Exception LmsResultCsvException -embedRenderMessage ''UniWorX ''LmsResultCsvException id - -mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkResultTable sid qsh qid = do - now_day <- utctDay <$> liftIO getCurrentTime - dbtCsvName <- csvFilenameLmsResult qsh - let dbtCsvSheetName = dbtCsvName - let - resultDBTable = DBTable{..} - where - dbtSQLQuery lmsresult = do - E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid - return lmsresult - dbtRowKey = (E.^. LmsResultId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident - , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success - , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp - ] - dbtSorting = Map.fromList - [ (csvLmsIdent , SortColumn (E.^. LmsResultIdent)) - , (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess)) - , (csvLmsTimestamp, SortColumn (E.^. LmsResultTimestamp)) - ] - dbtFilter = Map.fromList - [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent)) - , (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess)) - ] - dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess) - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "lms-result" - dbtCsvEncode = Just DBTCsvEncode - { dbtCsvExportForm = pure () - , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) - , dbtCsvName - , dbtCsvSheetName - , dbtCsvNoExportData = Just id - , dbtCsvHeader = const $ return lmsResultTableCsvHeader - , dbtCsvExampleData = Just - [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } - | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] - ] - } - where - doEncode' = LmsResultTableCsv - <$> view (_dbrOutput . _entityVal . _lmsResultIdent) - <*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay) - dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later - { dbtCsvRowKey = \LmsResultTableCsv{..} -> - fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident - , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first - DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do - yield $ LmsResultInsertData - { lmsResultInsertIdent = csvLRTident dbCsvNew - , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day - } - DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code - DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do - let successDay = lms2day csvLRTsuccess - when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $ - yield $ LmsResultUpdateData - { lmsResultInsertIdent = csvLRTident - , lmsResultInsertSuccess = successDay - } - DBCsvDiffMissing{} -> return () -- no deletion - , dbtCsvClassifyAction = \case - LmsResultInsertData{} -> LmsResultInsert - LmsResultUpdateData{} -> LmsResultUpdate - , dbtCsvCoarsenActionClass = \case - LmsResultInsert -> DBCsvActionNew - LmsResultUpdate -> DBCsvActionExisting - , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error - , dbtCsvExecuteActions = do - C.mapM_ $ \actionData -> do - now <- liftIO getCurrentTime - void $ upsert - LmsResult - { lmsResultQualification = qid - , lmsResultIdent = lmsResultInsertIdent actionData - , lmsResultSuccess = lmsResultInsertSuccess actionData - , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? - } - [ LmsResultSuccess =. lmsResultInsertSuccess actionData - , LmsResultTimestamp =. now - ] - -- audit $ Transaction.. (add to Audit.Types) - lift . queueDBJob $ JobLmsResults qid - return $ LmsResultR sid qsh - , dbtCsvRenderKey = const $ \case - LmsResultInsertData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Insert: Ident #{getLmsIdent lmsResultInsertIdent} # - had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} - |] - LmsResultUpdateData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Update: Ident #{getLmsIdent lmsResultInsertIdent} # - had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} - |] - , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure - , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text - } - dbtExtraReps = [] - - resultDBTableValidator = def - & defaultSorting [SortAscBy csvLmsIdent] - dbTable resultDBTableValidator resultDBTable - -getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsResultR = postLmsResultR -postLmsResultR sid qsh = do - let directUploadLink = LmsResultUploadR sid qsh - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkResultTable sid qsh qid - siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsResult - $(widgetFile "lms-result") - - --- Direct File Upload/Download - -saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int -saveResultCsv qid i LmsResultTableCsv{..} = do - now <- liftIO getCurrentTime - void $ upsert - LmsResult - { lmsResultQualification = qid - , lmsResultIdent = csvLRTident - , lmsResultSuccess = csvLRTsuccess & lms2day - , lmsResultTimestamp = now - } - [ LmsResultSuccess =. (csvLRTsuccess & lms2day) - , LmsResultTimestamp =. now - ] - return $ succ i - -makeResultUploadForm :: Form FileInfo -makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV" - -getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsResultUploadR = postLmsResultUploadR -postLmsResultUploadR sid qsh = do - ((result,widget), enctype) <- runFormPost makeResultUploadForm - case result of - FormSuccess file -> do - -- content <- fileSourceByteString file - -- return $ Just (fileName file, content) - nr <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - nr <- runConduit $ fileSource file - .| decodeCsv - .| foldMC (saveResultCsv qid) 0 - queueJob' $ JobLmsResults qid - return nr - addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") - redirect $ LmsResultR sid qsh - FormFailure errs -> do - forM_ errs $ addMessage Error . toHtml - redirect $ LmsResultUploadR sid qsh - FormMissing -> - siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsUpload - [whamlet|$newline never -
- ^{widget} -

- - |] - - -postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html -postLmsResultDirectR sid qsh = do - (_params, files) <- runRequestBody - (status, msg) <- case files of - [(fhead,file)] -> do - lmsDecoder <- getLmsCsvDecoder - runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - enr <- try $ runConduit $ fileSource file - .| lmsDecoder - .| foldMC (saveResultCsv qid) 0 - case enr of - Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error - $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e - return (badRequest400, "Exception: " <> tshow e) - Right nr -> do - let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " - $logInfoS "LMS" msg - when (nr > 0) $ queueJob' $ JobLmsResults qid - return (ok200, msg) - [] -> do - let msg = "Result upload file missing." - $logWarnS "LMS" msg - return (badRequest400, msg) - _other -> do - let msg = "Result upload received multiple files; all ignored." - $logWarnS "LMS" msg - return (badRequest400, msg) - sendResponseStatus status msg - diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs deleted file mode 100644 index 6304c5be7..000000000 --- a/src/Handler/LMS/Userlist.hs +++ /dev/null @@ -1,288 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances - -module Handler.LMS.Userlist - ( getLmsUserlistR, postLmsUserlistR - , getLmsUserlistUploadR, postLmsUserlistUploadR - , postLmsUserlistDirectR - ) - where - -import Import - -import Handler.Utils -import Handler.Utils.Csv -import Handler.Utils.LMS - -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 qualified Database.Esqueleto.Utils as E - -import Jobs.Queue - -data LmsUserlistTableCsv = LmsUserlistTableCsv - { csvLULident :: LmsIdent - , csvLULfailed :: LmsBool - } - deriving Generic -makeLenses_ ''LmsUserlistTableCsv - --- csv without headers -instance Csv.ToRecord LmsUserlistTableCsv -instance Csv.FromRecord LmsUserlistTableCsv - --- csv with headers -instance DefaultOrdered LmsUserlistTableCsv where - headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ] - -instance ToNamedRecord LmsUserlistTableCsv where - toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord - [ csvLmsIdent Csv..= csvLULident - , csvLmsBlocked Csv..= csvLULfailed - ] -instance FromNamedRecord LmsUserlistTableCsv where - parseNamedRecord (lsfHeaderTranslate -> csv) - = LmsUserlistTableCsv - <$> csv Csv..: csvLmsIdent - <*> csv Csv..: csvLmsBlocked - -instance CsvColumnsExplained LmsUserlistTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsBlocked MsgCsvColumnLmsLock - ] - where - single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget - single k v = singletonMap k [whamlet|_{v}|] - - -data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate - deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) -embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id - -data LmsUserlistCsvAction = LmsUserlistInsertData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool } - | LmsUserlistUpdateData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool } - deriving (Eq, Ord, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsUserlistInsertData -> insert - , fieldLabelModifier = camelToPathPiece' 2 -- lmsUserlistInsertIdent -> insert-ident | lmsUserlistInsertFailed -> insert-failed - , sumEncoding = TaggedObject "action" "data" - } ''LmsUserlistCsvAction - - -data LmsUserlistCsvException - = LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! - deriving (Show, Generic) - -instance Exception LmsUserlistCsvException -embedRenderMessage ''UniWorX ''LmsUserlistCsvException id - -mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkUserlistTable sid qsh qid = do - dbtCsvName <- csvFilenameLmsUserlist qsh - let dbtCsvSheetName = dbtCsvName - let - userlistTable = DBTable{..} - where - dbtSQLQuery lmslist = do - E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid - return lmslist - dbtRowKey = (E.^. LmsUserlistId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent - , sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsLock) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked - , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp - ] - dbtSorting = Map.fromList - [ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent) - , (csvLmsBlocked , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed) - , (csvLmsTimestamp, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp) - ] - dbtFilter = Map.fromList - [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) - , (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed)) - ] - dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsLock) - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "lms-userlist" - dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample - where - addExample dce = dce{ dbtCsvExampleData = csvExample } - csvExample = Just - [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl} - | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False] - ] - doEncode' = LmsUserlistTableCsv - <$> view (_dbrOutput . _entityVal . _lmsUserlistIdent) - <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool) - dbtCsvDecode = Just DBTCsvDecode {..} - where - dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} -> - fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident - dbtCsvComputeActions = \case -- shows a diff first - DBCsvDiffNew{dbCsvNew} -> do - yield $ LmsUserlistInsertData - { lmsUserlistInsertIdent = csvLULident dbCsvNew - , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew - } - DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do - let failedBool = lms2bool csvLULfailed - when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $ - yield $ LmsUserlistUpdateData - { lmsUserlistInsertIdent = csvLULident - , lmsUserlistInsertFailed = csvLULfailed & lms2bool - } - DBCsvDiffMissing{} -> return () -- no deletion - dbtCsvClassifyAction = \case - LmsUserlistInsertData{} -> LmsUserlistInsert - LmsUserlistUpdateData{} -> LmsUserlistUpdate - dbtCsvCoarsenActionClass = \case - LmsUserlistInsert -> DBCsvActionNew - LmsUserlistUpdate -> DBCsvActionExisting - dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error - dbtCsvExecuteActions = do - C.mapM_ $ \actionData -> do - now <- liftIO getCurrentTime - void $ upsert LmsUserlist - { - lmsUserlistQualification = qid - , lmsUserlistIdent = lmsUserlistInsertIdent actionData - , lmsUserlistFailed = lmsUserlistInsertFailed actionData - , lmsUserlistTimestamp = now - } - [ - LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False? - , LmsUserlistTimestamp =. now - ] - -- audit - lift . queueDBJob $ JobLmsUserlist qid - return $ LmsUserlistR sid qsh - dbtCsvRenderKey = const $ \case - LmsUserlistInsertData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Insert: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} # - $if lmsUserlistInsertFailed - is closed due to failure. - $else - is open. - |] - LmsUserlistUpdateData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Update: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} # - $if lmsUserlistInsertFailed - is now closed due to failure. - $else - is still open. - |] - dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure - dbtCsvRenderException = ap getMessageRender . pure :: LmsUserlistCsvException -> DB Text - dbtExtraReps = [] - - userlistDBTableValidator = def - & defaultSorting [SortAscBy csvLmsIdent] - - dbTable userlistDBTableValidator userlistTable - - -getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistR = postLmsUserlistR -postLmsUserlistR sid qsh = do - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkUserlistTable sid qsh qid - siteLayoutMsg MsgMenuLmsUserlist $ do - setTitleI MsgMenuLmsUserlist - lmsTable - - --- Direct File Upload/Download --- saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) => --- Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b -saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int -saveUserlistCsv qid i LmsUserlistTableCsv{..} = do - now <- liftIO getCurrentTime - void $ upsert - LmsUserlist - { lmsUserlistQualification = qid - , lmsUserlistIdent = csvLULident - , lmsUserlistFailed = csvLULfailed & lms2bool - , lmsUserlistTimestamp = now - } - [ LmsUserlistFailed =. (csvLULfailed & lms2bool) - , LmsUserlistTimestamp =. now - ] - return $ succ i - -makeUserlistUploadForm :: Form FileInfo -makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV" - -getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistUploadR = postLmsUserlistUploadR -postLmsUserlistUploadR sid qsh = do - ((result,widget), enctype) <- runFormPost makeUserlistUploadForm - case result of - FormSuccess file -> do - nr <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0 - queueJob' $ JobLmsUserlist qid - return nr - addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") - redirect $ LmsUserlistR sid qsh - FormFailure errs -> do - forM_ errs $ addMessage Error . toHtml - redirect $ LmsUserlistUploadR sid qsh - FormMissing -> - siteLayoutMsg MsgMenuLmsUserlist $ do - setTitleI MsgMenuLmsUpload - [whamlet|$newline never - - ^{widget} -

- - |] - - -postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html -postLmsUserlistDirectR sid qsh = do - (_params, files) <- runRequestBody - (status, msg) <- case files of - [(fhead,file)] -> do - lmsDecoder <- getLmsCsvDecoder - runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - enr <- try $ runConduit $ fileSource file - .| lmsDecoder - .| foldMC (saveUserlistCsv qid) 0 - case enr of - Left (e :: SomeException) -> do - $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e - return (badRequest400, "Exception: " <> tshow e) - Right nr -> do - let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " - $logInfoS "LMS" msg - when (nr > 0) $ queueJob' $ JobLmsUserlist qid - return (ok200, msg) - [] -> do - let msg = "Userlist upload file missing." - $logWarnS "LMS" msg - return (badRequest400, msg) - _other -> do - let msg = "Userlist upload received multiple files; all ignored." - $logWarnS "LMS" msg - return (badRequest400, msg) - sendResponseStatus status msg diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index eb619276b..e6f35e8e9 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -19,8 +19,6 @@ module Handler.Utils.LMS , csvLmsLock , csvLmsResult , csvFilenameLmsUser - , csvFilenameLmsUserlist - , csvFilenameLmsResult , csvFilenameLmsReport , lmsDeletionDate , lmsUserToDelete , _lmsUserToDelete , lmsUserToDeleteExpr @@ -109,14 +107,6 @@ csvLmsResult = fromString "result" -- LmsStatus: 0=Versuche aufgebraucht, 1=Offe csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsUser = makeLmsFilename "user" --- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface V2 -csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text -csvFilenameLmsUserlist = makeLmsFilename "userliste" - --- | Filename for Result transmission, contains current datestamp as agreed in LMS interface V1 -csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text -csvFilenameLmsResult = makeLmsFilename "ergebnisse" - -- | Filename for Report transmission, combining former Userlist and Result as agreed in new LMS interface V2 csvFilenameLmsReport :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsReport = makeLmsFilename "report" diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1785924b4..5ab7745ae 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -10,8 +10,6 @@ module Jobs.Handler.LMS , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsDequeue , dispatchJobLmsReports - , dispatchJobLmsResults - , dispatchJobLmsUserlist ) where import Import @@ -28,7 +26,7 @@ import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set -- import qualified Data.Map as Map -import qualified Data.Time.Zones as TZ +-- import qualified Data.Time.Zones as TZ import Handler.Utils.DateTime import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries) import Handler.Utils.Qualification @@ -134,10 +132,6 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by Qid, since LmsIdents must be unique across all `E.union_` ( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2 - `E.union_` - ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) ) -- V1 DEPRECATED - `E.union_` - ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- V1 DEPRECATED E.orderBy [E.asc lui] pure lui now <- liftIO getCurrentTime @@ -261,8 +255,6 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act when (numdel > 0) $ do $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] - deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers] - deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ] @@ -433,120 +425,3 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.<&> E.true) repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] - - --- DEPRECATED processes received results and lengthen qualifications, if applicable -dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX -dispatchJobLmsResults qid = JobHandlerAtomic act - where - -- act :: YesodJobDB UniWorX () - act = hoist lift $ do - results <- E.select $ do - (quser :& luser :& lresult) <- E.from $ - E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! - `E.innerJoin` E.table @LmsUser - `E.on` (\(quser :& luser) -> - luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser - E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) - `E.innerJoin` E.table @LmsResult - `E.on` (\(_ :& luser :& lresult) -> - luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent - E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. luser E.^. LmsUserQualification E.==. E.val qid - -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result WORKAROUND LMS-Bug: LMS may send blocked & success simultanesouly or within a few hours; in this case, success is the correct meaning - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners - return (quser, luser, lresult) - now <- liftIO getCurrentTime - let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now - forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do - -- three separate DB operations per result is not so nice. All within one transaction though. - let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted - saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) - -- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway - -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards - note <- if saneDate && (lmsUserStatus /= Just LmsSuccess) - then do - -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning - let reason_undo = Left $ "LMS Workaround undoing: " <> tshow (QualificationBlockFailedELearningBy lmsUserIdent) - ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right $ QualificationBlockFailedELearningBy lmsUserIdent) reason_undo False -- affects audit log - when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|]) - - _ok_renew <- renewValidQualificationUsers qid (Just $ Right $ QualificationRenewELearningBy lmsUserIdent) Nothing [qualificationUserUser] -- only unblocked are renewed - -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings - - update luid - [ LmsUserStatus =. Just LmsSuccess - , LmsUserStatusDay =. Just (utctDayMidnight lmsResultSuccess) - , LmsUserReceived =. Just lmsResultTimestamp - ] - return Nothing - else do - let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent} for #{tshow qid}|] - $logErrorS "LMS" errmsg - return $ Just errmsg - - audit TransactionLmsSuccess -- always log success, since this is only transmitted once - { transactionQualification = qid - , transactionLmsIdent = lmsUserIdent - , transactionLmsDay = utctDayMidnight lmsResultSuccess - , transactionLmsUser = lmsUserUser - , transactionNote = note - , transactionReceived = lmsResultTimestamp - } - delete lrid - $logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|] - - --- DEPRECATED processes received input and block qualifications, if applicable -dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX -dispatchJobLmsUserlist qid = JobHandlerAtomic act - where - act :: YesodJobDB UniWorX () - act = whenM (exists [LmsUserlistQualification ==. qid]) $ do -- safeguard against multiple calls, which would close all learners due to first case below - now <- liftIO getCurrentTime - -- result :: [(Entity LmsUser, Entity LmsUserlist)] - results <- E.select $ do - (luser :& lulist) <- E.from $ - E.table @LmsUser `E.leftJoin` E.table @LmsUserlist - `E.on` (\(luser :& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent - E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification) - E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners - return (luser, lulist) - forM_ results $ \case - (Entity luid luser, Nothing) - | isJust $ lmsUserReceived luser -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) - , isNothing $ lmsUserEnded luser -> - update luid [LmsUserEnded =. Just now] - | otherwise -> return () -- users likely not yet started - - (Entity luid luser, Just (Entity _lulid lulist)) -> do - let lReceived = lmsUserlistTimestamp lulist - update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications - - when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available - queueDBJob JobUserNotification - { jRecipient = lmsUserUser luser - , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } - } - - let isBlocked = lmsUserlistFailed lulist - oldStatus = lmsUserStatus luser - updateStatus = isBlocked && oldStatus /= Just LmsSuccess - when updateStatus $ do - update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lReceived] - ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True - when (ok /= 1) $ do - uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser - $logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}] - audit TransactionLmsBlocked - { transactionQualification = qid - , transactionLmsIdent = lmsUserIdent luser - , transactionLmsDay = lReceived - , transactionLmsUser = lmsUserUser luser - , transactionNote = Just $ "Old status was " <> tshow oldStatus - , transactionReceived = lReceived - } - delete lulid - $logInfoS "LMS" [st|Processed LMS Userlist with #{tshow (length results)} entries|] diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 78b4fe50b..dc8e04120 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -135,8 +135,6 @@ data Job | JobLmsEnqueueUser { jQualification :: QualificationId, jUser :: UserId } | JobLmsQualificationsDequeue | JobLmsDequeue { jQualification :: QualificationId } - | JobLmsUserlist { jQualification :: QualificationId } -- Deprecated, remove together with routes - | JobLmsResults { jQualification :: QualificationId } -- Deprecated, remove together with routes | JobLmsReports { jQualification :: QualificationId } | JobPrintAck | JobPrintAckAgain @@ -368,9 +366,7 @@ jobNoQueueSame = \case JobLmsEnqueue {} -> Just JobNoQueueSame JobLmsEnqueueUser {} -> Just JobNoQueueSame JobLmsQualificationsDequeue -> Just JobNoQueueSame - JobLmsDequeue {} -> Just JobNoQueueSame - JobLmsUserlist {} -> Just JobNoQueueSame - JobLmsResults {} -> Just JobNoQueueSame + JobLmsDequeue {} -> Just JobNoQueueSame JobLmsReports {} -> Just JobNoQueueSame JobPrintAck {} -> Just JobNoQueueSame JobPrintAckAgain {} -> Just JobNoQueueSame diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 861d98fd4..5c83e1e35 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -125,8 +125,6 @@ makeClassyFor_ ''QualificationUser makeClassyFor_ ''QualificationUserBlock makeClassyFor_ ''LmsUser -- makeClassyFor_ ''LmsUserStatus -makeClassyFor_ ''LmsUserlist -makeClassyFor_ ''LmsResult makeClassyFor_ ''LmsReport makeClassyFor_ ''UserAvs makeClassyFor_ ''UserAvsCard diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 9e1b9cea6..19f424fc8 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -739,12 +739,6 @@ fillDb = do insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11) | Entity uid User{userDisplayName=udn} <- take 200 $ drop 2 matUsers, uid `Set.notMember` qidfUsers] insertMany_ [LmsUser qid_f uid (LmsIdent udn) "123456" False now astatus astatusDay now (Just now) (Just now) Nothing False False | Entity uid User{userDisplayName=udn} <- take 200 $ drop 22 matUsers, uid `Set.notMember` qidfUsers , let selsome = odd $ length udn, let astatus = bool Nothing (Just LmsBlocked) selsome, let astatusDay = bool Nothing (Just now) selsome] - void . insert' $ LmsResult qid_f (LmsIdent "hijklm" ) (n_day (-1)) now - void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now - void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now - void . insert' $ LmsUserlist qid_f (LmsIdent "hijklm") False now - void . insert' $ LmsUserlist qid_f (LmsIdent "abcdef") True now - void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False void . insert' $ LmsUser qid_f svaupel (LmsIdent "bcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False void . insert' $ LmsUser qid_f gkleen (LmsIdent "hiklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True