chore(lms): upload and direct for userlist and result working now
This commit is contained in:
Steffen Jost
parent
cbfa88a059
commit
e860a99657
@ -10,8 +10,8 @@ Qualification
|
||||
-- elearningOnly Bool -- successful E-learing automatically increases validity. 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!
|
||||
UniqueSchoolShort school shorthand -- must be unique per school and shorthand
|
||||
UniqueSchoolName school name -- must be unique per school and name
|
||||
UniqueQualificationSchoolShort school shorthand -- must be unique per school and shorthand
|
||||
UniqueQualificationSchoolName school name -- must be unique per school and name
|
||||
deriving Generic
|
||||
|
||||
-- TODOs:
|
||||
|
||||
13
routes
13
routes
@ -255,8 +255,11 @@
|
||||
!/*WellKnownFileName WellKnownR GET !free
|
||||
|
||||
-- OSIS CSV Export Demo
|
||||
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/userliss/upload LmsUserlistUploadR 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
|
||||
|
||||
@ -133,11 +133,14 @@ breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
|
||||
breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing
|
||||
breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed
|
||||
|
||||
breadcrumb (LmsR _sid _qsh) = i18nCrumb MsgMenuLms Nothing
|
||||
breadcrumb (LmsUsersR sid qsh) = i18nCrumb MsgMenuLmsUsers $ 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 (LmsResultUploadR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsResultR sid qsh
|
||||
breadcrumb (LmsR _sid _qsh) = i18nCrumb MsgMenuLms Nothing
|
||||
breadcrumb (LmsUsersR sid qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR sid qsh
|
||||
breadcrumb (LmsUserlistR sid qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR sid qsh
|
||||
breadcrumb (LmsUserlistUploadR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR 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
|
||||
|
||||
@ -5,12 +5,12 @@
|
||||
|
||||
|
||||
module Handler.LMS
|
||||
( getLmsR , postLmsR
|
||||
, getLmsUsersR , postLmsUsersR
|
||||
, getLmsUserlistR, postLmsUserlistR
|
||||
, getLmsResultR , postLmsResultR
|
||||
, getLmsResultUploadR , postLmsResultUploadR
|
||||
, getLmsTestR
|
||||
( getLmsR , postLmsR
|
||||
, getLmsUsersR , postLmsUsersR
|
||||
, getLmsUserlistR , postLmsUserlistR
|
||||
, getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
|
||||
, getLmsResultR , postLmsResultR
|
||||
, getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR
|
||||
)
|
||||
where
|
||||
|
||||
@ -63,7 +63,7 @@ resultUser = _dbrOutput . _2
|
||||
getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsR = postLmsR
|
||||
postLmsR sid qsh = do
|
||||
_qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh
|
||||
_qid <- runDB . getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
|
||||
-- TODO !!! filter table by qid !!!
|
||||
|
||||
dbtCsvName <- csvLmsUserFilename
|
||||
@ -335,7 +335,7 @@ getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsR = postLmsR
|
||||
postLmsR sid qsh = do
|
||||
lmsTable <- runDB $ do
|
||||
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
|
||||
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
|
||||
view _2 <$> mkLmsTable sid qsh qid
|
||||
siteLayoutMsg MsgMenuLmsResult $ do
|
||||
setTitleI MsgMenuLmsResult
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
module Handler.LMS.Result
|
||||
( getLmsResultR, postLmsResultR
|
||||
, getLmsResultUploadR, postLmsResultUploadR
|
||||
, postLmsResultDirectR
|
||||
)
|
||||
where
|
||||
|
||||
@ -196,7 +197,7 @@ getLmsResultR = postLmsResultR
|
||||
postLmsResultR sid qsh = do
|
||||
let directUploadLink = LmsResultUploadR sid qsh
|
||||
lmsTable <- runDB $ do
|
||||
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
|
||||
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
|
||||
view _2 <$> mkResultTable sid qsh qid
|
||||
siteLayoutMsg MsgMenuLmsResult $ do
|
||||
setTitleI MsgMenuLmsResult
|
||||
@ -234,7 +235,7 @@ postLmsResultUploadR sid qsh = do
|
||||
-- content <- fileSourceByteString file
|
||||
-- return $ Just (fileName file, content)
|
||||
nr <- runDB $ do
|
||||
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
|
||||
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
|
||||
runConduit $ fileSource file
|
||||
.| decodeCsv
|
||||
.| foldMC (saveResultCsv qid) 0
|
||||
@ -246,10 +247,25 @@ postLmsResultUploadR sid qsh = do
|
||||
FormMissing ->
|
||||
siteLayoutMsg MsgMenuLmsResult $ do
|
||||
setTitleI MsgMenuLmsUpload
|
||||
[whamlet|$newline never
|
||||
[whamlet|$newline never
|
||||
<form method=post enctype=#{enctype}>
|
||||
^{widget}
|
||||
<p>
|
||||
<input type=submit>
|
||||
^{widget}
|
||||
<p>
|
||||
<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
|
||||
|
||||
@ -2,6 +2,8 @@
|
||||
|
||||
module Handler.LMS.Userlist
|
||||
( getLmsUserlistR, postLmsUserlistR
|
||||
, getLmsUserlistUploadR, postLmsUserlistUploadR
|
||||
, postLmsUserlistDirectR
|
||||
)
|
||||
where
|
||||
|
||||
@ -195,8 +197,73 @@ getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handl
|
||||
getLmsUserlistR = postLmsUserlistR
|
||||
postLmsUserlistR sid qsh = do
|
||||
lmsTable <- runDB $ do
|
||||
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
|
||||
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
|
||||
view _2 <$> mkUserlistTable sid qsh qid
|
||||
siteLayoutMsg MsgMenuLmsUserlist $ do
|
||||
setTitleI MsgMenuLmsUserlist
|
||||
$(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
|
||||
@ -130,8 +130,12 @@ getLmsUsersR, postLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Ht
|
||||
getLmsUsersR = postLmsUsersR
|
||||
postLmsUsersR sid qsh = do
|
||||
lmsTable <- runDB $ do
|
||||
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
|
||||
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
|
||||
view _2 <$> mkUserTable sid qsh qid
|
||||
siteLayoutMsg MsgMenuLmsUsers $ do
|
||||
setTitleI MsgMenuLmsUsers
|
||||
$(widgetFile "lms-user")
|
||||
|
||||
|
||||
-- direct Download see:
|
||||
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
|
||||
Loading…
Reference in New Issue
Block a user