diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 354a21100..b2138e4ba 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -53,16 +53,6 @@ resultLmsUser = _dbrOutput . _1 resultUser :: Lens' LmsUserTableData (Maybe (Entity User)) resultUser = _dbrOutput . _2 -csvLmsUserFilename :: MonadHandler m => m Text -csvLmsUserFilename = makeLmsFilename "user" - -csvLmsUserlistFilename :: MonadHandler m => m Text -csvLmsUserlistFilename = makeLmsFilename "userliste" - -csvLmsResultFilename :: MonadHandler m => m Text -csvLmsResultFilename = makeLmsFilename "ergebnisse" - - getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 2d0ebebc4..12c9949f3 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -26,11 +26,20 @@ 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 -> m Text -makeLmsFilename ftag = do +makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand -> m Text +makeLmsFilename ftag (citext2lower -> qsh) = do ymth <- getYMTH - return $ "fradrive_f_" <> ftag <> "_" <> ymth <> ".csv" + return $ "fradrive_" <> qsh <> "_" <> ftag <> "_" <> ymth <> ".csv" -- | Return current datetime in YYYYMMDDHH format getYMTH :: MonadHandler m => m Text @@ -138,11 +147,13 @@ embedRenderMessage ''UniWorX ''LmsResultCsvException id mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkResultTable sid qsh qid = do - --now <- liftIO getCurrentTime +mkResultTable sid qsh qid = do + dbtCsvName <- csvLmsResultFilename qsh + let dbtCsvSheetName = dbtCsvName let resultDBTable = DBTable{..} where + dbtSQLQuery = runReaderT $ do qualification <- asks queryQualification lmsResult <- asks queryLmsResult @@ -176,18 +187,20 @@ mkResultTable sid qsh qid = do dbtStyle = def dbtParams = def dbtIdent :: Text - dbtIdent = "lms-userlist" - dbtCsvEncode = Nothing - {- + dbtIdent = "lms-userlist" dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) - , dbtCsvName = makeLmsFilename "ergebnisse" - , dbtCsvSheetName = makeLmsFilename "ergebnisse" + , dbtCsvName + , dbtCsvSheetName , dbtCsvNoExportData = Just id - , dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber + , 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{..} -> diff --git a/src/Utils.hs b/src/Utils.hs index 886c45a0d..4d3feeeeb 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -295,6 +295,9 @@ 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 0dd6d0685..6174fe90e 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -457,8 +457,11 @@ 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_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing False + 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 "pqgrst" ) (addBDays (-3) $ utctDay now) now let sdBsc = StudyDegreeKey' 82 sdMst = StudyDegreeKey' 88