From 5aae0339fb9f81db384b7b84957f11810b6b4140 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 7 Mar 2022 12:51:04 +0100 Subject: [PATCH] refactor(lms): simplify lms result interface --- .../categories/qualification/de-de-formal.msg | 3 +- .../categories/qualification/en-eu.msg | 1 + src/Handler/LMS/Result.hs | 142 ++++------- src/Handler/LMS/User.hs | 235 ++++++++++++++++++ src/Handler/LMS/Userlist.hs | 20 +- src/Handler/Utils/LMS.hs | 6 +- 6 files changed, 307 insertions(+), 100 deletions(-) create mode 100644 src/Handler/LMS/User.hs diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 1e1008da3..72b2dbc66 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -6,7 +6,8 @@ CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Tei CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts LmsUserlistInsert: Neuer LMS User -LmsUserlistUpdate: Aktualisierung von LMS User +LmsUserlistUpdate: LMS User aktualisierung LmsResultInsert: Neues LMS Ergebnis +LmsResultUpdate: LMS Ergebnis aktualisierung LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index f1c822915..7df25fb11 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -8,5 +8,6 @@ CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversu LmsUserlistInsert: New LMS User LmsUserlistUpdate: Update of LMS User LmsResultInsert: New LMS result +LmsResultUpdate: Update of LMS result LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key \ No newline at end of file diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index e24ebb641..4d99eae29 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -17,50 +17,8 @@ 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 Database.Esqueleto.Utils.TH - -type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification) - `E.InnerJoin` E.SqlExpr (Entity LmsResult) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) - `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) - -queryQualification :: LmsResultTableExpr -> E.SqlExpr (Entity Qualification) -queryQualification = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) - -queryLmsResult :: LmsResultTableExpr -> E.SqlExpr (Entity LmsResult) -queryLmsResult = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) - -queryLmsUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) -queryLmsUser = $(sqlLOJproj 3 2) - -queryUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity User)) -queryUser = $(sqlLOJproj 3 3) - -type LmsResultTableData = DBRow (Entity Qualification, Entity LmsResult, Maybe (Entity LmsUser), Maybe (Entity User)) - -instance HasEntity LmsResultTableData LmsResult where - hasEntity = _dbrOutput . _2 - -{- MaybeHasUser only! -instance HasUser LmsResultTableData where - hasUser = _dbrOutput . _4 . _entityVal --} - -resultQualification :: Lens' LmsResultTableData (Entity Qualification) -resultQualification = _dbrOutput . _1 - -resultLmsResult :: Lens' LmsResultTableData (Entity LmsResult) -resultLmsResult = _dbrOutput . _2 - -resultLmsUser :: Traversal' LmsResultTableData (Entity LmsUser) -resultLmsUser = _dbrOutput . _3 . _Just - -resultUser :: Traversal' LmsResultTableData (Entity User) -resultUser = _dbrOutput . _4 . _Just - --- required for import only data LmsResultTableCsv = LmsResultTableCsv { csvLRTident :: LmsIdent , csvLRTsuccess :: Day @@ -68,11 +26,11 @@ data LmsResultTableCsv = LmsResultTableCsv deriving Generic makeLenses_ ''LmsResultTableCsv --- csv without headers +-- csv without headers -- TODO not yet supported instance Csv.ToRecord LmsResultTableCsv -- default suffices instance Csv.FromRecord LmsResultTableCsv -- default suffices --- csv with headers -- TODO not yet supported +-- csv with headers lmsResultTableCsvHeader :: Csv.Header lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ] @@ -97,12 +55,13 @@ instance CsvColumnsExplained LmsResultTableCsv where single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget single k v = singletonMap k [whamlet|_{v}|] -data LmsResultCsvActionClass = LmsResultInsert +data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded) embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id -- By coincidence the action type is identical to LmsResultTableCsv data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } + | LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions @@ -118,8 +77,6 @@ data LmsResultCsvException instance Exception LmsResultCsvException embedRenderMessage ''UniWorX ''LmsResultCsvException id - - mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkResultTable sid qsh qid = do dbtCsvName <- csvFilenameLmsResult qsh @@ -128,35 +85,28 @@ mkResultTable sid qsh qid = do resultDBTable = DBTable{..} where - dbtSQLQuery = runReaderT $ do - qualification <- asks queryQualification - lmsResult <- asks queryLmsResult - lmsUser <- asks queryLmsUser - user <- asks queryUser - lift $ do - E.on $ qualification E.^. QualificationId E.==. lmsResult E.^. LmsResultQualification - E.on $ lmsUser E.?. LmsUserIdent E.==. E.just (lmsResult E.^. LmsResultIdent) - E.on $ lmsUser E.?. LmsUserUser E.==. user E.?. UserId - E.where_ $ qualification E.^. QualificationId E.==. E.val qid - return (qualification, lmsResult, lmsUser, user) - dbtRowKey = queryLmsResult >>> (E.^. LmsResultId) + dbtSQLQuery lmsresult = do + E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid + return lmsresult + dbtRowKey = (E.^. LmsResultId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtColonnade = dbColonnade $ mconcat - [ sortable (Just csvResultIdent) (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident - , sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success - ] -- TODO: add more columns for manual debugging view !!! + [ sortable (Just csvResultIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident + , sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success + , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp + ] dbtSorting = Map.fromList - [ (csvResultIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) - -- , (csvResultSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) - , (csvResultSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + [ (csvResultIdent , SortColumn (E.^. LmsResultIdent)) + , (csvResultSuccess, SortColumn (E.^. LmsResultSuccess)) + , (csvLmsTimestamp , SortColumn (E.^. LmsResultTimestamp)) ] dbtFilter = Map.fromList - [ (csvResultIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) - , (csvResultSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + [ (csvResultIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent)) + , (csvResultSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess)) ] dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvResultIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess) + [ prismAForm (singletonFilter csvResultIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess) ] dbtStyle = def dbtParams = def @@ -173,46 +123,60 @@ mkResultTable sid qsh qid = do } where doEncode' = LmsResultTableCsv - <$> view (resultLmsResult . _entityVal . _lmsResultIdent) - <*> view (resultLmsResult . _entityVal . _lmsResultSuccess) - + <$> view (_dbrOutput . _entityVal . _lmsResultIdent) + <*> view (_dbrOutput . _entityVal . _lmsResultSuccess) dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later { dbtCsvRowKey = \LmsResultTableCsv{..} -> fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do yield $ LmsResultInsertData - { lmsResultInsertIdent = csvLRTident dbCsvNew - , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew + { lmsResultInsertIdent = csvLRTident dbCsvNew + , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew } DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code + DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}} -> do + yield $ LmsResultUpdateData + { lmsResultInsertIdent = csvLRTident + , lmsResultInsertSuccess = csvLRTsuccess + } DBCsvDiffMissing{} -> return () -- no deletion - DBCsvDiffExisting{} -> return () -- no merge TODO!!! ADD MERGE DUE TO Uniqueness! - , dbtCsvClassifyAction = \LmsResultInsertData{} -> LmsResultInsert - , dbtCsvCoarsenActionClass = \LmsResultInsert -> DBCsvActionNew -- there is only one action: insert into table + , dbtCsvClassifyAction = \case + LmsResultInsertData{} -> LmsResultInsert + LmsResultUpdateData{} -> LmsResultUpdate + , dbtCsvCoarsenActionClass = \case + LmsResultInsert -> DBCsvActionNew + LmsResultUpdate -> DBCsvActionExisting , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error , dbtCsvExecuteActions = do - C.mapM_ $ \LmsResultInsertData{..} -> do + C.mapM_ $ \actionData -> do now <- liftIO getCurrentTime void $ upsert LmsResult - { lmsResultQualification = qid - , lmsResultIdent = lmsResultInsertIdent - , lmsResultSuccess = lmsResultInsertSuccess - , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? + { lmsResultQualification = qid + , lmsResultIdent = lmsResultInsertIdent actionData + , lmsResultSuccess = lmsResultInsertSuccess actionData + , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? } - [ LmsResultSuccess =. lmsResultInsertSuccess + [ LmsResultSuccess =. lmsResultInsertSuccess actionData , LmsResultTimestamp =. now ] -- queueDBJob?? -- todo -- audit return $ LmsResultR sid qsh - , dbtCsvRenderKey = \_ LmsResultInsertData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Ident #{getLmsIdent lmsResultInsertIdent} # - had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} - |] + , dbtCsvRenderKey = const $ \case + LmsResultInsertData{..} -> do -- TODO: i18n + [whamlet| + $newline never + Insert: Ident #{getLmsIdent lmsResultInsertIdent} # + had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} + |] + LmsResultUpdateData{..} -> do -- TODO: i18n + [whamlet| + $newline never + Update: Ident #{getLmsIdent lmsResultInsertIdent} # + had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} + |] , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text } diff --git a/src/Handler/LMS/User.hs b/src/Handler/LMS/User.hs new file mode 100644 index 000000000..184ac64c2 --- /dev/null +++ b/src/Handler/LMS/User.hs @@ -0,0 +1,235 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances +{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only + +module Handler.LMS.User + ( getLmsUserR, postLmsUserR + ) + where + +-- TODO: needs complete refactoring! Old RESULT templates follows + +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 Database.Esqueleto.Utils.TH + + + +type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification) + `E.InnerJoin` E.SqlExpr (Entity LmsResult) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) + +queryQualification :: LmsResultTableExpr -> E.SqlExpr (Entity Qualification) +queryQualification = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) + +queryLmsResult :: LmsResultTableExpr -> E.SqlExpr (Entity LmsResult) +queryLmsResult = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) + +queryLmsUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) +queryLmsUser = $(sqlLOJproj 3 2) + +queryUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity User)) +queryUser = $(sqlLOJproj 3 3) + +type LmsResultTableData = DBRow (Entity Qualification, Entity LmsResult, Maybe (Entity LmsUser), Maybe (Entity User)) + +instance HasEntity LmsResultTableData LmsResult where + hasEntity = _dbrOutput . _2 + +{- MaybeHasUser only! +instance HasUser LmsResultTableData where + hasUser = _dbrOutput . _4 . _entityVal +-} + +resultQualification :: Lens' LmsResultTableData (Entity Qualification) +resultQualification = _dbrOutput . _1 + +resultLmsResult :: Lens' LmsResultTableData (Entity LmsResult) +resultLmsResult = _dbrOutput . _2 + +resultLmsUser :: Traversal' LmsResultTableData (Entity LmsUser) +resultLmsUser = _dbrOutput . _3 . _Just + +resultUser :: Traversal' LmsResultTableData (Entity User) +resultUser = _dbrOutput . _4 . _Just + +-- required for import only +data LmsResultTableCsv = LmsResultTableCsv + { csvLRTident :: LmsIdent + , csvLRTsuccess :: Day + } + deriving Generic +makeLenses_ ''LmsResultTableCsv + +-- csv without headers +instance Csv.ToRecord LmsResultTableCsv -- default suffices +instance Csv.FromRecord LmsResultTableCsv -- default suffices + +-- csv with headers -- TODO not yet supported +lmsResultTableCsvHeader :: Csv.Header +lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ] + +instance ToNamedRecord LmsResultTableCsv where + toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord + [ csvResultIdent Csv..= csvLRTident + , csvResultSuccess Csv..= csvLRTsuccess + ] + +instance FromNamedRecord LmsResultTableCsv where + parseNamedRecord (lsfHeaderTranslate -> csv) + = LmsResultTableCsv + <$> csv Csv..: csvResultIdent + <*> csv Csv..: csvResultSuccess + +instance CsvColumnsExplained LmsResultTableCsv where + csvColumnsExplanations _ = mconcat + [ single csvResultIdent MsgCsvColumnLmsIdent + , single csvResultSuccess MsgCsvColumnLmsSuccess + ] + where + single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget + single k v = singletonMap k [whamlet|_{v}|] + +data LmsResultCsvActionClass = LmsResultInsert + deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded) +embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id + +-- By coincidence the action type is identical to LmsResultTableCsv +data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert + , fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success + , sumEncoding = TaggedObject "action" "data" + } ''LmsResultCsvAction + +data LmsResultCsvException + = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! + deriving (Show, Generic, Typeable) + +instance Exception LmsResultCsvException +embedRenderMessage ''UniWorX ''LmsResultCsvException id + + + +mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) +mkResultTable sid qsh qid = do + dbtCsvName <- csvFilenameLmsResult qsh + let dbtCsvSheetName = dbtCsvName + let + resultDBTable = DBTable{..} + where + + dbtSQLQuery = runReaderT $ do + qualification <- asks queryQualification + lmsResult <- asks queryLmsResult + lmsUser <- asks queryLmsUser + user <- asks queryUser + lift $ do + E.on $ qualification E.^. QualificationId E.==. lmsResult E.^. LmsResultQualification + E.on $ lmsUser E.?. LmsUserIdent E.==. E.just (lmsResult E.^. LmsResultIdent) + E.on $ lmsUser E.?. LmsUserUser E.==. user E.?. UserId + E.where_ $ qualification E.^. QualificationId E.==. E.val qid + return (qualification, lmsResult, lmsUser, user) + dbtRowKey = queryLmsResult >>> (E.^. LmsResultId) + dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just csvResultIdent) (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident + , sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success + ] -- TODO: add more columns for manual debugging view !!! + dbtSorting = Map.fromList + [ (csvResultIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) + -- , (csvResultSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) + , (csvResultSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + ] + dbtFilter = Map.fromList + [ (csvResultIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) + , (csvResultSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + ] + dbtFilterUI = \mPrev -> mconcat + [ prismAForm (singletonFilter csvResultIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess) + ] + dbtStyle = def + dbtParams = def + dbtIdent :: Text + dbtIdent = "lms-result" + dbtCsvEncode = Just DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + , dbtCsvName + , dbtCsvSheetName + , dbtCsvNoExportData = Just id + , dbtCsvHeader = const $ return lmsResultTableCsvHeader + , dbtCsvExampleData = Nothing + } + where + doEncode' = LmsResultTableCsv + <$> view (resultLmsResult . _entityVal . _lmsResultIdent) + <*> view (resultLmsResult . _entityVal . _lmsResultSuccess) + + dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later + { dbtCsvRowKey = \LmsResultTableCsv{..} -> + fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess + , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first + DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do + yield $ LmsResultInsertData + { lmsResultInsertIdent = csvLRTident dbCsvNew + , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew + } + DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code + DBCsvDiffMissing{} -> return () -- no deletion + DBCsvDiffExisting{} -> return () -- no merge TODO!!! ADD MERGE DUE TO Uniqueness! + , dbtCsvClassifyAction = \LmsResultInsertData{} -> LmsResultInsert + , dbtCsvCoarsenActionClass = \LmsResultInsert -> DBCsvActionNew -- there is only one action: insert into table + , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error + , dbtCsvExecuteActions = do + C.mapM_ $ \LmsResultInsertData{..} -> do + now <- liftIO getCurrentTime + void $ upsert + LmsResult + { lmsResultQualification = qid + , lmsResultIdent = lmsResultInsertIdent + , lmsResultSuccess = lmsResultInsertSuccess + , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? + } + [ LmsResultSuccess =. lmsResultInsertSuccess + , LmsResultTimestamp =. now + ] + -- queueDBJob?? -- todo + -- audit + return $ LmsResultR sid qsh + , dbtCsvRenderKey = \_ LmsResultInsertData{..} -> do -- TODO: i18n + [whamlet| + $newline never + Ident #{getLmsIdent lmsResultInsertIdent} # + had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} + |] + , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure + , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text + } + dbtExtraReps = [] + + resultDBTableValidator = def + & defaultSorting [SortAscBy csvResultIdent] + dbTable resultDBTableValidator resultDBTable + +getLmsUserR, postLmsUserR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsUserR = postLmsUserR +postLmsUserR sid qsh = do + lmsTable <- runDB $ do + qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + view _2 <$> mkResultTable sid qsh qid + siteLayoutMsg MsgMenuLmsResult $ do + setTitleI MsgMenuLmsResult + $(widgetFile "lms-result") diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 35902b986..1970812f7 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances -{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only -{-# OPTIONS -Wno-unused-imports #-} -- TODO: remove me, for debugging only +{- # OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only +{- # OPTIONS -Wno-unused-imports #-} -- TODO: remove me, for debugging only module Handler.LMS.Userlist ( getLmsUserlistR, postLmsUserlistR @@ -18,7 +18,7 @@ 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 Database.Esqueleto.Utils.TH + data LmsUserlistTableCsv = LmsUserlistTableCsv { csvLULident :: LmsIdent @@ -93,12 +93,12 @@ mkUserlistTable sid qsh qid = do dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvUserlistIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent , sortable (Just csvUserlistBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell lmsUserlistFailed - , sortable (Just "timestamp") (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp + , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp ] dbtSorting = Map.fromList [ (csvUserlistIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent) , (csvUserlistBlocked, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed) - , ("timestamp" , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp) + , (csvLmsTimestamp , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp) ] dbtFilter = Map.fromList [ (csvUserlistIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) @@ -150,15 +150,17 @@ mkUserlistTable sid qsh qid = do now <- liftIO getCurrentTime void $ upsert LmsUserlist { - lmsUserlistQualification = qid - , lmsUserlistIdent = lmsUserlistInsertIdent actionData - , lmsUserlistFailed = lmsUserlistInsertFailed actionData - , lmsUserlistTimestamp = now + lmsUserlistQualification = qid + , lmsUserlistIdent = lmsUserlistInsertIdent actionData + , lmsUserlistFailed = lmsUserlistInsertFailed actionData + , lmsUserlistTimestamp = now } [ LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False? , LmsUserlistTimestamp =. now ] + -- queueDBJob?? -- todo + -- audit return $ LmsUserlistR sid qsh dbtCsvRenderKey = const $ \case LmsUserlistInsertData{..} -> do -- TODO: i18n diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index b06d930fd..267db1f5d 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -1,5 +1,6 @@ module Handler.Utils.LMS - ( csvUserlistIdent, csvUserlistBlocked + ( csvLmsTimestamp + , csvUserlistIdent, csvUserlistBlocked , csvResultIdent, csvResultSuccess , csvFilenameLmsUser , csvFilenameLmsUserlist @@ -12,6 +13,9 @@ import Import import Handler.Utils -- Column names +csvLmsTimestamp :: IsString a => a +csvLmsTimestamp = fromString "Zeitstempel" + csvUserlistIdent :: IsString a => a csvUserlistIdent = fromString "Benutzerkennung" csvUserlistBlocked :: IsString a => a