From 8bcdbd95f00f4a19a435bd027757b16e12c62a6d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 18 Jul 2023 15:20:44 +0000 Subject: [PATCH] chore(lms): WIP towards new interface --- .../utils/navigation/menu/de-de-formal.msg | 2 + .../uniworx/utils/navigation/menu/en-eu.msg | 4 +- models/lms.model | 10 + routes | 8 + src/Foundation/Navigation.hs | 7 + src/Handler/LMS.hs | 11 +- src/Handler/LMS/Learners.hs | 197 ++++++++++++ src/Handler/LMS/Report.hs | 301 ++++++++++++++++++ src/Handler/Utils/LMS.hs | 49 ++- 9 files changed, 574 insertions(+), 15 deletions(-) create mode 100644 src/Handler/LMS/Learners.hs create mode 100644 src/Handler/LMS/Report.hs diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 06916dd81..548508ef4 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -129,6 +129,8 @@ MenuLmsUpload: Hochladen MenuLmsDirectUpload: Direkter Upload MenuLmsDirectDownload: Direkter Download MenuLmsFake: Testnutzer generieren +MenuLmsLearners: Export Benutzer E‑Learning +MenuLmsReport: Ergebnisse E‑Learning MenuSap: SAP Schnittstelle diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 0c8086373..c9799daa9 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -129,7 +129,9 @@ MenuLmsResult: Upload E‑Learning Results MenuLmsUpload: Upload MenuLmsDirectUpload: Direct Upload MenuLmsDirectDownload: Direct Download -MenuLmsFake: Generate test users +MenuLmsFake: Generate Test Users +MenuLmsLearners: E‑Learning Users +MenuLmsReport: E‑Learning Results MenuSap: SAP Interface diff --git a/models/lms.model b/models/lms.model index ccc8d91ee..24a2f3a48 100644 --- a/models/lms.model +++ b/models/lms.model @@ -151,3 +151,13 @@ LmsResult timestamp UTCTime default=now() UniqueLmsResult qualification ident -- required by DBTable deriving Generic + +LmsReport + qualification QualificationId OnDeleteCascade OnUpdateCascade + ident LmsIdent + date Day Maybe -- BEWARE: timezone is local as submitted by LMS + result Int -- (0|1|2) 0=too many ties, 1=open, 2=success + lock Int -- (0|1) + timestamp UTCTime default=now() + UniqueLmsReport qualification ident -- required by DBTable + deriving Generic \ No newline at end of file diff --git a/routes b/routes index 675f15ed4..795f54292 100644 --- a/routes +++ b/routes @@ -273,6 +273,7 @@ /lms/#SchoolId LmsSchoolR GET /lms/#SchoolId/#QualificationShorthand LmsR GET POST /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST +-- old V1 LMS Interface /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET /lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST @@ -281,6 +282,13 @@ /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST /lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS +-- new V2 LMS Interface +/lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET +/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST +/lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development +/lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS +-- other lms routes /lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter /lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET /lmsuser/#CryptoUUIDUser LmsUserAllR GET diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 61889afd1..cf3449c13 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -186,6 +186,13 @@ breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed +-- v2 +breadcrumb (LmsLearnersR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsR ssh qsh +breadcrumb (LmsLearnersDirectR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsLearnersR ssh qsh -- never displayed, TypedContent +breadcrumb (LmsReportR ssh qsh) = i18nCrumb MsgMenuLmsReport $ Just $ LmsR ssh qsh +breadcrumb (LmsReportUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh +breadcrumb (LmsReportDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh -- never displayed +-- breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect breadcrumb (LmsUserR ssh _qsh u ) = i18nCrumb MsgMenuLmsUser $ Just $ LmsUserSchoolR u ssh breadcrumb (LmsUserSchoolR u _ ) = i18nCrumb MsgMenuLmsUserSchool $ Just $ LmsUserAllR u diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 9eb5a6b57..2c1ac9739 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -12,11 +12,17 @@ module Handler.LMS , getLmsR , postLmsR , getLmsIdentR , getLmsEditR , postLmsEditR + -- V1 , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR , getLmsResultR , postLmsResultR , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR + -- V1 + , getLmsLearnersR , getLmsLearnersDirectR + , getLmsReportR , postLmsReportR + , getLmsReportUploadR , postLmsReportUploadR , postLmsReportDirectR + -- , getLmsFakeR , postLmsFakeR , getLmsUserR , getLmsUserSchoolR @@ -45,10 +51,13 @@ import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Database.Persist.Sql (deleteWhereCount) - +-- V1 import Handler.LMS.Users as Handler.LMS import Handler.LMS.Userlist as Handler.LMS import Handler.LMS.Result as Handler.LMS +-- V2 +import Handler.LMS.Learners as Handler.LMS +import Handler.LMS.Report as Handler.LMS import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production! diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs new file mode 100644 index 000000000..219f928ac --- /dev/null +++ b/src/Handler/LMS/Learners.hs @@ -0,0 +1,197 @@ +-- SPDX-FileCopyrightText: 2022 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances + +module Handler.LMS.Learners + ( getLmsLearnersR + , getLmsLearnersDirectR + ) + where + + +import Import + +import Handler.Utils +import Handler.Utils.Csv +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 -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Utils as E + +data LmsUserTableCsv = LmsUserTableCsv -- for csv export only + { csvLUTident :: LmsIdent + , csvLUTpin :: Text + , csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool + } + deriving Generic +makeLenses_ ''LmsUserTableCsv + +-- | Mundane conversion needed for direct download without dbTable onlu +lmsUser2csv :: Day -> LmsUser -> LmsUserTableCsv +lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv + { csvLUTident = lmsUserIdent + , csvLUTpin = lmsUserPin + , csvLUTresetPin = lmsUserResetPin & LmsBool + , csvLUTdelete = lmsUserToDelete cutoff lu & LmsBool + , csvLUTstaff = False & LmsBool + } + +-- csv without headers +instance Csv.ToRecord LmsUserTableCsv +instance Csv.FromRecord LmsUserTableCsv + +-- csv with headers +lmsUserTableCsvHeader :: Csv.Header +lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff ] + +instance ToNamedRecord LmsUserTableCsv where + toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord + [ csvLmsIdent Csv..= csvLUTident + , csvLmsPin Csv..= csvLUTpin + , csvLmsResetPin Csv..= csvLUTresetPin + , csvLmsDelete Csv..= csvLUTdelete + , csvLmsStaff Csv..= csvLUTstaff + ] +instance FromNamedRecord LmsUserTableCsv where + parseNamedRecord (lsfHeaderTranslate -> csv) + = LmsUserTableCsv + <$> csv Csv..: csvLmsIdent + <*> csv Csv..: csvLmsPin + <*> csv Csv..: csvLmsResetPin + <*> csv Csv..: csvLmsDelete + <*> csv Csv..: csvLmsStaff + +instance CsvColumnsExplained LmsUserTableCsv where + csvColumnsExplanations _ = mconcat + [ single csvLmsIdent MsgCsvColumnLmsIdent + , single csvLmsPin MsgCsvColumnLmsPin + , single csvLmsResetPin MsgCsvColumnLmsResetPin + , single csvLmsDelete MsgCsvColumnLmsDelete + , single csvLmsStaff MsgCsvColumnLmsStaff + ] + where + single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget + single k v = singletonMap k [whamlet|_{v}|] + + + +mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) +mkUserTable _sid qsh qid = do + cutoff <- liftHandler lmsDeletionDate + dbtCsvName <- csvFilenameLmsUser qsh + let dbtCsvSheetName = dbtCsvName + let + userDBTable = DBTable{..} + 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 = dbtProjId + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident + , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] + ) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin + , sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset + , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete cutoff -> del ) -> ifIconCell del IconRemoveUser + , sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty + ] + dbtSorting = Map.fromList + [ (csvLmsIdent , SortColumn (E.^. LmsUserIdent)) + , (csvLmsPin , SortColumn (E.^. LmsUserPin)) + , (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin)) + , (csvLmsDelete , SortColumn (lmsUserToDeleteExpr cutoff)) + ] + dbtFilter = Map.fromList + [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent )) + , (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast (E.^. LmsUserResetPin)) + ] + dbtFilterUI = \mPrev -> mconcat + [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgTableLmsResetPin) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "lms-user" + dbtCsvEncode = Just DBTCsvEncode {..} + where + dbtCsvExportForm = pure () + dbtCsvNoExportData = Just id + dbtCsvExampleData = Nothing + dbtCsvHeader = const $ return lmsUserTableCsvHeader + dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + doEncode' = LmsUserTableCsv + <$> view (_dbrOutput . _entityVal . _lmsUserIdent) + <*> view (_dbrOutput . _entityVal . _lmsUserPin) + <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) + <*> view (_dbrOutput . _entityVal . _lmsUserToDelete cutoff . _lmsBool) + <*> const (LmsBool False) + + dbtCsvDecode = Nothing + dbtExtraReps = [] + + userDBTableValidator = def + & defaultSorting [SortAscBy csvLmsIdent] + dbTable userDBTableValidator userDBTable + +getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsLearnersR sid qsh = do + lmsTable <- runDB $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + view _2 <$> mkUserTable sid qsh qid + siteLayoutMsg MsgMenuLmsUsers $ do + setTitleI MsgMenuLmsUsers + lmsTable + +getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent +getLmsLearnersDirectR sid qsh = do + $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid + cutoff <- lmsDeletionDate + lms_users <- runDB $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + selectList [ LmsUserQualification ==. qid + , LmsUserEnded ==. Nothing + -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta + ] [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.^. LmsUserStatus) + , csvLUTstaff = LmsBool False + } + -} + LmsConf{..} <- getsYesod $ view _appLmsConf + let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users + --csvRenderedHeader = lmsUserTableCsvHeader + --cvsRendered = CsvRendered {..} + csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users + fmtOpts = (review csvPreset CsvPresetRFC) + { csvIncludeHeader = lmsDownloadHeader + , csvDelimiter = lmsDownloadDelimiter + , csvUseCrLf = lmsDownloadCrLf + } + csvOpts = def { csvFormat = fmtOpts } + csvSheetName <- csvFilenameLmsUser qsh + let nr = length lms_users + msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" + $logInfoS "LMS" msg + addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" + csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered + +-- direct Download see: +-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs new file mode 100644 index 000000000..fe7046e82 --- /dev/null +++ b/src/Handler/LMS/Report.hs @@ -0,0 +1,301 @@ +-- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances + +module Handler.LMS.Report + ( getLmsReportR, postLmsReportR + , getLmsReportUploadR, postLmsReportUploadR + , postLmsReportDirectR + ) + where + +import Import + +import Handler.Utils +import Handler.Utils.Csv +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.Legacy as E +import qualified Database.Esqueleto.Utils as E + +import Jobs.Queue + + +data LmsReportTableCsv = LmsReportTableCsv + { csvLRident :: LmsIdent + , csvLRdate :: Maybe LmsDay + , csvLRresult :: Int + , csvLRlock :: Int + } + deriving Generic +makeLenses_ ''LmsReportTableCsv + +-- csv without headers +instance Csv.ToRecord LmsReportTableCsv -- default suffices +instance Csv.FromRecord LmsReportTableCsv -- default suffices + +-- csv with headers +lmsReportTableCsvHeader :: Csv.Header +lmsReportTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsDate, csvLmsResult, csvLmsLock ] + +instance ToNamedRecord LmsReportTableCsv where + toNamedRecord LmsReportTableCsv{..} = Csv.namedRecord + [ csvLmsIdent Csv..= csvLRident + , csvLmsDate Csv..= csvLRdate + , csvLmsResult Csv..= csvLRresult + , csvLmsLock Csv..= csvLRlock + ] + +instance FromNamedRecord LmsReportTableCsv where + parseNamedRecord (lsfHeaderTranslate -> csv) + = LmsReportTableCsv + <$> csv Csv..: csvLmsIdent + <*> csv Csv..: csvLmsDate + <*> csv Csv..: csvLmsResult + <*> csv Csv..: csvLmsLock + +instance CsvColumnsExplained LmsReportTableCsv where + csvColumnsExplanations _ = mconcat + [ single csvLmsIdent MsgCsvColumnLmsIdent + , single csvLmsDate MsgCsvColumnLmsDate + , single csvLmsResult MsgCsvColumnLmsResult + , single csvLmsLock MsgCsvColumnLmsLock + ] + where + single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget + single k v = singletonMap k [whamlet|_{v}|] + +data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate + deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) +embedRenderMessage ''UniWorX ''LmsReportCsvActionClass id + +-- By coincidence the action type is identical to LmsReportTableCsv +data LmsReportCsvAction = LmsReportInsertData { lmsReportInsertIdent :: LmsIdent, lmsReportInsertDate :: Maybe Day, lmsReportInsertResult :: Int, lmsReportInsertLock :: Int } + | LmsReportUpdateData { lmsReportInsertIdent :: LmsIdent, lmsReportInsertDate :: Maybe Day, lmsReportInsertResult :: Int, lmsReportInsertLock :: Int } + deriving (Eq, Ord, Read, Show, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsReportInsertData -> insert + , fieldLabelModifier = camelToPathPiece' 2 -- lmsReportInsertIdent -> insert-ident | lmsReportInsertSuccess -> insert-success + , sumEncoding = TaggedObject "action" "data" + } ''LmsReportCsvAction + +data LmsReportCsvException + = LmsReportCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! + deriving (Show, Generic) + +instance Exception LmsReportCsvException +embedRenderMessage ''UniWorX ''LmsReportCsvException id + +mkReportTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) +mkReportTable sid qsh qid = do + now_day <- utctDay <$> liftIO getCurrentTime + dbtCsvName <- csvFilenameLmsReport qsh + let dbtCsvSheetName = dbtCsvName + let + reportDBTable = DBTable{..} + where + dbtSQLQuery lmsReport = do + E.where_ $ lmsReport E.^. LmsReportQualification E.==. E.val qid + return lmsReport + dbtRowKey = (E.^. LmsReportId) + dbtProj = dbtProjId + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsReportIdent . _getLmsIdent -> ident) -> textCell ident + , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsReportSuccess -> success) -> dayCell success + , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp -> timestamp) -> dateTimeCell timestamp + ] + dbtSorting = Map.fromList + [ (csvLmsIdent , SortColumn (E.^. LmsReportIdent)) + , (csvLmsSuccess , SortColumn (E.^. LmsReportSuccess)) + , (csvLmsTimestamp, SortColumn (E.^. LmsReportTimestamp)) + ] + dbtFilter = Map.fromList + [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsReportIdent)) + , (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsReportSuccess)) + ] + dbtFilterUI = \mPrev -> mconcat + [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "lms-Report" + dbtCsvEncode = Just DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + , dbtCsvName + , dbtCsvSheetName + , dbtCsvNoExportData = Just id + , dbtCsvHeader = const $ return lmsReportTableCsvHeader + , dbtCsvExampleData = Just + [ LmsReportTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } + | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] + ] + } + where + doEncode' = LmsReportTableCsv + <$> view (_dbrOutput . _entityVal . _lmsReportIdent) + <*> view (_dbrOutput . _entityVal . _lmsReportSuccess . _lmsDay) + dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later + { dbtCsvRowKey = \LmsReportTableCsv{..} -> + fmap E.Value . MaybeT . getKeyBy $ UniqueLmsReport qid csvLRTident + , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first + DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do + yield $ LmsReportInsertData + { lmsReportInsertIdent = csvLRTident dbCsvNew + , lmsReportInsertSuccess = csvLRTsuccess dbCsvNew & lms2day + } + DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsReport was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code + DBCsvDiffExisting{dbCsvNew = LmsReportTableCsv{..}, dbCsvOld} -> do + let successDay = lms2day csvLRTsuccess + when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsReportSuccess) $ + yield $ LmsReportUpdateData + { lmsReportInsertIdent = csvLRTident + , lmsReportInsertSuccess = successDay + } + DBCsvDiffMissing{} -> return () -- no deletion + , dbtCsvClassifyAction = \case + LmsReportInsertData{} -> LmsReportInsert + LmsReportUpdateData{} -> LmsReportUpdate + , dbtCsvCoarsenActionClass = \case + LmsReportInsert -> DBCsvActionNew + LmsReportUpdate -> DBCsvActionExisting + , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error + , dbtCsvExecuteActions = do + C.mapM_ $ \actionData -> do + now <- liftIO getCurrentTime + void $ upsert + LmsReport + { lmsReportQualification = qid + , lmsReportIdent = lmsReportInsertIdent actionData + , lmsReportSuccess = lmsReportInsertSuccess actionData + , lmsReportTimestamp = now -- lmsReportInsertTimestamp -- does it matter which one to choose? + } + [ LmsReportSuccess =. lmsReportInsertSuccess actionData + , LmsReportTimestamp =. now + ] + -- audit $ Transaction.. (add to Audit.Types) + lift . queueDBJob $ JobLmsReports qid + return $ LmsReportR sid qsh + , dbtCsvRenderKey = const $ \case + LmsReportInsertData{..} -> do -- TODO: i18n + [whamlet| + $newline never + Insert: Ident #{getLmsIdent lmsReportInsertIdent} # + had success on ^{formatTimeW SelFormatDate lmsReportInsertSuccess} + |] + LmsReportUpdateData{..} -> do -- TODO: i18n + [whamlet| + $newline never + Update: Ident #{getLmsIdent lmsReportInsertIdent} # + had success on ^{formatTimeW SelFormatDate lmsReportInsertSuccess} + |] + , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure + , dbtCsvRenderException = ap getMessageRender . pure :: LmsReportCsvException -> DB Text + } + dbtExtraReps = [] + + ReportDBTableValidator = def + & defaultSorting [SortAscBy csvLmsIdent] + dbTable ReportDBTableValidator ReportDBTable + +getLmsReportR, postLmsReportR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsReportR = postLmsReportR +postLmsReportR sid qsh = do + let directUploadLink = LmsReportUploadR sid qsh + lmsTable <- runDB $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + view _2 <$> mkReportTable sid qsh qid + siteLayoutMsg MsgMenuLmsReport $ do + setTitleI MsgMenuLmsReport + $(widgetFile "lms-Report") + + +-- Direct File Upload/Download + +saveReportCsv :: QualificationId -> Int -> LmsReportTableCsv -> JobDB Int +saveReportCsv qid i LmsReportTableCsv{..} = do + now <- liftIO getCurrentTime + void $ upsert + LmsReport + { lmsReportQualification = qid + , lmsReportIdent = csvLRTident + , lmsReportSuccess = csvLRTsuccess & lms2day + , lmsReportTimestamp = now + } + [ LmsReportSuccess =. (csvLRTsuccess & lms2day) + , LmsReportTimestamp =. now + ] + return $ succ i + +makeReportUploadForm :: Form FileInfo +makeReportUploadForm = renderAForm FormStandard $ fileAFormReq "Report CSV" + +getLmsReportUploadR, postLmsReportUploadR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsReportUploadR = postLmsReportUploadR +postLmsReportUploadR sid qsh = do + ((Report,widget), enctype) <- runFormPost makeReportUploadForm + case Report of + FormSuccess file -> do + -- content <- fileSourceByteString file + -- return $ Just (fileName file, content) + nr <- runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + nr <- runConduit $ fileSource file + .| decodeCsv + .| foldMC (saveReportCsv qid) 0 + queueDBJob $ JobLmsReports qid + return nr + addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") + redirect $ LmsReportR sid qsh + FormFailure errs -> do + forM_ errs $ addMessage Error . toHtml + redirect $ LmsReportUploadR sid qsh + FormMissing -> + siteLayoutMsg MsgMenuLmsReport $ do + setTitleI MsgMenuLmsUpload + [whamlet|$newline never +
+ ^{widget} +

