From e5216fde31ba23d90fa01a8bd63735875fa5abbd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 21 Feb 2022 17:02:53 +0100 Subject: [PATCH] chore(lms): import ought to work now --- models/lms.model | 2 +- routes | 7 +++-- src/Handler/Exam/Users.hs | 2 +- src/Handler/LMS.hs | 54 ++++++++++++++------------------- src/Handler/LMS/Result.hs | 64 +++++++++++++++++++++++++-------------- test/Database/Fill.hs | 3 +- 6 files changed, 72 insertions(+), 60 deletions(-) diff --git a/models/lms.model b/models/lms.model index cc51f2d18..47ec44cdf 100644 --- a/models/lms.model +++ b/models/lms.model @@ -115,7 +115,7 @@ LmsResult ident LmsIdent success Day timestamp UTCTime default=now() - UniqueLmsResult qualification ident success + UniqueLmsResult qualification ident success -- required by DBTable deriving Generic -- Logs all processed rows from LmsUserlist and LmsResult diff --git a/routes b/routes index d616ef341..0cf1d4c3b 100644 --- a/routes +++ b/routes @@ -255,6 +255,7 @@ !/*WellKnownFileName WellKnownR GET !free -- OSIS CSV Export Demo -/lms/#SchoolId/#QualificationShorthand LmsR GET -/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET -/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET +/lms/#SchoolId/#QualificationShorthand LmsR 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/Exam/Users.hs b/src/Handler/Exam/Users.hs index 5d20a3587..6c5fe13bd 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -600,7 +600,7 @@ postEUsersR tid ssh csh examn = do , dbtCsvName, dbtCsvSheetName , dbtCsvNoExportData = Just id , dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber - , dbtCsvExampleData = Nothing + , dbtCsvExampleData = Nothing } where doEncode' = ExamUserTableCsv diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index b18a9847a..354a21100 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -4,9 +4,9 @@ module Handler.LMS - ( getLmsR - , getLmsUserlistR - , getLmsResultR + ( getLmsR , postLmsR + , getLmsUserlistR, postLmsUserlistR + , getLmsResultR , postLmsResultR ) where @@ -28,7 +28,7 @@ type LmsUserIdent = Text -- Unique random use-once identifier for each individua data LmsUserTableCsv = LmsUserTableCsv -- for csv export only { csvLmsUserIdent :: LmsUserIdent - , csvLmsUserPin :: Text + , csvLmsUserPin :: Text , csvLmsUserReset, cvsLmsUserRemove, cvsLmsUserIntern :: Int } @@ -62,20 +62,12 @@ csvLmsUserlistFilename = makeLmsFilename "userliste" csvLmsResultFilename :: MonadHandler m => m Text csvLmsResultFilename = makeLmsFilename "ergebnisse" --- | Create filenames as specified by the LMS interface agreed with Know How AG -makeLmsFilename :: MonadHandler m => Text -> m Text -makeLmsFilename ftag = do - ymth <- getYMTH - return $ "fradrive_f_" <> ftag <> "_" <> ymth <> ".csv" - --- | Return current datetime in YYYYMMDDHH format -getYMTH :: MonadHandler m => m Text -getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime -getLmsR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsR sid qsh = do - _qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh +getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html +getLmsR = postLmsR +postLmsR sid qsh = do + _qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh -- TODO !!! filter table by qid !!! {- dbtCsvName <- csvLmsUserFilename @@ -114,7 +106,7 @@ getLmsR sid qsh = do (row ^. resultUser . _entityVal . _lmsUserResetPin . to fromEnum) (row ^. resultUser . _entityVal . _lmsUserDelete . to fromEnum) mitarbeiter - , dbtCsvName + , dbtCsvName , dbtCsvNoExportData = Nothing , dbtCsvHeader = def -- return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def , dbtCsvExampleData = Nothing @@ -130,10 +122,10 @@ getLmsR sid qsh = do -- , dbtCsvRenderKey = _7 -- , dbtCsvRenderActionClass = _8 -- , dbtCsvRenderException = _9 - -- } + -- } psValidator = def lmsTable = dbTable psValidator DBTable{..} - -} + -} let lmsTable = [whamlet|TODO|] -- TODO: remove me, just for debugging siteLayoutMsg MsgMenuLms $ do setTitleI MsgMenuLms @@ -144,15 +136,15 @@ getLmsR sid qsh = do mkUserlistTable :: QualificationId -> DB (Any, Widget) mkUserlistTable qid = do - let + let userlistTable = DBTable{..} where - dbtSQLQuery lmslist = do + 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 + 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 ] @@ -160,7 +152,7 @@ mkUserlistTable qid = do [ ("ident" , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent) , ("failed", SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed) ] - dbtFilter = mempty -- TODO !!! continue here !!! + dbtFilter = mempty -- TODO !!! continue here !!! dbtFilterUI = const mempty -- TODO !!! continue here !!! Manual filtering useful to deal with user complaints! dbtStyle = def dbtParams = def @@ -169,23 +161,23 @@ mkUserlistTable qid = do 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 + + userlistDBTableValidator = def & defaultSorting [SortAscBy "ident"] - + dbTable userlistDBTableValidator userlistTable -getLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistR sid qsh = do +getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsUserlistR = postLmsUserlistR +postLmsUserlistR sid qsh = do lmsTable <- runDB $ do qid <- getKeyBy404 $ UniqueSchoolShort sid qsh - view _2 <$> mkUserlistTable qid + view _2 <$> mkUserlistTable qid siteLayoutMsg MsgMenuLmsUserlist $ do setTitleI MsgMenuLmsUserlist $(widgetFile "lms-userlist") --- See Module Handler.LMS.Result for +-- See Module Handler.LMS.Result for -- getLmsResultR :: QualificationId -> Handler Html - \ No newline at end of file diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 75b95d252..2d0ebebc4 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -5,7 +5,8 @@ module Handler.LMS.Result - ( getLmsResultR + ( makeLmsFilename + , getLmsResultR, postLmsResultR ) where @@ -25,6 +26,15 @@ import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH +-- | Create filenames as specified by the LMS interface agreed with Know How AG +makeLmsFilename :: MonadHandler m => Text -> m Text +makeLmsFilename ftag = do + ymth <- getYMTH + return $ "fradrive_f_" <> 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) @@ -74,12 +84,6 @@ data LmsResultTableCsv = LmsResultTableCsv deriving Generic makeLenses_ ''LmsResultTableCsv -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece'' 2 1 -- TODO: purpose of dropping here is? - , fieldLabelModifier = camelToPathPiece' 2 - } ''LmsResultTableCsv - - -- csv without headers instance Csv.ToRecord LmsResultTableCsv -- default suffices instance Csv.FromRecord LmsResultTableCsv -- default suffices @@ -114,13 +118,13 @@ data LmsResultCsvActionClass = LmsResultInsert deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded) embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id --- TODO: why can't we use LmsResultTableCsv here instead? +-- 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 - , fieldLabelModifier = camelToPathPiece' 2 + { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert + , fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success , sumEncoding = TaggedObject "action" "data" } ''LmsResultCsvAction @@ -173,23 +177,31 @@ mkResultTable sid qsh qid = do dbtParams = def dbtIdent :: Text dbtIdent = "lms-userlist" - dbtCsvEncode = Nothing - dbtCsvDecode = Just $ DBTCsvDecode -- Just save to DB; Job will process data later + dbtCsvEncode = Nothing + {- + dbtCsvEncode = Just DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + , dbtCsvName = makeLmsFilename "ergebnisse" + , dbtCsvSheetName = makeLmsFilename "ergebnisse" + , dbtCsvNoExportData = Just id + , dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber + , dbtCsvExampleData = Nothing + -} + + dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later { dbtCsvRowKey = \LmsResultTableCsv{..} -> - fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess + 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 - --let LmsResultTableCsv{..} = dbCsvNew - --let csvLRTident = error "TODO" - -- csvLRTsuccess = error "TODO" yield $ LmsResultInsertData { lmsResultInsertIdent = csvLRTident dbCsvNew , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew } - DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _ } -> error "UniqueLmsResult was found, but Key no longer exists." + DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." DBCsvDiffMissing{} -> return () -- no deletion - DBCsvDiffExisting{} -> return () -- no merge - , dbtCsvClassifyAction = \LmsResultInsertData{} -> LmsResultInsert + DBCsvDiffExisting{} -> return () -- no merge + , 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 @@ -205,10 +217,15 @@ mkResultTable sid qsh qid = do [ LmsResultSuccess =. lmsResultInsertSuccess , LmsResultTimestamp =. now ] - -- queueDBJob + -- queueDBJob?? -- todo -- audit return $ LmsResultR sid qsh - , dbtCsvRenderKey = error "TODO" -- what is the purpose? + , dbtCsvRenderKey = \_ LmsResultInsertData{..} -> do + [whamlet| + $newline never + Ident #{getLmsIdent lmsResultInsertIdent} # + had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} + |] , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text } @@ -218,8 +235,9 @@ mkResultTable sid qsh qid = do & defaultSorting [SortAscBy "ident"] dbTable resultDBTableValidator resultDBTable -getLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsResultR sid qsh = do +getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsResultR = postLmsResultR +postLmsResultR sid qsh = do lmsTable <- runDB $ do qid <- getKeyBy404 $ UniqueSchoolShort sid qsh view _2 <$> mkResultTable sid qsh qid diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 49b100a44..0dd6d0685 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -457,7 +457,8 @@ fillDb = do for_ [jost] $ \uid -> void . insert' $ UserSchool uid avn False - -- void . insert' + _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 let sdBsc = StudyDegreeKey' 82 sdMst = StudyDegreeKey' 88