fraport/fradrive-old
Archived
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

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

@ -257,10 +257,12 @@ postLmsResultUploadR sid qsh = do
|] |]
postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Text postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsResultDirectR sid qsh = do postLmsResultDirectR sid qsh = do
(_params, files) <- runRequestBody (params, files) <- runRequestBody
case files of $logWarnS "LMS_1" $ tshow params
$logWarnS "LMS_2" $ tshow $ fst <$> files
(status, msg) <- case files of
[(fhead,file)] -> do [(fhead,file)] -> do
runDBJobs $ do runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
@ -270,18 +272,19 @@ postLmsResultDirectR sid qsh = do
case enr of case enr of
Left (e :: SomeException) -> do Left (e :: SomeException) -> do
$logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
sendResponseStatus badRequest400 $ "Exception: " <> tshow e return (badRequest400, "Exception: " <> tshow e)
Right nr -> do Right nr -> do
let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead 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 $logWarnS "LMS" msg -- TODO: change to Info Level in the future
queueDBJob $ JobLmsResults qid queueDBJob $ JobLmsResults qid
sendResponseStatus ok200 msg return (ok200, msg)
[] -> do [] -> do
let msg = "Result upload file missing." let msg = "Result upload file missing."
$logWarnS "LMS" msg $logWarnS "LMS" msg
sendResponseStatus badRequest400 msg return (badRequest400, msg)
_other -> do _other -> do
let msg = "Result upload received multiple files; all ignored." let msg = "Result upload received multiple files; all ignored."
$logWarnS "LMS" msg $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 :: SchoolId -> QualificationShorthand -> Handler Html
postLmsUserlistDirectR sid qsh = do postLmsUserlistDirectR sid qsh = do
(_params, files) <- runRequestBody (_params, files) <- runRequestBody
case files of (status, msg) <- case files of
[(fhead,file)] -> do [(fhead,file)] -> do
runDBJobs $ do runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
@ -266,18 +266,19 @@ postLmsUserlistDirectR sid qsh = do
case enr of case enr of
Left (e :: SomeException) -> do Left (e :: SomeException) -> do
$logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e
sendResponseStatus badRequest400 $ "Exception: " <> tshow e return (badRequest400, "Exception: " <> tshow e)
Right nr -> do Right nr -> do
let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead 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 $logWarnS "LMS" msg -- TODO: change to Info Level in the future
queueDBJob $ JobLmsResults qid queueDBJob $ JobLmsResults qid
sendResponseStatus ok200 msg return (ok200, msg)
[] -> do [] -> do
let msg = "Userlist upload file missing." let msg = "Userlist upload file missing."
$logWarnS "LMS" msg $logWarnS "LMS" msg
sendResponseStatus badRequest400 msg return (badRequest400, msg)
_other -> do _other -> do
let msg = "Userlist upload received multiple files; all ignored." let msg = "Userlist upload received multiple files; all ignored."
$logWarnS "LMS" msg $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 , LmsUserReceived =. Just lreceived
] ]
else 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 insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now
delete lrid 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 :: QualificationId -> JobHandler UniWorX
dispatchJobLmsUserlist qid = JobHandlerAtomic act dispatchJobLmsUserlist qid = JobHandlerAtomic act