From 6772290044d172a772cf67750200ef4a38642381 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 8 Mar 2022 11:17:35 +0100 Subject: [PATCH 01/14] chore(lms): add newtype for special day format (not yet used) --- src/Handler/LMS/Result.hs | 1 - src/Handler/LMS/Users.hs | 1 - src/Model/Types/Lms.hs | 50 +++++++++++++++++++-------------------- 3 files changed, 24 insertions(+), 28 deletions(-) diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 66c3a7588..46891f27f 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances -{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only module Handler.LMS.Result ( getLmsResultR, postLmsResultR diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 6f541f030..d98c9c369 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -1,5 +1,4 @@ {-# 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 diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 59790590c..d9a58a646 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -11,6 +11,7 @@ import Import.NoModel import Database.Persist.Sql import qualified Database.Esqueleto.Legacy as E import qualified Data.Csv as Csv +import qualified Data.Time.Format as Time import Utils.Lens.TH newtype LmsIdent = LmsIdent { getLmsIdent :: Text } @@ -38,32 +39,7 @@ deriveJSON defaultOptions 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 --} - +-- | LMS interface requires Bool to be encoded by 0 or 1 only newtype LmsBool = LmsBool { lms2bool :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -79,3 +55,25 @@ instance Csv.FromField LmsBool where | i == "0" = pure $ LmsBool False | i == "1" = pure $ LmsBool True | otherwise = empty + +-- | LMS interface requires day format not compliant with iso8601 +newtype LmsDay = LmsDay { lms2day :: Day } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +_lmsDay :: Iso' Day LmsDay +_lmsDay = iso LmsDay lms2day + +-- | Format for day for LMS interface +lmsDayFormat :: String +lmsDayFormat = "%d-%m-%Y" + +instance Csv.ToField LmsDay where + toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter; getTimeLocale requires MonadHandler + +instance Csv.FromField LmsDay where +-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField +-- where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat + parseField i = do + s <- Csv.parseField i + d <- Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s + return $ LmsDay d From 9e80a2e5e99c65880cfddab007be0275bfc42174 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 8 Mar 2022 16:16:16 +0100 Subject: [PATCH 02/14] chore(lms): activate filters, add examples --- .../categories/qualification/de-de-formal.msg | 2 +- .../uniworx/categories/qualification/en-eu.msg | 2 +- src/Handler/LMS.hs | 2 +- src/Handler/LMS/Result.hs | 8 ++++++-- src/Handler/LMS/Userlist.hs | 18 +++++++++--------- src/Handler/LMS/Users.hs | 2 +- 6 files changed, 19 insertions(+), 15 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 5ffa99c7e..bbf743671 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -11,7 +11,7 @@ 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 +CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC) CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts LmsUserlistInsert: Neuer LMS User LmsUserlistUpdate: LMS User aktualisierung diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 0eeca65f9..c618d7307 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -11,7 +11,7 @@ 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 +CsvColumnLmsSuccess: Timestamp of successful completion (UTC) CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche LmsUserlistInsert: New LMS User LmsUserlistUpdate: Update of LMS User diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 263d97cfc..5c6f9d169 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -265,7 +265,7 @@ mkLmsTable sid qsh qid = do [ 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 + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "lms-result" diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 46891f27f..9f7f55160 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -78,6 +78,7 @@ embedRenderMessage ''UniWorX ''LmsResultCsvException id mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkResultTable sid qsh qid = do + now_day <- utctDay <$> liftIO getCurrentTime dbtCsvName <- csvFilenameLmsResult qsh let dbtCsvSheetName = dbtCsvName let @@ -107,7 +108,7 @@ mkResultTable sid qsh qid = do [ 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 + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "lms-result" @@ -118,7 +119,10 @@ mkResultTable sid qsh qid = do , dbtCsvSheetName , dbtCsvNoExportData = Just id , dbtCsvHeader = const $ return lmsResultTableCsvHeader - , dbtCsvExampleData = Nothing + , dbtCsvExampleData = Just + [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = addDays (-dos) now_day } + | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] + ] } where doEncode' = LmsResultTableCsv diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 858559d14..849b33e26 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -30,8 +30,8 @@ makeLenses_ ''LmsUserlistTableCsv --instance Csv.FromRecord LmsUserlistTableCsv -- csv with headers -lmsUserlistTableCsvHeader :: Csv.Header -lmsUserlistTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsBlocked ] +instance DefaultOrdered LmsUserlistTableCsv where + headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ] instance ToNamedRecord LmsUserlistTableCsv where toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord @@ -106,17 +106,17 @@ mkUserlistTable sid qsh qid = do [ 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 + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "lms-userlist" - dbtCsvEncode = Just DBTCsvEncode {..} + dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample where - dbtCsvExportForm = pure () - dbtCsvNoExportData = Just id - dbtCsvExampleData = Nothing - dbtCsvHeader = const $ return lmsUserlistTableCsvHeader - dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + addExample dce = dce{ dbtCsvExampleData = csvExample } + csvExample = Just + [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl} + | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False] + ] doEncode' = LmsUserlistTableCsv <$> view (_dbrOutput . _entityVal . _lmsUserlistIdent) <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool) diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index d98c9c369..eb4be3cde 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -98,7 +98,7 @@ mkUserTable _sid qsh qid = do [ 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 + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "lms-user" From 5d795f845d937fb92ae6a9bf3ebdc02133de4013 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 10 Mar 2022 19:45:44 +0100 Subject: [PATCH 03/14] chore(docker): add some basic commandline tools to container --- nix/docker/default.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/nix/docker/default.nix b/nix/docker/default.nix index ec4960492..f03f950ea 100644 --- a/nix/docker/default.nix +++ b/nix/docker/default.nix @@ -27,6 +27,7 @@ let curl wget netcat # just for manual testing within the pod, remove for production! openldap # just for manual testing within the pod, remove for production! iana-etc + unixtools.netstat htop gnugrep ] ++ optionals isDemo [ postgresql_12 memcached uniworx.uniworx.components.exes.uniworxdb ]; runAsRoot = '' From eeb22dec9737e014c20b852438da4373219884b0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 10 Mar 2022 19:46:26 +0100 Subject: [PATCH 04/14] fix(uploadcache): set default to localhost --- config/settings.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config/settings.yml b/config/settings.yml index 6f4368343..255d8b9a7 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -165,7 +165,7 @@ memcached-local: maximum-weight: 104857600 # 100MiB upload-cache: - host: "_env:UPLOAD_S3_HOST:" + host: "_env:UPLOAD_S3_HOST:localhost" port: "_env:UPLOAD_S3_PORT:9000" access-key: "_env:UPLOAD_S3_KEY_ID:" secret-key: "_env:UPLOAD_S3_KEY" From f9fb236025a28dd090581fda70a30531d69dfb02 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 10 Mar 2022 19:47:45 +0100 Subject: [PATCH 05/14] chore(lms): minor changes --- src/Handler/Utils/Table/Pagination.hs | 2 ++ src/Model/Types/Lms.hs | 4 +++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 50e666ed0..cfb7b1231 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1066,6 +1066,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db <|> piInput psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit + lch <- lookupCustomHeader HeaderDBTableShortcircuit + $logErrorS "DBShortcircuit" $ fromMaybe mempty lch <> " and also " <> tshow psShortcircuit let -- adjustPI = over _piSorting $ guardOnM doSorting -- probably not neccessary; not displaying the links should be enough for now diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index d9a58a646..3a5ae6ea4 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -12,6 +12,7 @@ import Database.Persist.Sql import qualified Database.Esqueleto.Legacy as E import qualified Data.Csv as Csv import qualified Data.Time.Format as Time +import Data.Time.Format.ISO8601 (iso8601ParseM) import Utils.Lens.TH newtype LmsIdent = LmsIdent { getLmsIdent :: Text } @@ -54,7 +55,7 @@ instance Csv.FromField LmsBool where parseField i | i == "0" = pure $ LmsBool False | i == "1" = pure $ LmsBool True - | otherwise = empty + | otherwise = mempty -- | LMS interface requires day format not compliant with iso8601 newtype LmsDay = LmsDay { lms2day :: Day } @@ -76,4 +77,5 @@ instance Csv.FromField LmsDay where parseField i = do s <- Csv.parseField i d <- Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s + <|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future return $ LmsDay d From 4a1fc5ebb2de179e3e6c3d475a845dacf4b92ca7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 11 Mar 2022 11:47:19 +0100 Subject: [PATCH 06/14] chore(lms): switch result day format to LmsDay --- models/lms.model | 4 ++-- src/Handler/LMS.hs | 2 +- src/Handler/LMS/Result.hs | 14 +++++++------- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/models/lms.model b/models/lms.model index c04e02404..eb17703a8 100644 --- a/models/lms.model +++ b/models/lms.model @@ -99,7 +99,7 @@ LmsUser started UTCTime default=now() received UTCTime Maybe -- last acknowledgement by LMS ended UTCTime Maybe -- ident was deleted from LMS - UniqueLmsUser qualification ident + UniqueLmsUser ident -- idents must be unique accross all qualifications, since idents are global within LMS! deriving Generic -- LmsUserlist stores LMS upload for later processing only @@ -117,7 +117,7 @@ LmsResult ident LmsIdent success Day timestamp UTCTime default=now() - UniqueLmsResult qualification ident success -- required by DBTable + UniqueLmsResult qualification ident -- required by DBTable deriving Generic -- Logs all processed rows from LmsUserlist and LmsResult diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 5c6f9d169..c757d23fb 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -285,7 +285,7 @@ mkLmsTable sid qsh qid = do 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 , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do yield $ LmsResultInsertData diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 9f7f55160..d459d89a4 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -20,7 +20,7 @@ import qualified Database.Esqueleto.Utils as E data LmsResultTableCsv = LmsResultTableCsv { csvLRTident :: LmsIdent - , csvLRTsuccess :: Day + , csvLRTsuccess :: LmsDay } deriving Generic makeLenses_ ''LmsResultTableCsv @@ -65,7 +65,7 @@ data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert - , fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success + , fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success , sumEncoding = TaggedObject "action" "data" } ''LmsResultCsvAction @@ -120,28 +120,28 @@ mkResultTable sid qsh qid = do , dbtCsvNoExportData = Just id , dbtCsvHeader = const $ return lmsResultTableCsvHeader , dbtCsvExampleData = Just - [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = addDays (-dos) now_day } + [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] ] } where doEncode' = LmsResultTableCsv <$> view (_dbrOutput . _entityVal . _lmsResultIdent) - <*> view (_dbrOutput . _entityVal . _lmsResultSuccess) + <*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay) 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 , 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 + , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day } 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 + , lmsResultInsertSuccess = csvLRTsuccess & lms2day } DBCsvDiffMissing{} -> return () -- no deletion , dbtCsvClassifyAction = \case From 4f2834a77a2feb2c61b543175f75fe48cd262fd5 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 11 Mar 2022 13:29:13 +0100 Subject: [PATCH 07/14] chore(settings): return S3 upload cache back to not configured --- config/settings.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config/settings.yml b/config/settings.yml index 255d8b9a7..9a82fbf96 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -165,7 +165,7 @@ memcached-local: maximum-weight: 104857600 # 100MiB upload-cache: - host: "_env:UPLOAD_S3_HOST:localhost" + host: "_env:UPLOAD_S3_HOST:" # should be optional, but all file transfers will be empty without an S3 cache port: "_env:UPLOAD_S3_PORT:9000" access-key: "_env:UPLOAD_S3_KEY_ID:" secret-key: "_env:UPLOAD_S3_KEY" From 497e3e38e1f8eb9987ae0ff3847050f01017c066 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 11 Mar 2022 17:50:40 +0100 Subject: [PATCH 08/14] chore(lms): remove example data to allow sorting again; ignore identical imports for lms tables --- src/Handler/LMS/Result.hs | 19 +++++++++++-------- src/Handler/LMS/Userlist.hs | 12 +++++++----- src/Handler/LMS/Users.hs | 8 +++++--- src/Handler/Utils/LMS.hs | 10 ++++++++-- 4 files changed, 31 insertions(+), 18 deletions(-) diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index d459d89a4..e54f3da1e 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -78,13 +78,12 @@ embedRenderMessage ''UniWorX ''LmsResultCsvException id mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkResultTable sid qsh qid = do - now_day <- utctDay <$> liftIO getCurrentTime + _now_day <- utctDay <$> liftIO getCurrentTime dbtCsvName <- csvFilenameLmsResult qsh let dbtCsvSheetName = dbtCsvName let resultDBTable = DBTable{..} where - dbtSQLQuery lmsresult = do E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid return lmsresult @@ -119,10 +118,12 @@ mkResultTable sid qsh qid = do , dbtCsvSheetName , dbtCsvNoExportData = Just id , dbtCsvHeader = const $ return lmsResultTableCsvHeader - , dbtCsvExampleData = Just + , dbtCsvExampleData = Nothing + {-, dbtCsvExampleData = Just [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] ] + -} } where doEncode' = LmsResultTableCsv @@ -138,11 +139,13 @@ mkResultTable sid qsh qid = do , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day } 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 & lms2day - } + DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do + let successDay = lms2day csvLRTsuccess + when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $ + yield $ LmsResultUpdateData + { lmsResultInsertIdent = csvLRTident + , lmsResultInsertSuccess = successDay + } DBCsvDiffMissing{} -> return () -- no deletion , dbtCsvClassifyAction = \case LmsResultInsertData{} -> LmsResultInsert diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 849b33e26..ff261b983 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -130,11 +130,13 @@ mkUserlistTable sid qsh qid = do { lmsUserlistInsertIdent = csvLULident dbCsvNew , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew } - DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}} -> do - yield $ LmsUserlistUpdateData - { lmsUserlistInsertIdent = csvLULident - , lmsUserlistInsertFailed = csvLULfailed & lms2bool - } + DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do + let failedBool = lms2bool csvLULfailed + when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $ + yield $ LmsUserlistUpdateData + { lmsUserlistInsertIdent = csvLULident + , lmsUserlistInsertFailed = csvLULfailed & lms2bool + } DBCsvDiffMissing{} -> return () -- no deletion dbtCsvClassifyAction = \case LmsUserlistInsertData{} -> LmsUserlistInsert diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index eb4be3cde..7f7d3f9ed 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -84,11 +84,13 @@ mkUserTable _sid qsh qid = do , 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 + , sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty ] dbtSorting = Map.fromList - [ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserIdent) - , (csvLmsResetPin , SortColumn $ \lmslist -> lmslist E.^. LmsUserResetPin) + [ (csvLmsIdent , SortColumn (E.^. LmsUserIdent)) + , (csvLmsPin , SortColumn (E.^. LmsUserPin)) + , (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin)) + , (csvLmsDelete , SortColumn lmsUserToDeleteExpr) ] dbtFilter = Map.fromList [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent )) diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 1c9775888..43b849e24 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -13,12 +13,14 @@ module Handler.Utils.LMS , csvFilenameLmsUserlist , csvFilenameLmsResult , lmsUserToDelete, _lmsUserToDelete + , lmsUserToDeleteExpr ) where -- general utils for LMS Interface Handlers import Import import Handler.Utils +import qualified Database.Esqueleto.Legacy as E -- generic Column names csvLmsIdent :: IsString a => a @@ -27,7 +29,7 @@ csvLmsIdent = fromString "user" -- "Benutzerkennung" csvLmsTimestamp :: IsString a => a csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel" --- for User Table +-- for Users Table csvLmsPin :: IsString a => a csvLmsPin = fromString "pin" -- "PIN" @@ -72,8 +74,12 @@ getYMTH :: MonadHandler m => m Text getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime -- | Deceide whether LMS platform should delete an identifier +lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) +lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserSuccess) + lmsUserToDelete :: LmsUser -> Bool lmsUserToDelete LmsUser{lmsUserEnded, lmsUserSuccess} = isNothing lmsUserEnded && isJust lmsUserSuccess _lmsUserToDelete :: Getter LmsUser Bool -_lmsUserToDelete = to lmsUserToDelete \ No newline at end of file +_lmsUserToDelete = to lmsUserToDelete + From 7ccbf5868d597ed8df451b403280ec03509052e2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 14 Mar 2022 17:32:34 +0100 Subject: [PATCH 09/14] chore(lms): reinstate CSV examples, sorting working now --- src/Handler/LMS/Result.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index e54f3da1e..473f1443a 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -78,7 +78,7 @@ embedRenderMessage ''UniWorX ''LmsResultCsvException id mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkResultTable sid qsh qid = do - _now_day <- utctDay <$> liftIO getCurrentTime + now_day <- utctDay <$> liftIO getCurrentTime dbtCsvName <- csvFilenameLmsResult qsh let dbtCsvSheetName = dbtCsvName let @@ -111,19 +111,17 @@ mkResultTable sid qsh qid = do dbtParams = def dbtIdent :: Text dbtIdent = "lms-result" - dbtCsvEncode = Just DBTCsvEncode + dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvName , dbtCsvSheetName , dbtCsvNoExportData = Just id , dbtCsvHeader = const $ return lmsResultTableCsvHeader - , dbtCsvExampleData = Nothing - {-, dbtCsvExampleData = Just + , dbtCsvExampleData = Just [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] - ] - -} + ] } where doEncode' = LmsResultTableCsv From 51aa76ebdb963e2874b77b964cbd87fb71e71afd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 16 Mar 2022 17:37:25 +0100 Subject: [PATCH 10/14] chore(lms): add working direct upload page lms results --- routes | 11 +++--- src/Foundation/Navigation.hs | 2 + src/Handler/LMS.hs | 2 + src/Handler/LMS/Result.hs | 72 ++++++++++++++++++++++++++++++++++++ 4 files changed, 82 insertions(+), 5 deletions(-) diff --git a/routes b/routes index b340da62e..63263989e 100644 --- a/routes +++ b/routes @@ -255,8 +255,9 @@ !/*WellKnownFileName WellKnownR GET !free -- 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 +/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 +/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST +/lms/test LmsTestR GET \ No newline at end of file diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index f9b973078..5d1b5c677 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -137,6 +137,8 @@ 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 +breadcrumb (LmsResultUploadR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsResultR sid qsh +breadcrumb LmsTestR = i18nCrumb MsgMenuLmsResult Nothing breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c757d23fb..be6dd5a8c 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -9,6 +9,8 @@ module Handler.LMS , getLmsUsersR , postLmsUsersR , getLmsUserlistR, postLmsUserlistR , getLmsResultR , postLmsResultR + , getLmsResultUploadR , postLmsResultUploadR + , getLmsTestR ) where diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 473f1443a..9f04c35bf 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -2,6 +2,8 @@ module Handler.LMS.Result ( getLmsResultR, postLmsResultR + , getLmsResultUploadR, postLmsResultUploadR + , getLmsTestR ) where @@ -199,3 +201,73 @@ postLmsResultR sid qsh = do siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsResult $(widgetFile "lms-result") + + +-- Direct File Upload/Download +getLmsTestR :: Handler Html +getLmsTestR = siteLayoutMsg MsgMenuLmsResult $ do + setTitleI MsgMenuLmsResult + [whamlet|$newline never + Hello! + |] + + +getLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsResultUploadR _sid _qsh = do + -- _qid <- runDB $ getKeyBy404 $ UniqueSchoolShort sid qsh + ((_,widget), enctype) <- runFormPost makeResultUploadForm + siteLayoutMsg MsgMenuLmsResult $ do + setTitleI MsgMenuLmsResult + [whamlet|$newline never +
+ ^{widget} +

+ + |] + + +--saveResultCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend) => +-- Key Qualification -> LmsResultTableCsv -> ReaderT backend m () +saveResultCsv :: QualificationId -> LmsResultTableCsv -> DB () +saveResultCsv qid LmsResultTableCsv{..} = do + now <- liftIO getCurrentTime + void $ upsert + LmsResult + { lmsResultQualification = qid + , lmsResultIdent = csvLRTident + , lmsResultSuccess = csvLRTsuccess & lms2day + , lmsResultTimestamp = now + } + [ LmsResultSuccess =. (csvLRTsuccess & lms2day) + , LmsResultTimestamp =. now + ] + +postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html +postLmsResultUploadR sid qsh = do + ((result,widget), enctype) <- runFormPost makeResultUploadForm + case result of + FormSuccess file -> do + -- content <- fileSourceByteString file + -- return $ Just (fileName file, content) + void $ runDB $ do + qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + runConduit $ fileSource file + .| decodeCsv + .| mapM_C (saveResultCsv qid) + addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file + redirect $ LmsResultR sid qsh + FormFailure errs -> do + forM_ errs $ addMessage Error . toHtml + redirect $ LmsResultUploadR sid qsh + FormMissing -> + siteLayoutMsg MsgMenuLmsResult $ do + setTitleI MsgMenuLmsResult + [whamlet|$newline never + + ^{widget} +

+ + |] + +makeResultUploadForm :: Form FileInfo +makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "ResultCSV" From cbfa88a0597e6ee3cac4f09b29937a9a0955a2c1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 16 Mar 2022 18:33:40 +0100 Subject: [PATCH 11/14] chore(lms): clean direct result upload --- .../categories/qualification/de-de-formal.msg | 3 +- .../categories/qualification/en-eu.msg | 3 +- .../utils/navigation/menu/de-de-formal.msg | 3 +- .../uniworx/utils/navigation/menu/en-eu.msg | 3 +- routes | 3 +- src/Foundation/Navigation.hs | 12 ++--- src/Handler/LMS/Result.hs | 48 ++++++------------- templates/lms-result.hamlet | 3 ++ 8 files changed, 33 insertions(+), 45 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index bbf743671..642e9cdee 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -18,4 +18,5 @@ 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 +LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel +LmsDirectUpload: Direkter Upload für automatisierte Systeme \ 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 c618d7307..cf100eece 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -18,4 +18,5 @@ 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 +LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key +LmsDirectUpload: Direct upload for automated Systems \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 51d4765fc..44bf1006f 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -126,4 +126,5 @@ 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 +MenuLmsResult: Melden Ergebnisse E-Lernen +MenuLmsUpload: Direkter Upload \ 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 255a07c22..8c46e72da 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -127,4 +127,5 @@ 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 +MenuLmsResult: Upload E-Learning Results +MenuLmsUpload: Direct Upload \ No newline at end of file diff --git a/routes b/routes index 63263989e..36e4215a2 100644 --- a/routes +++ b/routes @@ -259,5 +259,4 @@ /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST -/lms/test LmsTestR GET \ No newline at end of file +/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST \ No newline at end of file diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 5d1b5c677..9527f7ad8 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -133,12 +133,12 @@ breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing 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 -breadcrumb (LmsResultUploadR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsResultR sid qsh -breadcrumb LmsTestR = i18nCrumb MsgMenuLmsResult Nothing +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 +breadcrumb (LmsResultUploadR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsResultR sid qsh + breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 9f04c35bf..6d337a290 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -2,8 +2,7 @@ module Handler.LMS.Result ( getLmsResultR, postLmsResultR - , getLmsResultUploadR, postLmsResultUploadR - , getLmsTestR + , getLmsResultUploadR, postLmsResultUploadR ) where @@ -195,6 +194,7 @@ mkResultTable sid qsh qid = do getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html getLmsResultR = postLmsResultR postLmsResultR sid qsh = do + let directUploadLink = LmsResultUploadR sid qsh lmsTable <- runDB $ do qid <- getKeyBy404 $ UniqueSchoolShort sid qsh view _2 <$> mkResultTable sid qsh qid @@ -204,32 +204,11 @@ postLmsResultR sid qsh = do -- Direct File Upload/Download -getLmsTestR :: Handler Html -getLmsTestR = siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsResult - [whamlet|$newline never - Hello! - |] - - -getLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsResultUploadR _sid _qsh = do - -- _qid <- runDB $ getKeyBy404 $ UniqueSchoolShort sid qsh - ((_,widget), enctype) <- runFormPost makeResultUploadForm - siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsResult - [whamlet|$newline never - - ^{widget} -

- - |] - --saveResultCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend) => -- Key Qualification -> LmsResultTableCsv -> ReaderT backend m () -saveResultCsv :: QualificationId -> LmsResultTableCsv -> DB () -saveResultCsv qid LmsResultTableCsv{..} = do +saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int +saveResultCsv qid i LmsResultTableCsv{..} = do now <- liftIO getCurrentTime void $ upsert LmsResult @@ -241,33 +220,36 @@ saveResultCsv qid LmsResultTableCsv{..} = do [ LmsResultSuccess =. (csvLRTsuccess & lms2day) , LmsResultTimestamp =. now ] + return $ succ i -postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html +makeResultUploadForm :: Form FileInfo +makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV" + +getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsResultUploadR = postLmsResultUploadR postLmsResultUploadR sid qsh = do ((result,widget), enctype) <- runFormPost makeResultUploadForm case result of FormSuccess file -> do -- content <- fileSourceByteString file -- return $ Just (fileName file, content) - void $ runDB $ do + nr <- runDB $ do qid <- getKeyBy404 $ UniqueSchoolShort sid qsh runConduit $ fileSource file .| decodeCsv - .| mapM_C (saveResultCsv qid) - addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file + .| foldMC (saveResultCsv qid) 0 + addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") redirect $ LmsResultR sid qsh FormFailure errs -> do forM_ errs $ addMessage Error . toHtml redirect $ LmsResultUploadR sid qsh FormMissing -> siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsResult - [whamlet|$newline never + setTitleI MsgMenuLmsUpload + [whamlet|$newline never ^{widget}

|] -makeResultUploadForm :: Form FileInfo -makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "ResultCSV" diff --git a/templates/lms-result.hamlet b/templates/lms-result.hamlet index 389ec613d..44ca90389 100644 --- a/templates/lms-result.hamlet +++ b/templates/lms-result.hamlet @@ -1,2 +1,5 @@ LMS Result ^{lmsTable} +

+ + _{MsgLmsDirectUpload} From e860a99657752707e790c7d6fcebfea712ddd294 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 17 Mar 2022 11:16:28 +0100 Subject: [PATCH 12/14] chore(lms): upload and direct for userlist and result working now --- models/lms.model | 4 +-- routes | 13 ++++--- src/Foundation/Navigation.hs | 13 ++++--- src/Handler/LMS.hs | 16 ++++----- src/Handler/LMS/Result.hs | 30 ++++++++++++---- src/Handler/LMS/Userlist.hs | 69 +++++++++++++++++++++++++++++++++++- src/Handler/LMS/Users.hs | 6 +++- 7 files changed, 122 insertions(+), 29 deletions(-) diff --git a/models/lms.model b/models/lms.model index eb17703a8..1463a6b9d 100644 --- a/models/lms.model +++ b/models/lms.model @@ -10,8 +10,8 @@ Qualification -- elearningOnly Bool -- successful E-learing automatically increases validity. NO! -- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO! -- expiryNotification StoredMarkup Maybe -- configurable user-profile-notifcations are used instead NO! - UniqueSchoolShort school shorthand -- must be unique per school and shorthand - UniqueSchoolName school name -- must be unique per school and name + UniqueQualificationSchoolShort school shorthand -- must be unique per school and shorthand + UniqueQualificationSchoolName school name -- must be unique per school and name deriving Generic -- TODOs: diff --git a/routes b/routes index 36e4215a2..0a2262676 100644 --- a/routes +++ b/routes @@ -255,8 +255,11 @@ !/*WellKnownFileName WellKnownR GET !free -- 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 -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST \ No newline at end of file +/lms/#SchoolId/#QualificationShorthand LmsR GET POST +/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST +/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST +/lms/#SchoolId/#QualificationShorthand/userliss/upload LmsUserlistUploadR GET POST +/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST +/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST +/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST +/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 9527f7ad8..52b22c348 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -133,11 +133,14 @@ breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing 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 -breadcrumb (LmsResultUploadR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsResultR sid qsh +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 (LmsUserlistUploadR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR sid qsh +breadcrumb (LmsUserlistDirectR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR sid qsh -- never displayed +breadcrumb (LmsResultR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR sid qsh +breadcrumb (LmsResultUploadR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR sid qsh +breadcrumb (LmsResultDirectR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR sid qsh -- never displayed breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index be6dd5a8c..03a704baa 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -5,12 +5,12 @@ module Handler.LMS - ( getLmsR , postLmsR - , getLmsUsersR , postLmsUsersR - , getLmsUserlistR, postLmsUserlistR - , getLmsResultR , postLmsResultR - , getLmsResultUploadR , postLmsResultUploadR - , getLmsTestR + ( getLmsR , postLmsR + , getLmsUsersR , postLmsUsersR + , getLmsUserlistR , postLmsUserlistR + , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR + , getLmsResultR , postLmsResultR + , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR ) where @@ -63,7 +63,7 @@ resultUser = _dbrOutput . _2 getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do - _qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh + _qid <- runDB . getKeyBy404 $ UniqueQualificationSchoolShort sid qsh -- TODO !!! filter table by qid !!! dbtCsvName <- csvLmsUserFilename @@ -335,7 +335,7 @@ getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do lmsTable <- runDB $ do - qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh view _2 <$> mkLmsTable sid qsh qid siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsResult diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 6d337a290..502a4a5a5 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -3,6 +3,7 @@ module Handler.LMS.Result ( getLmsResultR, postLmsResultR , getLmsResultUploadR, postLmsResultUploadR + , postLmsResultDirectR ) where @@ -196,7 +197,7 @@ getLmsResultR = postLmsResultR postLmsResultR sid qsh = do let directUploadLink = LmsResultUploadR sid qsh lmsTable <- runDB $ do - qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh view _2 <$> mkResultTable sid qsh qid siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsResult @@ -234,7 +235,7 @@ postLmsResultUploadR sid qsh = do -- content <- fileSourceByteString file -- return $ Just (fileName file, content) nr <- runDB $ do - qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh runConduit $ fileSource file .| decodeCsv .| foldMC (saveResultCsv qid) 0 @@ -246,10 +247,25 @@ postLmsResultUploadR sid qsh = do FormMissing -> siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsUpload - [whamlet|$newline never + [whamlet|$newline never - ^{widget} -

- + ^{widget} +

+ |] - + + +postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html +postLmsResultDirectR sid qsh = do + (_params, files) <- runRequestBody + case files of + [(fhead,file)] -> do + nr <- runDB $ do + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh + runConduit $ fileSource file + .| decodeCsv + .| foldMC (saveResultCsv qid) 0 + addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen für Result mit Header ") <> fhead + [] -> addMessage Error "Es wurde keine Datei übermittelt." + _other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden." + redirect $ LmsResultR sid qsh diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index ff261b983..7dbe6c14c 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -2,6 +2,8 @@ module Handler.LMS.Userlist ( getLmsUserlistR, postLmsUserlistR + , getLmsUserlistUploadR, postLmsUserlistUploadR + , postLmsUserlistDirectR ) where @@ -195,8 +197,73 @@ getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handl getLmsUserlistR = postLmsUserlistR postLmsUserlistR sid qsh = do lmsTable <- runDB $ do - qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh view _2 <$> mkUserlistTable sid qsh qid siteLayoutMsg MsgMenuLmsUserlist $ do setTitleI MsgMenuLmsUserlist $(widgetFile "lms-userlist") + + +-- Direct File Upload/Download + +--saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend) => +-- Key Qualification -> LmsUserlistTableCsv -> ReaderT backend m () +saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int +saveUserlistCsv qid i LmsUserlistTableCsv{..} = do + now <- liftIO getCurrentTime + void $ upsert + LmsUserlist + { lmsUserlistQualification = qid + , lmsUserlistIdent = csvLULident + , lmsUserlistFailed = csvLULfailed & lms2bool + , lmsUserlistTimestamp = now + } + [ LmsUserlistFailed =. (csvLULfailed & lms2bool) + , LmsUserlistTimestamp =. now + ] + return $ succ i + +makeUserlistUploadForm :: Form FileInfo +makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV" + +getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsUserlistUploadR = postLmsUserlistUploadR +postLmsUserlistUploadR sid qsh = do + ((result,widget), enctype) <- runFormPost makeUserlistUploadForm + case result of + FormSuccess file -> do + nr <- runDB $ do + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh + runConduit $ fileSource file + .| decodeCsv + .| foldMC (saveUserlistCsv qid) 0 + addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") + redirect $ LmsUserlistR sid qsh + FormFailure errs -> do + forM_ errs $ addMessage Error . toHtml + redirect $ LmsUserlistUploadR sid qsh + FormMissing -> + siteLayoutMsg MsgMenuLmsUserlist $ do + setTitleI MsgMenuLmsUpload + [whamlet|$newline never + + ^{widget} +

+ + |] + + +postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html +postLmsUserlistDirectR sid qsh = do + (_params, files) <- runRequestBody + case files of + [(fhead,file)] -> do + nr <- runDB $ do + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh + runConduit $ fileSource file + .| decodeCsv + .| foldMC (saveUserlistCsv qid) 0 + addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen für Userlit mit Header ") <> fhead + [] -> addMessage Error "Es wurde keine Datei übermittelt." + _other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden." + redirect $ LmsUserlistR sid qsh \ No newline at end of file diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 7f7d3f9ed..ba6b8d688 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -130,8 +130,12 @@ getLmsUsersR, postLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Ht getLmsUsersR = postLmsUsersR postLmsUsersR sid qsh = do lmsTable <- runDB $ do - qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh view _2 <$> mkUserTable sid qsh qid siteLayoutMsg MsgMenuLmsUsers $ do setTitleI MsgMenuLmsUsers $(widgetFile "lms-user") + + +-- direct Download see: +-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file From 9e91eab1394b6a9180dfba7b6ead9e38386b18ef Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 17 Mar 2022 13:13:06 +0100 Subject: [PATCH 13/14] chore(lms): direct export for lms users working --- routes | 3 ++- src/Foundation/Navigation.hs | 1 + src/Handler/LMS.hs | 2 +- src/Handler/LMS/Users.hs | 48 ++++++++++++++++++++++++++++++------ 4 files changed, 45 insertions(+), 9 deletions(-) diff --git a/routes b/routes index 0a2262676..f76b98d79 100644 --- a/routes +++ b/routes @@ -256,7 +256,8 @@ -- OSIS CSV Export Demo /lms/#SchoolId/#QualificationShorthand LmsR GET POST -/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST +/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET +/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST /lms/#SchoolId/#QualificationShorthand/userliss/upload LmsUserlistUploadR GET POST /lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 52b22c348..39aed96e6 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -135,6 +135,7 @@ breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never breadcrumb (LmsR _sid _qsh) = i18nCrumb MsgMenuLms Nothing breadcrumb (LmsUsersR sid qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR sid qsh +breadcrumb (LmsUsersDirectR sid qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsUsersR sid qsh -- never displayed, TypedContent breadcrumb (LmsUserlistR sid qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR sid qsh breadcrumb (LmsUserlistUploadR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR sid qsh breadcrumb (LmsUserlistDirectR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR sid qsh -- never displayed diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 03a704baa..a2bbbc88c 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -6,7 +6,7 @@ module Handler.LMS ( getLmsR , postLmsR - , getLmsUsersR , postLmsUsersR + , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR , getLmsResultR , postLmsResultR diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index ba6b8d688..f10585b62 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -1,7 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances +{- LANGUAGE TypeApplications -} -- only needed for Database.Esqueleto.Experimental module Handler.LMS.Users - ( getLmsUsersR, postLmsUsersR + ( getLmsUsersR + , getLmsUsersDirectR ) where @@ -16,6 +18,7 @@ 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.Experimental as Ex import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E @@ -27,6 +30,15 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only deriving Generic makeLenses_ ''LmsUserTableCsv +-- | Mundane conversion needed for direct download without dbTable onlu +lmsUser2csv :: LmsUser -> LmsUserTableCsv +lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv + { csvLUTident = lmsUserIdent + , csvLUTpin = lmsUserPin + , csvLUTresetPin = lmsUserResetPin & LmsBool + , csvLUTdelete = lmsUserToDelete lu & LmsBool + , csvLUTstaff = False & LmsBool + } -- csv without headers -- TODO not yet supported -- instance Csv.ToRecord LmsUserTableCsv @@ -76,6 +88,7 @@ mkUserTable _sid qsh qid = do where dbtSQLQuery lmsuser = do E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid + E.&&. E.isNothing (lmsuser E.^. LmsUserEnded) return lmsuser dbtRowKey = (E.^. LmsUserId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? @@ -116,8 +129,7 @@ mkUserTable _sid qsh qid = do <*> view (_dbrOutput . _entityVal . _lmsUserPin) <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool) - -- <*> const $ LmsBool False - <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool) + <*> const (LmsBool False) dbtCsvDecode = Nothing dbtExtraReps = [] @@ -126,9 +138,8 @@ mkUserTable _sid qsh qid = do & defaultSorting [SortAscBy csvLmsIdent] dbTable userDBTableValidator userDBTable -getLmsUsersR, postLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUsersR = postLmsUsersR -postLmsUsersR sid qsh = do +getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsUsersR sid qsh = do lmsTable <- runDB $ do qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh view _2 <$> mkUserTable sid qsh qid @@ -136,6 +147,29 @@ postLmsUsersR sid qsh = do setTitleI MsgMenuLmsUsers $(widgetFile "lms-user") - +getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent +getLmsUsersDirectR sid qsh = do + lms_users <- runDB $ do + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh + selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent] + {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it + Ex.select $ do + lmsuser <- Ex.from $ Ex.table @LmsUser + Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid + Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded) + pure $ LmsUserTableCsv + { csvLUTident = lmsuser Ex.^. LmsUserIdent + , csvLUTpin = lmsuser Ex.^. LmsUserPin + , csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin + , csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserSuccess) + , csvLUTstaff = LmsBool False + } + -} + let csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users + csvRenderedHeader = lmsUserTableCsvHeader + csvSheetName <- csvFilenameLmsUser qsh + addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" + csvRenderedToTypedContent csvSheetName CsvRendered{..} + -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file From d892fb5b71a2de441a2ad393e1362b41e4bbc126 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 17 Mar 2022 13:14:19 +0100 Subject: [PATCH 14/14] chore(lms): add test csv for upload to testdata --- testdata/test_results.csv | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 testdata/test_results.csv diff --git a/testdata/test_results.csv b/testdata/test_results.csv new file mode 100644 index 000000000..beb80f5ae --- /dev/null +++ b/testdata/test_results.csv @@ -0,0 +1,5 @@ +user,success +barfoo,2022-02-01 +huhuuhu,10-12-2011 +pqgrst,2022-03-07 +hootsman,1994-07-08