+ + |] + + +postLmsReportDirectR :: SchoolId -> QualificationShorthand -> Handler Html +postLmsReportDirectR sid qsh = do + (_params, files) <- runRequestBody + (status, msg) <- case files of + [(fhead,file)] -> do + lmsDecoder <- getLmsCsvDecoder + runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + enr <- try $ runConduit $ fileSource file + .| lmsDecoder + .| foldMC (saveReportCsv qid) 0 + case enr of + Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error + $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e + return (badRequest400, "Exception: " <> tshow e) + Right nr -> do + let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " + $logInfoS "LMS" msg + when (nr > 0) $ queueDBJob $ JobLmsReports qid + return (ok200, msg) + [] -> do + let msg = "Report upload file missing." + $logWarnS "LMS" msg + return (badRequest400, msg) + _other -> do + let msg = "Report upload received multiple files; all ignored." + $logWarnS "LMS" msg + return (badRequest400, msg) + sendResponseStatus status msg + diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index e832af3dc..b93c832ba 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -7,6 +7,7 @@ module Handler.Utils.LMS ( getLmsCsvDecoder , csvLmsIdent + , csvLmsDate , csvLmsTimestamp , csvLmsBlocked , csvLmsSuccess @@ -14,9 +15,13 @@ module Handler.Utils.LMS , csvLmsResetPin , csvLmsDelete , csvLmsStaff + , csvLmsResetTries + , csvLmsLock + , csvLmsResult , csvFilenameLmsUser , csvFilenameLmsUserlist , csvFilenameLmsResult + , csvFilenameLmsReport , lmsDeletionDate , lmsUserToDelete, _lmsUserToDelete , lmsUserToDeleteExpr @@ -56,45 +61,63 @@ getLmsCsvDecoder = do -- generic Column names csvLmsIdent :: IsString a => a -csvLmsIdent = fromString "user" -- "Benutzerkennung" +csvLmsIdent = fromString "user" -- "Benutzerkennung" V1, V2 + +csvLmsDate :: IsString a => a +csvLmsDate = fromString "date" -- "Datum", V2 csvLmsTimestamp :: IsString a => a -csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel" +csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel" V1 -- for Users Table csvLmsPin :: IsString a => a -csvLmsPin = fromString "pin" -- "PIN" +csvLmsPin = fromString "pin" -- "PIN" V1, V2 csvLmsResetPin :: IsString a => a -csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen" +csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen" V1, V2 csvLmsDelete :: IsString a => a -csvLmsDelete = fromString "delete" -- "Account löschen" +csvLmsDelete = fromString "delete" -- "Account löschen" V1, V2 csvLmsStaff :: IsString a => a -csvLmsStaff = fromString "staff" -- "Mitarbeiter" +csvLmsStaff = fromString "staff" -- "Mitarbeiter" V1, V2 --- for Userlist Table +csvLmsResetTries :: IsString a => a +csvLmsResetTries = fromString "reset_tries" -- Anzahl Versuche zurücksetzen, V2 + +csvLmsLock :: IsString a => a +csvLmsLock = fromString "lock" -- Ist der Login derzeit gesperrt? V2 + +-- for Userlist Table V1 csvLmsBlocked :: IsString a => a -csvLmsBlocked = fromString "blocked" -- "Sperrung" +csvLmsBlocked = fromString "blocked" -- "Sperrung" V1 --- for Result Table +-- for Result Table V1 csvLmsSuccess :: IsString a => a -csvLmsSuccess = fromString "success" -- "Datum" +csvLmsSuccess = fromString "success" -- "Datum" V1 + +-- for Report Table V2 +csvLmsResult :: IsString a => a +csvLmsResult = fromString "result" -- LmsStatus: 0=Versuche aufgebraucht, 1=Offen, 2=Bestanden V2 --- | Filename for User transmission, contains current datestamp as agreed in LMS interface + +-- | Filename for User transmission, contains current datestamp as agreed in LMS interface V1 & V2 csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsUser = makeLmsFilename "user" --- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface +-- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface V2 csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsUserlist = makeLmsFilename "userliste" --- | Filename for Result transmission, contains current datestamp as agreed in LMS interface +-- | Filename for Result transmission, contains current datestamp as agreed in LMS interface V1 csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsResult = makeLmsFilename "ergebnisse" +-- | Filename for Report transmission, combining former Userlist and Result as agreed in new LMS interface V2 +csvFilenameLmsReport :: MonadHandler m => QualificationShorthand -> m Text +csvFilenameLmsReport = makeLmsFilename "report" + -- | Create filenames as specified by the LMS interface agreed with Know How AG makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand -> m Text makeLmsFilename ftag (citext2lower -> qsh) = do