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

fix(lms): direct upload did not commit to DB

Browse Source
This commit is contained in:
Steffen Jost 2022-05-19 16:44:02 +02:00
parent 52e6646f39
commit e7cea4aa6c
3 changed files with 19 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -257,10 +257,12 @@ postLmsResultUploadR sid qsh = do
|]
postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Text
postLmsResultDirectR sid qsh = do
(_params, files) <- runRequestBody
case files of
postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsResultDirectR sid qsh = do
(params, files) <- runRequestBody
$logWarnS "LMS_1" $ tshow params
$logWarnS "LMS_2" $ tshow $ fst <$> files
(status, msg) <- case files of
[(fhead,file)] -> do
runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
@ -270,18 +272,19 @@ postLmsResultDirectR sid qsh = do
case enr of
Left (e :: SomeException) -> do
$logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
sendResponseStatus badRequest400 $ "Exception: " <> tshow e
return (badRequest400, "Exception: " <> tshow e)
Right nr -> do
let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
$logWarnS "LMS" msg -- TODO: change to Info Level in the future
queueDBJob $ JobLmsResults qid
sendResponseStatus ok200 msg
return (ok200, msg)
[] -> do
let msg = "Result upload file missing."
$logWarnS "LMS" msg
sendResponseStatus badRequest400 msg
return (badRequest400, msg)
_other -> do
let msg = "Result upload received multiple files; all ignored."
$logWarnS "LMS" msg
sendResponseStatus badRequest400 msg
return (badRequest400, msg)
sendResponseStatus status msg

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

@ -256,7 +256,7 @@ postLmsUserlistUploadR sid qsh = do
postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsUserlistDirectR sid qsh = do
(_params, files) <- runRequestBody
case files of
(status, msg) <- case files of
[(fhead,file)] -> do
runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
@ -266,18 +266,19 @@ postLmsUserlistDirectR sid qsh = do
case enr of
Left (e :: SomeException) -> do
$logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e
sendResponseStatus badRequest400 $ "Exception: " <> tshow e
return (badRequest400, "Exception: " <> tshow e)
Right nr -> do
let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
$logWarnS "LMS" msg -- TODO: change to Info Level in the future
queueDBJob $ JobLmsResults qid
sendResponseStatus ok200 msg
return (ok200, msg)
[] -> do
let msg = "Userlist upload file missing."
$logWarnS "LMS" msg
sendResponseStatus badRequest400 msg
return (badRequest400, msg)
_other -> do
let msg = "Userlist upload received multiple files; all ignored."
$logWarnS "LMS" msg
sendResponseStatus badRequest400 msg
return (badRequest400, msg)
sendResponseStatus status msg

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

@ -186,10 +186,10 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
, LmsUserReceived =. Just lreceived
]
else
$logErrorS "LmsResult" [st|LMS success with insane date ${tshow (lmsResultSuccess lresult)} received|]
$logErrorS "LmsResult" [st|LMS success with insane date #{tshow (lmsResultSuccess lresult)} received|]
insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now
delete lrid
$logInfoS "LmsResult" [st|Processed ${tshow (length results)} LMS results|]
$logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
dispatchJobLmsUserlist qid = JobHandlerAtomic act