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 +