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

feat(lms): enable upload handlers for all upload routes

Browse Source
This commit is contained in:
Steffen Jost 2022-04-04 15:19:17 +02:00
parent 9483a0fc15
commit a5121f0d3e
2 changed files with 26 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -208,9 +208,7 @@ postLmsResultR sid qsh = do
-- Direct File Upload/Download -- Direct File Upload/Download
--saveResultCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend) => saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int
-- Key Qualification -> LmsResultTableCsv -> ReaderT backend m ()
saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int
saveResultCsv qid i LmsResultTableCsv{..} = do saveResultCsv qid i LmsResultTableCsv{..} = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert void $ upsert
@ -236,11 +234,13 @@ postLmsResultUploadR sid qsh = do
FormSuccess file -> do FormSuccess file -> do
-- content <- fileSourceByteString file -- content <- fileSourceByteString file
-- return $ Just (fileName file, content) -- return $ Just (fileName file, content)
nr <- runDB $ do nr <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
runConduit $ fileSource file nr <- runConduit $ fileSource file
.| decodeCsv .| decodeCsv
.| foldMC (saveResultCsv qid) 0 .| foldMC (saveResultCsv qid) 0
queueDBJob $ JobLmsResults qid
return nr
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
redirect $ LmsResultR sid qsh redirect $ LmsResultR sid qsh
FormFailure errs -> do FormFailure errs -> do
@ -262,11 +262,13 @@ postLmsResultDirectR sid qsh = do
(_params, files) <- runRequestBody (_params, files) <- runRequestBody
case files of case files of
[(fhead,file)] -> do [(fhead,file)] -> do
nr <- runDB $ do nr <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
runConduit $ fileSource file nr <- runConduit $ fileSource file
.| decodeCsv .| decodeCsv
.| foldMC (saveResultCsv qid) 0 .| foldMC (saveResultCsv qid) 0
queueDBJob $ JobLmsResults qid
return nr
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen für Result mit Header ") <> fhead addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen für Result mit Header ") <> fhead
[] -> addMessage Error "Es wurde keine Datei übermittelt." [] -> addMessage Error "Es wurde keine Datei übermittelt."
_other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden." _other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden."

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

@ -206,10 +206,9 @@ postLmsUserlistR sid qsh = do
-- Direct File Upload/Download -- Direct File Upload/Download
-- saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) =>
--saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend) => -- Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b
-- Key Qualification -> LmsUserlistTableCsv -> ReaderT backend m () saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int
saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int
saveUserlistCsv qid i LmsUserlistTableCsv{..} = do saveUserlistCsv qid i LmsUserlistTableCsv{..} = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert void $ upsert
@ -233,11 +232,11 @@ postLmsUserlistUploadR sid qsh = do
((result,widget), enctype) <- runFormPost makeUserlistUploadForm ((result,widget), enctype) <- runFormPost makeUserlistUploadForm
case result of case result of
FormSuccess file -> do FormSuccess file -> do
nr <- runDB $ do nr <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
runConduit $ fileSource file nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0
.| decodeCsv queueDBJob $ JobLmsUserlist qid
.| foldMC (saveUserlistCsv qid) 0 return nr
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
redirect $ LmsUserlistR sid qsh redirect $ LmsUserlistR sid qsh
FormFailure errs -> do FormFailure errs -> do
@ -259,11 +258,13 @@ postLmsUserlistDirectR sid qsh = do
(_params, files) <- runRequestBody (_params, files) <- runRequestBody
case files of case files of
[(fhead,file)] -> do [(fhead,file)] -> do
nr <- runDB $ do nr <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
runConduit $ fileSource file nr <- runConduit $ fileSource file
.| decodeCsv .| decodeCsv
.| foldMC (saveUserlistCsv qid) 0 .| foldMC (saveUserlistCsv qid) 0
queueDBJob $ JobLmsUserlist qid
return nr
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen für Userlit mit Header ") <> fhead addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen für Userlit mit Header ") <> fhead
[] -> addMessage Error "Es wurde keine Datei übermittelt." [] -> addMessage Error "Es wurde keine Datei übermittelt."
_other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden." _other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden."