From c1d0f636201ba95b675625c4d620430c975eb4cd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 24 Feb 2022 12:37:02 +0100 Subject: [PATCH 1/7] chore(lms): add dd-mm-yyyy date format specified in lms interface --- src/Handler/Utils/DateTime.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 14693fe6a..edcfbdc42 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -167,6 +167,8 @@ validDateTimeFormats _ SelFormatDate = Set.fromList , DateTimeFormat "%A %d.%m.%Y" , DateTimeFormat "%Y-%m-%d" , DateTimeFormat "%y-%m-%d" + , DateTimeFormat "%d-%m-%Y" + , DateTimeFormat "%d-%m-%y" ] validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catMaybes $ [ Just @@ -336,7 +338,7 @@ instance Csv.FromField ZonedTime where return $ utcToZonedTime _ltuResult parseFormats = do - date <- ["%Y-%m-%d", "%d.%m.%Y"] + date <- ["%Y-%m-%d", "%d.%m.%Y", "%d-%m-%Y"] sep <- ["T", " "] doZone <- [True, False] let zone = bool "" "%z" doZone -- 2.39.2 From aa54bba62b1ae7b593461b58820c8c4c0c3abf04 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 24 Feb 2022 13:03:59 +0100 Subject: [PATCH 2/7] chore(lms): encode bool by 0 and 1 in lms csv export/import --- src/Handler/LMS/Userlist.hs | 12 ++++++------ src/Model/Types/Lms.hs | 25 +++++++++++++++++++++++++ 2 files changed, 31 insertions(+), 6 deletions(-) diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 73a04b422..35902b986 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -22,13 +22,13 @@ import Database.Esqueleto.Utils.TH data LmsUserlistTableCsv = LmsUserlistTableCsv { csvLULident :: LmsIdent - , csvLULfailed :: Bool + , csvLULfailed :: LmsBool } deriving Generic makeLenses_ ''LmsUserlistTableCsv -- csv without headers -- TODO not yet supported -instance Csv.ToRecord LmsUserlistTableCsv +instance Csv.ToRecord LmsUserlistTableCsv instance Csv.FromRecord LmsUserlistTableCsv -- csv with headers @@ -121,7 +121,7 @@ mkUserlistTable sid qsh qid = do dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) doEncode' = LmsUserlistTableCsv <$> view (_dbrOutput . _entityVal . _lmsUserlistIdent) - <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed) + <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool) dbtCsvDecode = Just DBTCsvDecode {..} where dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} -> @@ -129,13 +129,13 @@ mkUserlistTable sid qsh qid = do dbtCsvComputeActions = \case -- shows a diff first DBCsvDiffNew{dbCsvNew} -> do yield $ LmsUserlistInsertData - { lmsUserlistInsertIdent = csvLULident dbCsvNew - , lmsUserlistInsertFailed = csvLULfailed dbCsvNew + { lmsUserlistInsertIdent = csvLULident dbCsvNew + , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew } DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}} -> do yield $ LmsUserlistUpdateData { lmsUserlistInsertIdent = csvLULident - , lmsUserlistInsertFailed = csvLULfailed + , lmsUserlistInsertFailed = csvLULfailed & lms2bool } DBCsvDiffMissing{} -> return () -- no deletion dbtCsvClassifyAction = \case diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index d62851469..13d2ae183 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -36,3 +36,28 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "lmsaudit" "lmsaction" } ''LmsStatus derivePersistFieldJSON ''LmsStatus + + +-- LMS Interface requires Bool to be encoded by 0 or 1 only +data LmsBool = LmsUnset | LmsSet + deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData) + +lms2bool :: LmsBool -> Bool +lms2bool LmsUnset = False +lms2bool LmsSet = True +bool2lms :: Bool -> LmsBool +bool2lms False = LmsUnset +bool2lms True = LmsSet + +_lmsBool :: Iso' Bool LmsBool +_lmsBool = iso bool2lms lms2bool + +instance Csv.ToField LmsBool where + toField LmsUnset = "0" + toField LmsSet = "1" + +instance Csv.FromField LmsBool where + parseField i + | i == "0" = pure LmsUnset + | i == "1" = pure LmsSet + | otherwise = empty -- 2.39.2 From 7b8e566f65aae484e4d6e077f26009ae4fe821ac Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 24 Feb 2022 14:00:07 +0100 Subject: [PATCH 3/7] refactor(lms): encode bool by 0 and 1 in lms csv export/import --- src/Model/Types/Lms.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 13d2ae183..59790590c 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -39,6 +39,7 @@ derivePersistFieldJSON ''LmsStatus -- LMS Interface requires Bool to be encoded by 0 or 1 only +{- data LmsBool = LmsUnset | LmsSet deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData) @@ -61,3 +62,20 @@ instance Csv.FromField LmsBool where | i == "0" = pure LmsUnset | i == "1" = pure LmsSet | otherwise = empty +-} + +newtype LmsBool = LmsBool { lms2bool :: Bool } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +_lmsBool :: Iso' Bool LmsBool +_lmsBool = iso LmsBool lms2bool + +instance Csv.ToField LmsBool where + toField (LmsBool False) = "0" + toField (LmsBool True ) = "1" + +instance Csv.FromField LmsBool where + parseField i + | i == "0" = pure $ LmsBool False + | i == "1" = pure $ LmsBool True + | otherwise = empty -- 2.39.2 From 864c2f13ad9095bd68fd1fb89140239fe464d150 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 3 Mar 2022 16:58:28 +0100 Subject: [PATCH 4/7] chore(status): minor code cleaning --- src/Handler/Health.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 02257e1e9..ca41fe686 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -2,7 +2,7 @@ module Handler.Health where import Import -import Handler.Utils +-- import Handler.Utils import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.Text.Lazy.Builder as Builder @@ -106,7 +106,7 @@ getStatusR :: Handler Html getStatusR = do starttime <- getsYesod appStartTime currtime <- liftIO getCurrentTime - ft <- formatTime' "%Y%m%d %H:%M:%S" currtime -- use me throughout or delete me (delete, since this Handler is for mechanised tests only) + -- ft <- formatTime' "%Y-%m-%d %H:%M:%S" currtime withUrlRenderer [hamlet| $doctype 5 @@ -116,8 +116,7 @@ getStatusR = do

Current Time
- #{show currtime}
- #{ft} + #{show currtime}

Instance Start
#{show starttime} # -- 2.39.2 From 1acaf54840c4f1bd4b2e20520b4903909e9ae52b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 4 Mar 2022 11:43:39 +0100 Subject: [PATCH 5/7] chore(fill): rename avn-a to proper fa --- test/Database/Fill.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 0c5e82d16..7d16bb3e9 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -434,7 +434,7 @@ fillDb = do } ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True - avn <- insert' $ School "Fahrschule" "AVN-A" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True + avn <- insert' $ School "Fahrerausbildung" "FA" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True void . insert' $ UserFunction jost avn SchoolAdmin void . insert' $ UserFunction gkleen ifi SchoolAdmin void . insert' $ UserFunction gkleen mi SchoolAdmin -- 2.39.2 From 5aae0339fb9f81db384b7b84957f11810b6b4140 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 7 Mar 2022 12:51:04 +0100 Subject: [PATCH 6/7] 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 -- 2.39.2 From dc4ea0cc29ea089e097ed03e8defd86e1a1a1363 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 7 Mar 2022 19:12:15 +0100 Subject: [PATCH 7/7] chore(lms): export user implemented --- .../categories/qualification/de-de-formal.msg | 12 +- .../categories/qualification/en-eu.msg | 14 +- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + models/lms.model | 3 +- routes | 2 +- src/Foundation/Navigation.hs | 1 + src/Handler/LMS.hs | 225 ++++++++++++++++- src/Handler/LMS/Result.hs | 40 +-- src/Handler/LMS/User.hs | 235 ------------------ src/Handler/LMS/Userlist.hs | 42 ++-- src/Handler/LMS/Users.hs | 136 ++++++++++ src/Handler/Utils/LMS.hs | 59 +++-- src/Handler/Utils/Table/Cells.hs | 4 + src/Utils/Icon.hs | 6 + templates/lms-user.hamlet | 2 + templates/lms.hamlet | 5 + test/Database/Fill.hs | 7 +- 18 files changed, 489 insertions(+), 306 deletions(-) delete mode 100644 src/Handler/LMS/User.hs create mode 100644 src/Handler/LMS/Users.hs create mode 100644 templates/lms-user.hamlet diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 72b2dbc66..5ffa99c7e 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -1,8 +1,16 @@ TableLmsIdent: Identifikation -TableLmsFailed: Gesperrt -TableLmsSuccess: Bestanden +TableLmsPin: E-Lernen Pin +TableLmsResetPin: Pin zurücksetzen? +TableLmsDelete: Löschen? +TableLmsStaff: Interner Mitarbeiter? TableLmsReceived: Erhalten +TableLmsSuccess: Bestanden +TableLmsFailed: Gesperrt CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer +CsvColumnLmsPin: PIN des E-Lernen Zugangs +CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt? +CsvColumnLmsDelete: Wird der Identifikator in der E-Lernen Plattform bei der nächsten Synchronisation gelöscht? +CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.) CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts LmsUserlistInsert: Neuer LMS User diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 7df25fb11..0eeca65f9 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -1,8 +1,16 @@ TableLmsIdent: Identifier -TableLmsFailed: Blocked -TableLmsSuccess: Completed +TableLmsPin: E-learning pin +TableLmsResetPin: Reset pin? +TableLmsDelete: Delete? +TableLmsStaff: Staff? TableLmsReceived: Received -CsvColumnLmsIdent: E-Learing identifier, unique for each qualfication and user +TableLmsSuccess: Completed +TableLmsFailed: Blocked +CsvColumnLmsIdent: E-learning identifier, unique for each qualfication and user +CsvColumnLmsPin: PIN for E-learning access +CsvColumnLmsResetPin: Will the E-learning PIN be reset upon next synchronisation? +CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom upon next synchronisation? +CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored) CsvColumnLmsSuccess: Timestamp of successful completion CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche LmsUserlistInsert: New LMS User diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 0ccd16936..51d4765fc 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -124,5 +124,6 @@ MenuCourseEventEdit: Kurstermin bearbeiten MenuLanguage: Sprache MenuLms: Schnittstelle E-Lernen +MenuLmsUsers: Empfang E-Lernen Benutzer MenuLmsUserlist: Melden E-Lernen Benutzer MenuLmsResult: Melden Ergebnisse E-Lernen \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index dc5646b24..255a07c22 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -125,5 +125,6 @@ MenuCourseEventEdit: Edit course occurrence MenuLanguage: Language MenuLms: Interface E-Learning +MenuLmsUsers: Download E-Learning Users MenuLmsUserlist: Upload E-Learning Users MenuLmsResult: Upload E-Learning Results \ No newline at end of file diff --git a/models/lms.model b/models/lms.model index 5747095ab..c04e02404 100644 --- a/models/lms.model +++ b/models/lms.model @@ -90,11 +90,12 @@ QualificationUser LmsUser qualification QualificationId OnDeleteCascade OnUpdateCascade user UserId - ident LmsIdent + ident LmsIdent -- must be unique accross all LMS courses! pin Text resetPin Bool default=false -- should pin be reset? success Bool Maybe -- open, success or failure; isJust indicates user will be deleted from LMS -- success LmsStatus -- this would also encode Day information?! + --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete started UTCTime default=now() received UTCTime Maybe -- last acknowledgement by LMS ended UTCTime Maybe -- ident was deleted from LMS diff --git a/routes b/routes index 10ec10cc2..b340da62e 100644 --- a/routes +++ b/routes @@ -256,7 +256,7 @@ -- OSIS CSV Export Demo /lms/#SchoolId/#QualificationShorthand LmsR GET POST ---/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST +/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST \ No newline at end of file diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 6b7ab4575..f9b973078 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -134,6 +134,7 @@ 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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index bb4c35326..263d97cfc 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -1,3 +1,4 @@ +{-# 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-redundant-constraints #-} -- TODO: remove me, for debugging only @@ -5,6 +6,7 @@ module Handler.LMS ( getLmsR , postLmsR + , getLmsUsersR , postLmsUsersR , getLmsUserlistR, postLmsUserlistR , getLmsResultR , postLmsResultR ) @@ -13,6 +15,7 @@ module Handler.LMS import Import import Handler.Utils +import Handler.Utils.Csv import Handler.Utils.LMS import qualified Data.Map as Map @@ -22,11 +25,11 @@ import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH -import Handler.LMS.Result as Handler.LMS +import Handler.LMS.Users as Handler.LMS import Handler.LMS.Userlist as Handler.LMS +import Handler.LMS.Result as Handler.LMS - - +{- data LmsUserTableCsv = LmsUserTableCsv -- for csv export only { csvLmsUserIdent :: LmsIdent , csvLmsUserPin :: Text @@ -60,7 +63,7 @@ getLmsR = postLmsR postLmsR sid qsh = do _qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh -- TODO !!! filter table by qid !!! - {- + dbtCsvName <- csvLmsUserFilename let dbtIdent = "lmsUsers" :: Text dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } @@ -116,10 +119,222 @@ postLmsR sid qsh = do -- } psValidator = def lmsTable = dbTable psValidator DBTable{..} - -} + let lmsTable = [whamlet|TODO|] -- TODO: remove me, just for debugging siteLayoutMsg MsgMenuLms $ do setTitleI MsgMenuLms $(widgetFile "lms") +-} + +--- old above, new below + +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 [ csvLmsIdent, csvLmsSuccess ] + +instance ToNamedRecord LmsResultTableCsv where + toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord + [ csvLmsIdent Csv..= csvLRTident + , csvLmsSuccess Csv..= csvLRTsuccess + ] + +instance FromNamedRecord LmsResultTableCsv where + parseNamedRecord (lsfHeaderTranslate -> csv) + = LmsResultTableCsv + <$> csv Csv..: csvLmsIdent + <*> csv Csv..: csvLmsSuccess + +instance CsvColumnsExplained LmsResultTableCsv where + csvColumnsExplanations _ = mconcat + [ single csvLmsIdent MsgCsvColumnLmsIdent + , single csvLmsSuccess 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 + +mkLmsTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) +mkLmsTable 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 csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident + , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success + ] -- TODO: add more columns for manual debugging view !!! + dbtSorting = Map.fromList + [ (csvLmsIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) + -- , (csvLmsSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) + , (csvLmsSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + ] + dbtFilter = Map.fromList + [ (csvLmsIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) + , (csvLmsSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + ] + dbtFilterUI = \mPrev -> mconcat + [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , prismAForm (singletonFilter csvLmsSuccess . 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 csvLmsIdent] + dbTable resultDBTableValidator resultDBTable + +getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsR = postLmsR +postLmsR sid qsh = do + lmsTable <- runDB $ do + qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + view _2 <$> mkLmsTable sid qsh qid + siteLayoutMsg MsgMenuLmsResult $ do + setTitleI MsgMenuLmsResult + $(widgetFile "lms") diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 4d99eae29..66c3a7588 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -27,29 +27,29 @@ data LmsResultTableCsv = LmsResultTableCsv makeLenses_ ''LmsResultTableCsv -- csv without headers -- TODO not yet supported -instance Csv.ToRecord LmsResultTableCsv -- default suffices -instance Csv.FromRecord LmsResultTableCsv -- default suffices +--instance Csv.ToRecord LmsResultTableCsv -- default suffices +--instance Csv.FromRecord LmsResultTableCsv -- default suffices -- csv with headers lmsResultTableCsvHeader :: Csv.Header -lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ] +lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ] instance ToNamedRecord LmsResultTableCsv where toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord - [ csvResultIdent Csv..= csvLRTident - , csvResultSuccess Csv..= csvLRTsuccess + [ csvLmsIdent Csv..= csvLRTident + , csvLmsSuccess Csv..= csvLRTsuccess ] instance FromNamedRecord LmsResultTableCsv where parseNamedRecord (lsfHeaderTranslate -> csv) = LmsResultTableCsv - <$> csv Csv..: csvResultIdent - <*> csv Csv..: csvResultSuccess + <$> csv Csv..: csvLmsIdent + <*> csv Csv..: csvLmsSuccess instance CsvColumnsExplained LmsResultTableCsv where csvColumnsExplanations _ = mconcat - [ single csvResultIdent MsgCsvColumnLmsIdent - , single csvResultSuccess MsgCsvColumnLmsSuccess + [ single csvLmsIdent MsgCsvColumnLmsIdent + , single csvLmsSuccess MsgCsvColumnLmsSuccess ] where single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget @@ -91,22 +91,22 @@ mkResultTable sid qsh qid = do dbtRowKey = (E.^. LmsResultId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtColonnade = dbColonnade $ mconcat - [ 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 + [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident + , sortable (Just csvLmsSuccess) (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 (E.^. LmsResultIdent)) - , (csvResultSuccess, SortColumn (E.^. LmsResultSuccess)) - , (csvLmsTimestamp , SortColumn (E.^. LmsResultTimestamp)) + [ (csvLmsIdent , SortColumn (E.^. LmsResultIdent)) + , (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess)) + , (csvLmsTimestamp, SortColumn (E.^. LmsResultTimestamp)) ] dbtFilter = Map.fromList - [ (csvResultIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent)) - , (csvResultSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess)) + [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent)) + , (csvLmsSuccess, 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 dayField) (fslI MsgTableLmsSuccess) + [ 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 dbtParams = def @@ -183,7 +183,7 @@ mkResultTable sid qsh qid = do dbtExtraReps = [] resultDBTableValidator = def - & defaultSorting [SortAscBy csvResultIdent] + & defaultSorting [SortAscBy csvLmsIdent] dbTable resultDBTableValidator resultDBTable getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html diff --git a/src/Handler/LMS/User.hs b/src/Handler/LMS/User.hs deleted file mode 100644 index 184ac64c2..000000000 --- a/src/Handler/LMS/User.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# 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 1970812f7..858559d14 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -1,6 +1,4 @@ {-# 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 module Handler.LMS.Userlist ( getLmsUserlistR, postLmsUserlistR @@ -28,28 +26,28 @@ data LmsUserlistTableCsv = LmsUserlistTableCsv makeLenses_ ''LmsUserlistTableCsv -- csv without headers -- TODO not yet supported -instance Csv.ToRecord LmsUserlistTableCsv -instance Csv.FromRecord LmsUserlistTableCsv +--instance Csv.ToRecord LmsUserlistTableCsv +--instance Csv.FromRecord LmsUserlistTableCsv -- csv with headers lmsUserlistTableCsvHeader :: Csv.Header -lmsUserlistTableCsvHeader = Csv.header [ csvUserlistIdent, csvUserlistBlocked ] +lmsUserlistTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsBlocked ] instance ToNamedRecord LmsUserlistTableCsv where toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord - [ csvUserlistIdent Csv..= csvLULident - , csvUserlistBlocked Csv..= csvLULfailed + [ csvLmsIdent Csv..= csvLULident + , csvLmsBlocked Csv..= csvLULfailed ] instance FromNamedRecord LmsUserlistTableCsv where parseNamedRecord (lsfHeaderTranslate -> csv) = LmsUserlistTableCsv - <$> csv Csv..: csvUserlistIdent - <*> csv Csv..: csvUserlistBlocked + <$> csv Csv..: csvLmsIdent + <*> csv Csv..: csvLmsBlocked instance CsvColumnsExplained LmsUserlistTableCsv where csvColumnsExplanations _ = mconcat - [ single csvUserlistIdent MsgCsvColumnLmsIdent - , single csvUserlistBlocked MsgCsvColumnLmsFailed + [ single csvLmsIdent MsgCsvColumnLmsIdent + , single csvLmsBlocked MsgCsvColumnLmsFailed ] where single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget @@ -91,22 +89,22 @@ mkUserlistTable sid qsh qid = do dbtRowKey = (E.^. LmsUserlistId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? 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 csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp + [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent + , sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked + , 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) - , (csvLmsTimestamp , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp) + [ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent) + , (csvLmsBlocked , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed) + , (csvLmsTimestamp, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp) ] dbtFilter = Map.fromList - [ (csvUserlistIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) - , (csvUserlistBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed)) + [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) + , (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed)) ] dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvUserlistIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter csvUserlistBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed) + [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed) ] dbtStyle = def dbtParams = def @@ -186,7 +184,7 @@ mkUserlistTable sid qsh qid = do dbtExtraReps = [] userlistDBTableValidator = def - & defaultSorting [SortAscBy csvUserlistIdent] + & defaultSorting [SortAscBy csvLmsIdent] dbTable userlistDBTableValidator userlistTable diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs new file mode 100644 index 000000000..6f541f030 --- /dev/null +++ b/src/Handler/LMS/Users.hs @@ -0,0 +1,136 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances +{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only + +module Handler.LMS.Users + ( getLmsUsersR, postLmsUsersR + ) + 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 + +data LmsUserTableCsv = LmsUserTableCsv -- for csv export only + { csvLUTident :: LmsIdent + , csvLUTpin :: Text + , csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool + } + deriving Generic +makeLenses_ ''LmsUserTableCsv + + +-- csv without headers -- TODO not yet supported +-- 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 + dbtCsvName <- csvFilenameLmsUser qsh + let dbtCsvSheetName = dbtCsvName + let + userDBTable = DBTable{..} + where + dbtSQLQuery lmsuser = do + E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid + return lmsuser + dbtRowKey = (E.^. LmsUserId) + dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident + , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin) $ \(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 -> del ) -> ifIconCell del IconRemoveUser + , sortable (Just csvLmsStaff) (i18nCell MsgTableLmsStaff) $ const mempty + ] + dbtSorting = Map.fromList + [ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserIdent) + , (csvLmsResetPin , SortColumn $ \lmslist -> lmslist E.^. LmsUserResetPin) + ] + dbtFilter = Map.fromList + [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent )) + , (csvLmsResetPin , FilterColumn $ E.mkExactFilter (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 checkBoxField) (fslI MsgTableLmsResetPin) + ] + dbtStyle = def + 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 . _lmsBool) + -- <*> const $ LmsBool False + <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool) + + dbtCsvDecode = Nothing + dbtExtraReps = [] + + userDBTableValidator = def + & defaultSorting [SortAscBy csvLmsIdent] + dbTable userDBTableValidator userDBTable + +getLmsUsersR, postLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsUsersR = postLmsUsersR +postLmsUsersR sid qsh = do + lmsTable <- runDB $ do + qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + view _2 <$> mkUserTable sid qsh qid + siteLayoutMsg MsgMenuLmsUsers $ do + setTitleI MsgMenuLmsUsers + $(widgetFile "lms-user") diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 267db1f5d..1c9775888 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -1,10 +1,18 @@ +{-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter + module Handler.Utils.LMS - ( csvLmsTimestamp - , csvUserlistIdent, csvUserlistBlocked - , csvResultIdent, csvResultSuccess + ( csvLmsIdent + , csvLmsTimestamp + , csvLmsBlocked + , csvLmsSuccess + , csvLmsPin + , csvLmsResetPin + , csvLmsDelete + , csvLmsStaff , csvFilenameLmsUser , csvFilenameLmsUserlist - , csvFilenameLmsResult + , csvFilenameLmsResult + , lmsUserToDelete, _lmsUserToDelete ) where -- general utils for LMS Interface Handlers @@ -12,19 +20,33 @@ module Handler.Utils.LMS import Import import Handler.Utils --- Column names +-- generic Column names +csvLmsIdent :: IsString a => a +csvLmsIdent = fromString "user" -- "Benutzerkennung" + csvLmsTimestamp :: IsString a => a -csvLmsTimestamp = fromString "Zeitstempel" +csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel" -csvUserlistIdent :: IsString a => a -csvUserlistIdent = fromString "Benutzerkennung" -csvUserlistBlocked :: IsString a => a -csvUserlistBlocked = fromString "Sperrung" +-- for User Table +csvLmsPin :: IsString a => a +csvLmsPin = fromString "pin" -- "PIN" -csvResultIdent :: IsString a => a -csvResultIdent = fromString "Benutzerkennung" -csvResultSuccess :: IsString a => a -csvResultSuccess = fromString "Datum" +csvLmsResetPin :: IsString a => a +csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen" + +csvLmsDelete :: IsString a => a +csvLmsDelete = fromString "delete" -- "Account löschen" + +csvLmsStaff :: IsString a => a +csvLmsStaff = fromString "staff" -- "Mitarbeiter" + +-- for Userlist Table +csvLmsBlocked :: IsString a => a +csvLmsBlocked = fromString "blocked" -- "Sperrung" + +-- for Result Table +csvLmsSuccess :: IsString a => a +csvLmsSuccess = fromString "success" -- "Datum" -- | Filename for User transmission, contains current datestamp as agreed in LMS interface @@ -47,4 +69,11 @@ makeLmsFilename ftag (citext2lower -> qsh) = do -- | Return current datetime in YYYYMMDDHH format getYMTH :: MonadHandler m => m Text -getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime \ No newline at end of file +getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime + +-- | Deceide whether LMS platform should delete an identifier +lmsUserToDelete :: LmsUser -> Bool +lmsUserToDelete LmsUser{lmsUserEnded, lmsUserSuccess} = isNothing lmsUserEnded && isJust lmsUserSuccess + +_lmsUserToDelete :: Getter LmsUser Bool +_lmsUserToDelete = to lmsUserToDelete \ No newline at end of file diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 3f99e4b99..e6f08695a 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -80,6 +80,10 @@ guardAuthCell mkParams = over cellContents $ \act -> do iconCell :: IsDBTable m a => Icon -> DBCell m a iconCell = cell . toWidget . icon +ifIconCell :: IsDBTable m a => Bool -> Icon -> DBCell m a +ifIconCell True = iconCell +ifIconCell False = const iconSpacerCell + addIconFixedWidth :: IsDBTable m a => DBCell m a -> DBCell m a addIconFixedWidth = addCellClass ("icon-fixed-width" :: Text) diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index d220f9f7f..b03b15874 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -100,6 +100,9 @@ data Icon | IconSubmissionUserDuplicate | IconNoAllocationUser | IconSubmissionNoUsers + | IconRemoveUser + | IconReset + | IconBlocked deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) deriving anyclass (Universe, Finite, NFData) @@ -143,6 +146,7 @@ iconText = \case IconApplyTrue -> "file-alt" IconApplyFalse -> "trash" IconNoCorrectors -> "user-slash" + IconRemoveUser -> "user-slash" IconApplicationVeto -> "times" IconApplicationFiles -> "file-alt" IconTooltipDefault -> "question-circle" @@ -183,6 +187,8 @@ iconText = \case IconSubmissionUserDuplicate -> "copy" IconNoAllocationUser -> "user-slash" IconSubmissionNoUsers -> "user-slash" + IconReset -> "undo" -- From fontawesome v6 onwards: "arrow-rotate-left" + IconBlocked -> "ban" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/templates/lms-user.hamlet b/templates/lms-user.hamlet new file mode 100644 index 000000000..5d7ab85f6 --- /dev/null +++ b/templates/lms-user.hamlet @@ -0,0 +1,2 @@ +LMS User +^{lmsTable} diff --git a/templates/lms.hamlet b/templates/lms.hamlet index 79aa7175b..b04cf5204 100644 --- a/templates/lms.hamlet +++ b/templates/lms.hamlet @@ -1,5 +1,10 @@ LMS Overview +