diff --git a/models/lms.model b/models/lms.model index eb17703a8..1463a6b9d 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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: diff --git a/routes b/routes index 36e4215a2..0a2262676 100644 --- a/routes +++ b/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 \ No newline at end of file +/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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 9527f7ad8..52b22c348 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index be6dd5a8c..03a704baa 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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 diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 6d337a290..502a4a5a5 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -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
- ^{widget} -

- + ^{widget} +

+ |] - + + +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 diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index ff261b983..7dbe6c14c 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -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 + + ^{widget} +

+ + |] + + +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 \ No newline at end of file diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 7f7d3f9ed..ba6b8d688 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -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 \ No newline at end of file