diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index a5796ccca..a8a5c4455 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -1,7 +1,9 @@ TableLmsIdent: Identifikation TableLmsFailed: Gesperrt TableLmsSuccess: Bestanden -CsvColumnLmsResultIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer -CsvColumnLmsResultSuccess: Zeitstempel der erfolgreichen Teilnahme +TableLmsReceived: Erhalten +CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer +CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme +CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts LmsResultInsert: Neues LMS Ergebnis LmsResultCsvExceptionDuplicatedKey: 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 13dbe9ea4..d45739846 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -1,7 +1,9 @@ TableLmsIdent: Identifier TableLmsFailed: Blocked TableLmsSuccess: Completed -CsvColumnLmsResultIdent: E-Learing identifier, unique for each qualfication and user -CsvColumnLmsResultSuccess: Timestamp of successful completion +TableLmsReceived: Received +CsvColumnLmsIdent: E-Learing identifier, unique for each qualfication and user +CsvColumnLmsSuccess: Timestamp of successful completion +CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche LmsResultInsert: New LMS result LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key \ No newline at end of file diff --git a/routes b/routes index 0cf1d4c3b..10ec10cc2 100644 --- a/routes +++ b/routes @@ -256,6 +256,7 @@ -- OSIS CSV Export Demo /lms/#SchoolId/#QualificationShorthand LmsR 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/Handler/LMS.hs b/src/Handler/LMS.hs index b2138e4ba..bb4c35326 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -13,6 +13,7 @@ module Handler.LMS import Import import Handler.Utils +import Handler.Utils.LMS import qualified Data.Map as Map import qualified Data.Csv as Csv @@ -21,13 +22,13 @@ 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.Result as Handler.LMS +import Handler.LMS.Userlist as Handler.LMS -type LmsUserIdent = Text -- Unique random use-once identifier for each individual e-learning course; i.e. users may have several active LmsUserIdents at once! data LmsUserTableCsv = LmsUserTableCsv -- for csv export only - { csvLmsUserIdent :: LmsUserIdent + { csvLmsUserIdent :: LmsIdent , csvLmsUserPin :: Text , csvLmsUserReset, cvsLmsUserRemove, cvsLmsUserIntern :: Int } @@ -122,52 +123,3 @@ postLmsR sid qsh = do $(widgetFile "lms") - - -mkUserlistTable :: QualificationId -> DB (Any, Widget) -mkUserlistTable qid = do - let - userlistTable = DBTable{..} - where - dbtSQLQuery lmslist = do - E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid - return lmslist - dbtRowKey = (E.^. LmsUserlistId) - dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ getLmsIdent lmsUserlistIdent - , sortable (Just "failed") (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell lmsUserlistFailed - ] - dbtSorting = Map.fromList - [ ("ident" , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent) - , ("failed", SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed) - ] - dbtFilter = mempty -- TODO !!! continue here !!! - dbtFilterUI = const mempty -- TODO !!! continue here !!! Manual filtering useful to deal with user complaints! - dbtStyle = def - dbtParams = def - dbtIdent :: Text - dbtIdent = "lms-userlist" - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing -- TODO !!! continue here !!! CSV Import is the purpose of this page! Just save to DB, create Job to deal with it later! - dbtExtraReps = [] - - userlistDBTableValidator = def - & defaultSorting [SortAscBy "ident"] - - dbTable userlistDBTableValidator userlistTable - - -getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistR = postLmsUserlistR -postLmsUserlistR sid qsh = do - lmsTable <- runDB $ do - qid <- getKeyBy404 $ UniqueSchoolShort sid qsh - view _2 <$> mkUserlistTable qid - siteLayoutMsg MsgMenuLmsUserlist $ do - setTitleI MsgMenuLmsUserlist - $(widgetFile "lms-userlist") - - --- See Module Handler.LMS.Result for --- getLmsResultR :: QualificationId -> Handler Html diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 12c9949f3..5aca0ab12 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -1,12 +1,8 @@ {-# 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 - module Handler.LMS.Result - ( makeLmsFilename - , getLmsResultR, postLmsResultR + ( getLmsResultR, postLmsResultR ) where @@ -14,36 +10,15 @@ 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 Data.CaseInsensitive as CI -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lens as Text import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH -csvLmsUserFilename :: MonadHandler m => QualificationShorthand -> m Text -csvLmsUserFilename = makeLmsFilename "user" - -csvLmsUserlistFilename :: MonadHandler m => QualificationShorthand -> m Text -csvLmsUserlistFilename = makeLmsFilename "userliste" - -csvLmsResultFilename :: MonadHandler m => QualificationShorthand -> m Text -csvLmsResultFilename = makeLmsFilename "ergebnisse" - --- | Create filenames as specified by the LMS interface agreed with Know How AG -makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand -> m Text -makeLmsFilename ftag (citext2lower -> qsh) = do - ymth <- getYMTH - return $ "fradrive_" <> qsh <> "_" <> ftag <> "_" <> ymth <> ".csv" - --- | Return current datetime in YYYYMMDDHH format -getYMTH :: MonadHandler m => m Text -getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification) @@ -99,25 +74,25 @@ instance Csv.FromRecord LmsResultTableCsv -- default suffices -- csv with headers lmsResultTableCsvHeader :: Csv.Header -lmsResultTableCsvHeader = Csv.header [ "identification", "day-success" ] +lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ] instance ToNamedRecord LmsResultTableCsv where toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord - [ "identification" Csv..= csvLRTident - , "day-success" Csv..= csvLRTsuccess + [ csvResultIdent Csv..= csvLRTident + , csvResultSuccess Csv..= csvLRTsuccess ] instance FromNamedRecord LmsResultTableCsv where parseNamedRecord (lsfHeaderTranslate -> csv) = LmsResultTableCsv - <$> csv Csv..: "identification" - <*> csv Csv..: "day-success" + <$> csv Csv..: csvResultIdent + <*> csv Csv..: csvResultSuccess instance CsvColumnsExplained LmsResultTableCsv where csvColumnsExplanations _ = mconcat - [ single "identification" MsgCsvColumnLmsResultIdent - , single "timestamp-success" MsgCsvColumnLmsResultSuccess + [ single csvResultIdent MsgCsvColumnLmsIdent + , single csvResultSuccess MsgCsvColumnLmsSuccess ] where single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget @@ -148,7 +123,7 @@ embedRenderMessage ''UniWorX ''LmsResultCsvException id mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkResultTable sid qsh qid = do - dbtCsvName <- csvLmsResultFilename qsh + dbtCsvName <- csvFilenameLmsResult qsh let dbtCsvSheetName = dbtCsvName let resultDBTable = DBTable{..} @@ -168,26 +143,26 @@ mkResultTable sid qsh qid = do dbtRowKey = queryLmsResult >>> (E.^. LmsResultId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident - , sortable (Just "sucess") (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success + [ 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 - [ ("ident" , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) - -- , ("success", SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) - , ("success", SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + [ (csvResultIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) + -- , (csvResultSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) + , (csvResultSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] dbtFilter = Map.fromList - [ ("ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) - , ("success" , FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + [ (csvResultIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) + , (csvResultSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter "success" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsIdent) + [ 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-userlist" + dbtIdent = "lms-result" dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs new file mode 100644 index 000000000..9a621479f --- /dev/null +++ b/src/Handler/LMS/Userlist.hs @@ -0,0 +1,77 @@ +{-# 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 + ) + where + +import Import + +import Handler.Utils +import Handler.Utils.Csv +import Handler.Utils.LMS + +import qualified Data.Map as Map +import qualified Data.Csv as Csv +import qualified Data.Conduit.List as C +import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils.TH + + + +mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) +mkUserlistTable _sid qsh qid = do + dbtCsvName <- csvFilenameLmsUserlist qsh + let _dbtCsvSheetName = dbtCsvName + let + userlistTable = DBTable{..} + where + dbtSQLQuery lmslist = do + E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid + return lmslist + 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 "timestamp") (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) + ] + dbtFilter = Map.fromList + [ (csvUserlistIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) + , (csvUserlistBlocked, 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) + ] + dbtStyle = def + dbtParams = def + dbtIdent :: Text + dbtIdent = "lms-userlist" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing -- TODO !!! continue here !!! CSV Import is the purpose of this page! Just save to DB, create Job to deal with it later! + dbtExtraReps = [] + + userlistDBTableValidator = def + & defaultSorting [SortAscBy "ident"] + + dbTable userlistDBTableValidator userlistTable + + +getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsUserlistR = postLmsUserlistR +postLmsUserlistR sid qsh = do + lmsTable <- runDB $ do + qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + view _2 <$> mkUserlistTable sid qsh qid + siteLayoutMsg MsgMenuLmsUserlist $ do + setTitleI MsgMenuLmsUserlist + $(widgetFile "lms-userlist") diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs new file mode 100644 index 000000000..b06d930fd --- /dev/null +++ b/src/Handler/Utils/LMS.hs @@ -0,0 +1,46 @@ +module Handler.Utils.LMS + ( csvUserlistIdent, csvUserlistBlocked + , csvResultIdent, csvResultSuccess + , csvFilenameLmsUser + , csvFilenameLmsUserlist + , csvFilenameLmsResult + ) where + +-- general utils for LMS Interface Handlers + +import Import +import Handler.Utils + +-- Column names +csvUserlistIdent :: IsString a => a +csvUserlistIdent = fromString "Benutzerkennung" +csvUserlistBlocked :: IsString a => a +csvUserlistBlocked = fromString "Sperrung" + +csvResultIdent :: IsString a => a +csvResultIdent = fromString "Benutzerkennung" +csvResultSuccess :: IsString a => a +csvResultSuccess = fromString "Datum" + + +-- | Filename for User transmission, contains current datestamp as agreed in LMS interface +csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text +csvFilenameLmsUser = makeLmsFilename "user" + +-- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface +csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text +csvFilenameLmsUserlist = makeLmsFilename "userliste" + +-- | Filename for Result transmission, contains current datestamp as agreed in LMS interface +csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text +csvFilenameLmsResult = makeLmsFilename "ergebnisse" + +-- | Create filenames as specified by the LMS interface agreed with Know How AG +makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand -> m Text +makeLmsFilename ftag (citext2lower -> qsh) = do + ymth <- getYMTH + return $ "fradrive_" <> qsh <> "_" <> ftag <> "_" <> ymth <> ".csv" + +-- | 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 diff --git a/src/Utils.hs b/src/Utils.hs index 4d3feeeeb..db515f22d 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -274,6 +274,9 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs stripAll :: Text -> Text stripAll = Text.filter (not . isSpace) +citext2lower :: CI Text -> Text +citext2lower = Text.toLower . CI.original + -- | Convert text as it is to Html, may prevent ambiguous types -- This function definition is mainly for documentation purposes text2Html :: Text -> Html @@ -295,9 +298,6 @@ text2widget t = [whamlet|#{t}|] citext2widget :: CI Text -> WidgetFor site () citext2widget t = [whamlet|#{CI.original t}|] -citext2lower :: CI Text -> Text -citext2lower = Text.toLower . CI.original - str2widget :: String -> WidgetFor site () str2widget s = [whamlet|#{s}|] diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 6174fe90e..5d8bf71c4 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -457,10 +457,10 @@ fillDb = do for_ [jost] $ \uid -> void . insert' $ UserSchool uid avn False - qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing True + _qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing True qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing False - void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (addBDays (-1) $ utctDay now) now - void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (addBDays (-2) $ utctDay now) now + void . insert' $ LmsResult qid_r (LmsIdent "hijklmn") (addBDays (-1) $ utctDay now) now + void . insert' $ LmsResult qid_r (LmsIdent "opqgrs" ) (addBDays (-2) $ utctDay now) now void . insert' $ LmsResult qid_r (LmsIdent "pqgrst" ) (addBDays (-3) $ utctDay now) now let sdBsc = StudyDegreeKey' 82