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

chore(lms): upload and direct for userlist and result working now

Browse Source
This commit is contained in:
Steffen Jost 2022-03-17 11:16:28 +01:00
parent cbfa88a059
commit e860a99657
7 changed files with 122 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
models/lms.model
View File

@ -10,8 +10,8 @@ Qualification
-- elearningOnly Bool -- successful E-learing automatically increases validity. NO! -- elearningOnly Bool -- successful E-learing automatically increases validity. NO!
-- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO! -- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO!
-- expiryNotification StoredMarkup Maybe -- configurable user-profile-notifcations are used instead NO! -- expiryNotification StoredMarkup Maybe -- configurable user-profile-notifcations are used instead NO!
UniqueSchoolShort school shorthand -- must be unique per school and shorthand UniqueQualificationSchoolShort school shorthand -- must be unique per school and shorthand
UniqueSchoolName school name -- must be unique per school and name UniqueQualificationSchoolName school name -- must be unique per school and name
deriving Generic deriving Generic
-- TODOs: -- TODOs:

13
routes
View File

@ -255,8 +255,11 @@
!/*WellKnownFileName WellKnownR GET !free !/*WellKnownFileName WellKnownR GET !free
-- OSIS CSV Export Demo -- OSIS CSV Export Demo
/lms/#SchoolId/#QualificationShorthand LmsR GET POST /lms/#SchoolId/#QualificationShorthand LmsR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST /lms/#SchoolId/#QualificationShorthand/userliss/upload LmsUserlistUploadR GET POST
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST /lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST

13
src/Foundation/Navigation.hs
View File

@ -133,11 +133,14 @@ breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing
breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed
breadcrumb (LmsR _sid _qsh) = i18nCrumb MsgMenuLms Nothing breadcrumb (LmsR _sid _qsh) = i18nCrumb MsgMenuLms Nothing
breadcrumb (LmsUsersR sid qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR sid qsh breadcrumb (LmsUsersR sid qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR sid qsh
breadcrumb (LmsUserlistR sid qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR sid qsh breadcrumb (LmsUserlistR sid qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR sid qsh
breadcrumb (LmsResultR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR sid qsh breadcrumb (LmsUserlistUploadR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR sid qsh
breadcrumb (LmsResultUploadR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsResultR sid qsh breadcrumb (LmsUserlistDirectR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR sid qsh -- never displayed
breadcrumb (LmsResultR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR sid qsh
breadcrumb (LmsResultUploadR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR sid qsh
breadcrumb (LmsResultDirectR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR sid qsh -- never displayed
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing

16
src/Handler/LMS.hs
View File

@ -5,12 +5,12 @@
module Handler.LMS module Handler.LMS
( getLmsR , postLmsR ( getLmsR , postLmsR
, getLmsUsersR , postLmsUsersR , getLmsUsersR , postLmsUsersR
, getLmsUserlistR, postLmsUserlistR , getLmsUserlistR , postLmsUserlistR
, getLmsResultR , postLmsResultR , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
, getLmsResultUploadR , postLmsResultUploadR , getLmsResultR , postLmsResultR
, getLmsTestR , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR
) )
where where
@ -63,7 +63,7 @@ resultUser = _dbrOutput . _2
getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR getLmsR = postLmsR
postLmsR sid qsh = do postLmsR sid qsh = do
_qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh _qid <- runDB . getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
-- TODO !!! filter table by qid !!! -- TODO !!! filter table by qid !!!
dbtCsvName <- csvLmsUserFilename dbtCsvName <- csvLmsUserFilename
@ -335,7 +335,7 @@ getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR getLmsR = postLmsR
postLmsR sid qsh = do postLmsR sid qsh = do
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
view _2 <$> mkLmsTable sid qsh qid view _2 <$> mkLmsTable sid qsh qid
siteLayoutMsg MsgMenuLmsResult $ do siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsResult setTitleI MsgMenuLmsResult

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

@ -3,6 +3,7 @@
module Handler.LMS.Result module Handler.LMS.Result
( getLmsResultR, postLmsResultR ( getLmsResultR, postLmsResultR
, getLmsResultUploadR, postLmsResultUploadR , getLmsResultUploadR, postLmsResultUploadR
, postLmsResultDirectR
) )
where where
@ -196,7 +197,7 @@ getLmsResultR = postLmsResultR
postLmsResultR sid qsh = do postLmsResultR sid qsh = do
let directUploadLink = LmsResultUploadR sid qsh let directUploadLink = LmsResultUploadR sid qsh
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
view _2 <$> mkResultTable sid qsh qid view _2 <$> mkResultTable sid qsh qid
siteLayoutMsg MsgMenuLmsResult $ do siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsResult setTitleI MsgMenuLmsResult
@ -234,7 +235,7 @@ postLmsResultUploadR sid qsh = do
-- content <- fileSourceByteString file -- content <- fileSourceByteString file
-- return $ Just (fileName file, content) -- return $ Just (fileName file, content)
nr <- runDB $ do nr <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
runConduit $ fileSource file runConduit $ fileSource file
.| decodeCsv .| decodeCsv
.| foldMC (saveResultCsv qid) 0 .| foldMC (saveResultCsv qid) 0
@ -248,8 +249,23 @@ postLmsResultUploadR sid qsh = do
setTitleI MsgMenuLmsUpload setTitleI MsgMenuLmsUpload
[whamlet|$newline never [whamlet|$newline never
<form method=post enctype=#{enctype}> <form method=post enctype=#{enctype}>
^{widget} ^{widget}
<p> <p>
<input type=submit> <input type=submit>
|] |]
postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsResultDirectR sid qsh = do
(_params, files) <- runRequestBody
case files of
[(fhead,file)] -> do
nr <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveResultCsv qid) 0
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."
_other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden."
redirect $ LmsResultR sid qsh

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

@ -2,6 +2,8 @@
module Handler.LMS.Userlist module Handler.LMS.Userlist
( getLmsUserlistR, postLmsUserlistR ( getLmsUserlistR, postLmsUserlistR
, getLmsUserlistUploadR, postLmsUserlistUploadR
, postLmsUserlistDirectR
) )
where where
@ -195,8 +197,73 @@ getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handl
getLmsUserlistR = postLmsUserlistR getLmsUserlistR = postLmsUserlistR
postLmsUserlistR sid qsh = do postLmsUserlistR sid qsh = do
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
view _2 <$> mkUserlistTable sid qsh qid view _2 <$> mkUserlistTable sid qsh qid
siteLayoutMsg MsgMenuLmsUserlist $ do siteLayoutMsg MsgMenuLmsUserlist $ do
setTitleI MsgMenuLmsUserlist setTitleI MsgMenuLmsUserlist
$(widgetFile "lms-userlist") $(widgetFile "lms-userlist")
-- Direct File Upload/Download
--saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend) =>
-- Key Qualification -> LmsUserlistTableCsv -> ReaderT backend m ()
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 $ UniqueQualificationSchoolShort sid qsh
runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveUserlistCsv qid) 0
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
case files of
[(fhead,file)] -> do
nr <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveUserlistCsv qid) 0
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."
_other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden."
redirect $ LmsUserlistR sid qsh

6
src/Handler/LMS/Users.hs
View File

@ -130,8 +130,12 @@ getLmsUsersR, postLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Ht
getLmsUsersR = postLmsUsersR getLmsUsersR = postLmsUsersR
postLmsUsersR sid qsh = do postLmsUsersR sid qsh = do
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
view _2 <$> mkUserTable sid qsh qid view _2 <$> mkUserTable sid qsh qid
siteLayoutMsg MsgMenuLmsUsers $ do siteLayoutMsg MsgMenuLmsUsers $ do
setTitleI MsgMenuLmsUsers setTitleI MsgMenuLmsUsers
$(widgetFile "lms-user") $(widgetFile "lms-user")
-- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod