diff --git a/routes b/routes index 0a2262676..f76b98d79 100644 --- a/routes +++ b/routes @@ -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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 52b22c348..39aed96e6 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 03a704baa..a2bbbc88c 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -6,7 +6,7 @@ module Handler.LMS ( getLmsR , postLmsR - , getLmsUsersR , postLmsUsersR + , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR , getLmsResultR , postLmsResultR diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index ba6b8d688..f10585b62 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -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 \ No newline at end of file