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

chore(lms): direct export for lms users working

Browse Source
This commit is contained in:
Steffen Jost 2022-03-17 13:13:06 +01:00
parent e860a99657
commit 9e91eab139
4 changed files with 45 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
routes
View File

@ -256,7 +256,8 @@
-- OSIS CSV Export Demo
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
/lms/#SchoolId/#QualificationShorthand/userliss/upload LmsUserlistUploadR GET POST
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST

1
src/Foundation/Navigation.hs
View File

@ -135,6 +135,7 @@ breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never
breadcrumb (LmsR _sid _qsh) = i18nCrumb MsgMenuLms Nothing
breadcrumb (LmsUsersR sid qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR sid qsh
breadcrumb (LmsUsersDirectR sid qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsUsersR sid qsh -- never displayed, TypedContent
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

2
src/Handler/LMS.hs
View File

@ -6,7 +6,7 @@
module Handler.LMS
( getLmsR , postLmsR
, getLmsUsersR , postLmsUsersR
, getLmsUsersR , getLmsUsersDirectR
, getLmsUserlistR , postLmsUserlistR
, getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
, getLmsResultR , postLmsResultR

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

@ -1,7 +1,9 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{- LANGUAGE TypeApplications -} -- only needed for Database.Esqueleto.Experimental
module Handler.LMS.Users
( getLmsUsersR, postLmsUsersR
( getLmsUsersR
, getLmsUsersDirectR
)
where
@ -16,6 +18,7 @@ import Handler.Utils.LMS
import qualified Data.Map as Map
import qualified Data.Csv as Csv
import qualified Data.Conduit.List as C
-- import qualified Database.Esqueleto.Experimental as Ex
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
@ -27,6 +30,15 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
deriving Generic
makeLenses_ ''LmsUserTableCsv
-- | Mundane conversion needed for direct download without dbTable onlu
lmsUser2csv :: LmsUser -> LmsUserTableCsv
lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv
{ csvLUTident = lmsUserIdent
, csvLUTpin = lmsUserPin
, csvLUTresetPin = lmsUserResetPin & LmsBool
, csvLUTdelete = lmsUserToDelete lu & LmsBool
, csvLUTstaff = False & LmsBool
}
-- csv without headers -- TODO not yet supported
-- instance Csv.ToRecord LmsUserTableCsv
@ -76,6 +88,7 @@ mkUserTable _sid qsh qid = do
where
dbtSQLQuery lmsuser = do
E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (lmsuser E.^. LmsUserEnded)
return lmsuser
dbtRowKey = (E.^. LmsUserId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
@ -116,8 +129,7 @@ mkUserTable _sid qsh qid = do
<*> view (_dbrOutput . _entityVal . _lmsUserPin)
<*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
-- <*> const $ LmsBool False
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
<*> const (LmsBool False)
dbtCsvDecode = Nothing
dbtExtraReps = []
@ -126,9 +138,8 @@ mkUserTable _sid qsh qid = do
& defaultSorting [SortAscBy csvLmsIdent]
dbTable userDBTableValidator userDBTable
getLmsUsersR, postLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUsersR = postLmsUsersR
postLmsUsersR sid qsh = do
getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUsersR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
view _2 <$> mkUserTable sid qsh qid
@ -136,6 +147,29 @@ postLmsUsersR sid qsh = do
setTitleI MsgMenuLmsUsers
$(widgetFile "lms-user")
getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsUsersDirectR sid qsh = do
lms_users <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent]
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
Ex.select $ do
lmsuser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid
Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded)
pure $ LmsUserTableCsv
{ csvLUTident = lmsuser Ex.^. LmsUserIdent
, csvLUTpin = lmsuser Ex.^. LmsUserPin
, csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin
, csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserSuccess)
, csvLUTstaff = LmsBool False
}
-}
let csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
csvRenderedHeader = lmsUserTableCsvHeader
csvSheetName <- csvFilenameLmsUser qsh
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContent csvSheetName CsvRendered{..}
-- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod