fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): remove obsolete lms handlers v1

Browse Source
This commit is contained in:
Steffen Jost 2023-12-01 18:11:02 +01:00
parent df6a7ee1e2
commit fcc802753a
15 changed files with 11 additions and 825 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
messages/uniworx/categories/qualification/de-de-formal.msg
View File

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

6
messages/uniworx/categories/qualification/en-eu.msg
View File

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

2
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

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

2
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

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

37
models/lms.model
View File

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

9
routes
View File

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

30
src/Foundation/Navigation.hs
View File

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

12
src/Handler/LMS.hs
View File

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

293
src/Handler/LMS/Result.hs
View File

@ -1,293 +0,0 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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
<form method=post enctype=#{enctype}>
^{widget}
<p>
<input type=submit>
|]
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

288
src/Handler/LMS/Userlist.hs
View File

@ -1,288 +0,0 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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
<form method=post enctype=#{enctype}>
^{widget}
<p>
<input type=submit>
|]
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

10
src/Handler/Utils/LMS.hs
View File

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

127
src/Jobs/Handler/LMS.hs
View File

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

6
src/Jobs/Types.hs
View File

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

2
src/Utils/Lens.hs
View File

@ -125,8 +125,6 @@ makeClassyFor_ ''QualificationUser
makeClassyFor_ ''QualificationUserBlock
makeClassyFor_ ''LmsUser
-- makeClassyFor_ ''LmsUserStatus
makeClassyFor_ ''LmsUserlist
makeClassyFor_ ''LmsResult
makeClassyFor_ ''LmsReport
makeClassyFor_ ''UserAvs
makeClassyFor_ ''UserAvsCard

6
test/Database/Fill.hs
View File

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