From 6159403b27dab30178645dc37c99d41b4aaf610c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 8 Sep 2022 18:11:07 +0200 Subject: [PATCH 01/39] feat(lms): configurable csv settings for lms direct import and export routes --- config/settings.yml | 7 ++++ .../utils/navigation/menu/de-de-formal.msg | 3 +- .../uniworx/utils/navigation/menu/en-eu.msg | 3 +- src/Foundation/Navigation.hs | 10 ++--- src/Handler/LMS/Result.hs | 13 +++++-- src/Handler/LMS/Userlist.hs | 13 +++++-- src/Handler/LMS/Users.hs | 20 +++++++--- src/Handler/Utils/Csv.hs | 11 +++++- src/Handler/Utils/Form.hs | 1 + src/Model/Types/Avs.hs | 3 ++ src/Model/Types/Csv.hs | 38 ++++++++++--------- src/Settings.hs | 26 ++++++++++++- 12 files changed, 107 insertions(+), 41 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 1da144da9..f9c501645 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -125,6 +125,13 @@ ldap: ldap-re-test-failover: 60 +lms: + upload-headedness: "_env:LMSUPLOADHEADEDNESS:true" + upload-delimiter: "_env:LMSUPLOADDELIMITER:," + download-headedness: "_env:LMSDOWNLOADHEADEDNESS:true" + download-delimiter: "_env:LMSDOWNLOADDELIMITER:," + download-cr-lf: "_env:LMSDOWNLOADCRLF:true" + avs: host: "_env:AVSHOST:skytest.fra.fraport.de" port: "_env:AVSPORT:443" diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 1c8948184..569028694 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -130,7 +130,8 @@ MenuLmsUsers: Export E-Lernen Benutzer MenuLmsUserlist: Melden E-Lernen Benutzer MenuLmsResult: Melden Ergebnisse E-Lernen MenuLmsUpload: Hochladen -MenuLmsDirect: Direkter Upload +MenuLmsDirectUpload: Direkter Upload +MenuLmsDirectDownload: Direkter Download MenuLmsFake: Testnutzer generieren MenuAvs: Schnittstelle AVS diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index b0e1779d1..ee8b49b0b 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -131,7 +131,8 @@ MenuLmsUsers: Download E-Learning Users MenuLmsUserlist: Upload E-Learning Users MenuLmsResult: Upload E-Learning Results MenuLmsUpload: Upload -MenuLmsDirect: Direct Upload +MenuLmsDirectUpload: Direct Upload +MenuLmsDirectDownload: Direct Download MenuLmsFake: Generate test users MenuAvs: AVS Interface diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 419c3de01..33fbaf5f8 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -2464,21 +2464,21 @@ pageActions (LmsR sid qsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh , navChildren = - [ defNavLink MsgMenuLmsDirect $ LmsUsersDirectR sid qsh + [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh ] } , NavPageActionPrimary { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh , navChildren = - [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh - , defNavLink MsgMenuLmsDirect $ LmsUserlistDirectR sid qsh + [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh + , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh ] } , NavPageActionPrimary { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh , navChildren = - [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh - , defNavLink MsgMenuLmsDirect $ LmsResultDirectR sid qsh + [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh + , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh ] } , NavPageActionSecondary { diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 6e7fbc6b2..92c6c4550 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -29,9 +29,9 @@ data LmsResultTableCsv = LmsResultTableCsv deriving Generic makeLenses_ ''LmsResultTableCsv --- csv without headers -- TODO not yet supported ---instance Csv.ToRecord LmsResultTableCsv -- default suffices ---instance Csv.FromRecord LmsResultTableCsv -- default suffices +-- csv without headers +instance Csv.ToRecord LmsResultTableCsv -- default suffices +instance Csv.FromRecord LmsResultTableCsv -- default suffices -- csv with headers lmsResultTableCsvHeader :: Csv.Header @@ -262,10 +262,15 @@ postLmsResultDirectR sid qsh = do (_params, files) <- runRequestBody (status, msg) <- case files of [(fhead,file)] -> do + LmsConf{..} <- getsYesod $ view _appLmsConf + let fmtOpts = def { csvDelimiter = lmsUploadDelimiter + , csvIncludeHeader = lmsUploadHeadedness + } + csvOpts = def { csvFormat = fmtOpts } runDBJobs $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh enr <- try $ runConduit $ fileSource file - .| decodeCsv + .| decodeCsvWith csvOpts .| foldMC (saveResultCsv qid) 0 case enr of Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 2a1a4cf1f..3ef15737e 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -28,9 +28,9 @@ data LmsUserlistTableCsv = LmsUserlistTableCsv deriving Generic makeLenses_ ''LmsUserlistTableCsv --- csv without headers -- TODO not yet supported ---instance Csv.ToRecord LmsUserlistTableCsv ---instance Csv.FromRecord LmsUserlistTableCsv +-- csv without headers +instance Csv.ToRecord LmsUserlistTableCsv +instance Csv.FromRecord LmsUserlistTableCsv -- csv with headers instance DefaultOrdered LmsUserlistTableCsv where @@ -258,10 +258,15 @@ postLmsUserlistDirectR sid qsh = do (_params, files) <- runRequestBody (status, msg) <- case files of [(fhead,file)] -> do + LmsConf{..} <- getsYesod $ view _appLmsConf + let fmtOpts = def { csvDelimiter = lmsUploadDelimiter + , csvIncludeHeader = lmsUploadHeadedness + } + csvOpts = def { csvFormat = fmtOpts } runDBJobs $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh enr <- try $ runConduit $ fileSource file - .| decodeCsv + .| decodeCsvWith csvOpts .| foldMC (saveUserlistCsv qid) 0 case enr of Left (e :: SomeException) -> do diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 57954e912..772f7910a 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -39,9 +39,9 @@ lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv , csvLUTstaff = False & LmsBool } --- csv without headers -- TODO not yet supported --- instance Csv.ToRecord LmsUserTableCsv --- instance Csv.FromRecord LmsUserTableCsv +-- csv without headers +instance Csv.ToRecord LmsUserTableCsv +instance Csv.FromRecord LmsUserTableCsv -- csv with headers lmsUserTableCsvHeader :: Csv.Header @@ -165,11 +165,19 @@ getLmsUsersDirectR sid qsh = do , csvLUTstaff = LmsBool False } -} - let csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users - csvRenderedHeader = lmsUserTableCsvHeader + LmsConf{..} <- getsYesod $ view _appLmsConf + let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users + --csvRenderedHeader = lmsUserTableCsvHeader + --cvsRendered = CsvRendered {..} + csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv . entityVal <$> lms_users + fmtOpts = def { csvDelimiter = lmsDownloadDelimiter + , csvUseCrLf = lmsDownloadCrLf + , csvIncludeHeader = lmsDownloadHeadedness + } + csvOpts = def { csvFormat = fmtOpts } csvSheetName <- csvFilenameLmsUser qsh addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" - csvRenderedToTypedContent csvSheetName CsvRendered{..} + csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 813527281..b9581486f 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Utils.Csv - ( decodeCsv, decodeCsvPositional + ( decodeCsv, decodeCsvPositional, decodeCsvWith , encodeCsv, encodeCsvWith, encodeCsvRendered, encodeCsvRenderedWith , csvRenderedToTypedContent, csvRenderedToTypedContentWith , expectedCsvFormat, expectedCsvContentType @@ -87,6 +87,15 @@ decodeCsv = decodeCsv' $ \opts -> fromNamedCsvStreamError opts (review _haltingC decodeCsvPositional :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromRecord csv) => HasHeader -> ConduitT ByteString csv m () decodeCsvPositional hdr = decodeCsv' $ \opts -> fromCsvStreamError opts hdr (review _haltingCsvParseError) .| throwIncrementalErrors +decodeCsvWith :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv, FromRecord csv) => CsvOptions -> ConduitT ByteString csv m () +decodeCsvWith opts + | csvIncludeHeader fmtOpts + = decodeCsv' $ \_ -> fromNamedCsvStreamError decOpts (review _haltingCsvParseError) .| throwIncrementalErrors + | otherwise + = decodeCsv' $ \_ -> fromCsvStreamError decOpts NoHeader (review _haltingCsvParseError) .| throwIncrementalErrors + where + fmtOpts = csvFormat opts + decOpts = DecodeOptions { decDelimiter = fromIntegral $ Char.ord $ csvDelimiter fmtOpts } decodeCsv' :: forall csv m. ( MonadHandler m, HandlerSite m ~ UniWorX diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index bb5903487..2c00f2317 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -2067,6 +2067,7 @@ csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs <*> apreq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (preview _csvUseCrLf =<< mPrev) <*> apreq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (preview _csvQuoting =<< mPrev) <*> apreq (selectField encodingOpts) (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (preview _csvEncoding =<< mPrev) + <*> pure True FormatXlsx -> pure CsvXlsxFormatOptions delimiterOpts :: Handler (OptionList Char) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index aca992367..a259654b8 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -61,6 +61,7 @@ data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable) instance ToJSON AvsLicence where + -- toJSON al = Number $ fromEnum AvsLicence -- would do, but... toJSON AvsNoLicence = Number 0 toJSON AvsLicenceVorfeld = Number 1 toJSON AvsLicenceRollfeld = Number 2 @@ -229,6 +230,8 @@ deriveJSON defaultOptions , rejectUnknownFields = False } ''AvsResponsePerson + + ------------- -- Queries -- ------------- diff --git a/src/Model/Types/Csv.hs b/src/Model/Types/Csv.hs index ca7ec802b..e6053b6ac 100644 --- a/src/Model/Types/Csv.hs +++ b/src/Model/Types/Csv.hs @@ -60,10 +60,11 @@ data CsvOptions data CsvFormatOptions = CsvFormatOptions - { csvDelimiter :: Char - , csvUseCrLf :: Bool - , csvQuoting :: Csv.Quoting - , csvEncoding :: DynEncoding + { csvDelimiter :: Char + , csvUseCrLf :: Bool + , csvQuoting :: Csv.Quoting + , csvEncoding :: DynEncoding + , csvIncludeHeader :: Bool } | CsvXlsxFormatOptions deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -94,16 +95,18 @@ csvPreset = prism' fromPreset toPreset where fromPreset :: CsvPreset -> CsvFormatOptions fromPreset CsvPresetRFC = CsvFormatOptions - { csvDelimiter = ',' - , csvUseCrLf = True - , csvQuoting = QuoteMinimal - , csvEncoding = "UTF8" + { csvDelimiter = ',' + , csvUseCrLf = True + , csvIncludeHeader = True + , csvQuoting = QuoteMinimal + , csvEncoding = "UTF8" } fromPreset CsvPresetExcel = CsvFormatOptions - { csvDelimiter = ';' - , csvUseCrLf = True - , csvQuoting = QuoteAll - , csvEncoding = "CP1252" + { csvDelimiter = ';' + , csvUseCrLf = True + , csvIncludeHeader = True + , csvQuoting = QuoteAll + , csvEncoding = "CP1252" } fromPreset CsvPresetXlsx = CsvXlsxFormatOptions @@ -119,7 +122,7 @@ _CsvEncodeOptions = prism' fromEncode toEncode { Csv.encDelimiter = fromIntegral $ fromEnum csvDelimiter , Csv.encUseCrLf = csvUseCrLf , Csv.encQuoting = csvQuoting - , Csv.encIncludeHeader = True + , Csv.encIncludeHeader = csvIncludeHeader } toEncode CsvXlsxFormatOptions{} = Nothing fromEncode encOpts = def @@ -180,13 +183,14 @@ instance ToJSON CsvFormatOptions where instance FromJSON CsvFormatOptions where parseJSON = JSON.withObject "CsvFormatOptions" $ \o -> do formatTag <- o JSON..:? "format" JSON..!= FormatCsv - + case formatTag of FormatCsv -> do csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def - csvUseCrLf <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf def - csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def - csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def + csvUseCrLf <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf def + csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def + csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def + csvIncludeHeader <- o JSON..:? "include-header" JSON..!= csvIncludeHeader def return CsvFormatOptions{..} FormatXlsx -> return CsvXlsxFormatOptions diff --git a/src/Settings.hs b/src/Settings.hs index 33c2f40ca..6f8b502da 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -93,6 +93,8 @@ data AppSettings = AppSettings -- ^ Configuration settings for accessing the database. , appAutoDbMigrate :: Bool , appLdapConf :: Maybe (PointedList LdapConf) + -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) + , appLmsConf :: LmsConf -- ^ Configuration settings for accessing the LDAP-directory , appAvsConf :: Maybe AvsConf -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System) @@ -301,6 +303,14 @@ data LdapConf = LdapConf , ldapPool :: ResourcePoolConf } deriving (Show) +data LmsConf = LmsConf + { lmsUploadDelimiter :: Char + , lmsUploadHeadedness :: Bool + , lmsDownloadDelimiter :: Char + , lmsDownloadHeadedness :: Bool + , lmsDownloadCrLf :: Bool + } deriving (Show) + data AvsConf = AvsConf { avsHost :: String , avsPort :: Int @@ -311,7 +321,7 @@ data AvsConf = AvsConf data LprConf = LprConf { lprHost :: String , lprPort :: Int - , lprQueue:: String + , lprQueue:: String } deriving (Show) data SmtpConf = SmtpConf @@ -480,6 +490,17 @@ deriveFromJSON } ''HaskellNet.AuthType +instance FromJSON LmsConf where + parseJSON = withObject "LmsConf" $ \o -> do + lmsUploadDelimiter <- o .: "upload-delimiter" + lmsUploadHeadedness <- o .: "upload-headedness" + lmsDownloadDelimiter <- o .: "download-delimiter" + lmsDownloadHeadedness <- o .: "download-headedness" + lmsDownloadCrLf <- o .: "download-cr-lf" + return LmsConf{..} + +makeLenses_ ''LmsConf + instance FromJSON AvsConf where parseJSON = withObject "AvsConf" $ \o -> do avsHost <- o .: "host" @@ -492,7 +513,7 @@ instance FromJSON LprConf where parseJSON = withObject "LprConf" $ \o -> do lprHost <- o .: "host" lprPort <- o .: "port" - lprQueue <- o .: "queue" + lprQueue <- o .: "queue" return LprConf{..} instance FromJSON SmtpConf where @@ -576,6 +597,7 @@ instance FromJSON AppSettings where Ldap.Tls host _ -> not $ null host Ldap.Plain host -> not $ null host appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= [] + appLmsConf <- o .: "lms" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" appLprConf <- o .: "lpr" appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" From 0001dfbba90e3e0de69bf84a95b0d8bc194dc9f3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 8 Sep 2022 18:21:19 +0200 Subject: [PATCH 02/39] chore(lms): fix build --- test/Model/TypesSpec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 53d8ab8dc..486b9c03e 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -298,6 +298,7 @@ instance Arbitrary CsvFormatOptions where <*> arbitrary <*> arbitrary <*> elements ["UTF8", "CP1252"] + <*> True , pure CsvXlsxFormatOptions ] where From 712f9adcdbfa860a57f963193dbd46ac024d1e6e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 8 Sep 2022 18:31:38 +0200 Subject: [PATCH 03/39] chore(lms): fix build --- test/Model/TypesSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 486b9c03e..8e8096c97 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -298,7 +298,7 @@ instance Arbitrary CsvFormatOptions where <*> arbitrary <*> arbitrary <*> elements ["UTF8", "CP1252"] - <*> True + <*> pure True , pure CsvXlsxFormatOptions ] where From b99629b97ddf462d3eac673b7c2de6ec490f06e4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 8 Sep 2022 18:51:44 +0200 Subject: [PATCH 04/39] chore(release): 26.4.0 --- CHANGELOG.md | 9 +++++++++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 14 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c811b891e..1fa5a2150 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [26.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.3.1...v26.4.0) (2022-09-08) + + +### Features + +* **avs:** add SetRampDrivingLicence and InfoRampDrivingLicence to AVS interface ([a1272e3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a1272e38b72d146b881492341a86e1fc544ab0ff)) +* **lms:** configurable csv settings for lms direct import and export routes ([6159403](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6159403b27dab30178645dc37c99d41b4aaf610c)) +* **users:** allow users to set postal address and email encryption password ([655fcf7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/655fcf756471a2dfc6380e4b63236ca8d5229e11)) + ## [26.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.3.0...v26.3.1) (2022-09-03) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index 9d550df50..dfcd8eed7 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "26.3.1" + "version": "26.4.0" } diff --git a/nix/docker/version.json b/nix/docker/version.json index 9d550df50..dfcd8eed7 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "26.3.1" + "version": "26.4.0" } diff --git a/package-lock.json b/package-lock.json index cf92b247b..e822225a1 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.3.1", + "version": "26.4.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index d3655ce6a..08a77cd85 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.3.1", + "version": "26.4.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 7c9939884..581d03a75 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 26.3.1 +version: 26.4.0 dependencies: - base - yesod From d174f3953019f9e41bfb8a146c36089affe6f7fa Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 9 Sep 2022 12:11:13 +0200 Subject: [PATCH 05/39] refactor(lms): lms decoding delimiter is fully optional now --- config/settings.yml | 8 +-- src/Handler/LMS/Result.hs | 126 +++++++++++++++++------------------- src/Handler/LMS/Userlist.hs | 107 +++++++++++++++--------------- src/Handler/LMS/Users.hs | 62 +++++++++--------- src/Handler/Utils/LMS.hs | 68 +++++++++++-------- src/Settings.hs | 18 +++--- 6 files changed, 198 insertions(+), 191 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index f9c501645..190cd0670 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -125,10 +125,10 @@ ldap: ldap-re-test-failover: 60 -lms: - upload-headedness: "_env:LMSUPLOADHEADEDNESS:true" - upload-delimiter: "_env:LMSUPLOADDELIMITER:," - download-headedness: "_env:LMSDOWNLOADHEADEDNESS:true" +lms-direct: + upload-header: "_env:LMSUPLOADHEADER:true" + upload-delimiter: "_env:LMSUPLOADDELIMITER:" + download-header: "_env:LMSDOWNLOADHEADER:true" download-delimiter: "_env:LMSDOWNLOADDELIMITER:," download-cr-lf: "_env:LMSDOWNLOADCRLF:true" diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 92c6c4550..43ddac453 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -1,8 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances module Handler.LMS.Result - ( getLmsResultR, postLmsResultR - , getLmsResultUploadR, postLmsResultUploadR + ( getLmsResultR, postLmsResultR + , getLmsResultUploadR, postLmsResultUploadR , postLmsResultDirectR ) where @@ -33,7 +33,7 @@ makeLenses_ ''LmsResultTableCsv instance Csv.ToRecord LmsResultTableCsv -- default suffices instance Csv.FromRecord LmsResultTableCsv -- default suffices --- csv with headers +-- csv with headers lmsResultTableCsvHeader :: Csv.Header lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ] @@ -73,15 +73,15 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "action" "data" } ''LmsResultCsvAction -data LmsResultCsvException +data LmsResultCsvException = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! deriving (Show, Generic, Typeable) instance Exception LmsResultCsvException -embedRenderMessage ''UniWorX ''LmsResultCsvException id +embedRenderMessage ''UniWorX ''LmsResultCsvException id mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkResultTable sid qsh qid = do +mkResultTable sid qsh qid = do now_day <- utctDay <$> liftIO getCurrentTime dbtCsvName <- csvFilenameLmsResult qsh let dbtCsvSheetName = dbtCsvName @@ -97,7 +97,7 @@ mkResultTable sid qsh qid = do [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp - ] + ] dbtSorting = Map.fromList [ (csvLmsIdent , SortColumn (E.^. LmsResultIdent)) , (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess)) @@ -107,72 +107,72 @@ mkResultTable sid qsh qid = do [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent)) , (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess)) ] - dbtFilterUI = \mPrev -> mconcat + dbtFilterUI = \mPrev -> mconcat [ 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 { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text - dbtIdent = "lms-result" - dbtCsvEncode = Just DBTCsvEncode + dbtIdent = "lms-result" + dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) - , dbtCsvName + , dbtCsvName , dbtCsvSheetName , dbtCsvNoExportData = Just id , dbtCsvHeader = const $ return lmsResultTableCsvHeader - , dbtCsvExampleData = Just - [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } - | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] - ] + , dbtCsvExampleData = Just + [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } + | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] + ] } - where + where doEncode' = LmsResultTableCsv <$> view (_dbrOutput . _entityVal . _lmsResultIdent) <*> 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 + { dbtCsvRowKey = \LmsResultTableCsv{..} -> + 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 + DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do yield $ LmsResultInsertData { lmsResultInsertIdent = csvLRTident 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{..}, dbCsvOld} -> do + DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do let successDay = lms2day csvLRTsuccess - when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $ + when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $ yield $ LmsResultUpdateData { lmsResultInsertIdent = csvLRTident , lmsResultInsertSuccess = successDay - } + } DBCsvDiffMissing{} -> return () -- no deletion - , dbtCsvClassifyAction = \case + , dbtCsvClassifyAction = \case LmsResultInsertData{} -> LmsResultInsert - LmsResultUpdateData{} -> LmsResultUpdate + LmsResultUpdateData{} -> LmsResultUpdate , dbtCsvCoarsenActionClass = \case - LmsResultInsert -> DBCsvActionNew + LmsResultInsert -> DBCsvActionNew LmsResultUpdate -> DBCsvActionExisting , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error , dbtCsvExecuteActions = do - C.mapM_ $ \actionData -> do + C.mapM_ $ \actionData -> do now <- liftIO getCurrentTime - void $ upsert + void $ upsert LmsResult - { lmsResultQualification = qid + { lmsResultQualification = qid , lmsResultIdent = lmsResultInsertIdent actionData , lmsResultSuccess = lmsResultInsertSuccess actionData , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? } [ LmsResultSuccess =. lmsResultInsertSuccess actionData , LmsResultTimestamp =. now - ] + ] -- audit $ Transaction.. (add to Audit.Types) lift . queueDBJob $ JobLmsResults qid - return $ LmsResultR sid qsh - , dbtCsvRenderKey = const $ \case + return $ LmsResultR sid qsh + , dbtCsvRenderKey = const $ \case LmsResultInsertData{..} -> do -- TODO: i18n [whamlet| $newline never @@ -187,7 +187,7 @@ mkResultTable sid qsh qid = do |] , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text - } + } dbtExtraReps = [] resultDBTableValidator = def @@ -198,9 +198,9 @@ getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler getLmsResultR = postLmsResultR postLmsResultR sid qsh = do let directUploadLink = LmsResultUploadR sid qsh - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkResultTable sid qsh qid + lmsTable <- runDB $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + view _2 <$> mkResultTable sid qsh qid siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsResult $(widgetFile "lms-result") @@ -211,17 +211,17 @@ postLmsResultR sid qsh = do saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int saveResultCsv qid i LmsResultTableCsv{..} = do now <- liftIO getCurrentTime - void $ upsert + void $ upsert LmsResult - { lmsResultQualification = qid + { lmsResultQualification = qid , lmsResultIdent = csvLRTident , lmsResultSuccess = csvLRTsuccess & lms2day - , lmsResultTimestamp = now + , lmsResultTimestamp = now } [ LmsResultSuccess =. (csvLRTsuccess & lms2day) , LmsResultTimestamp =. now ] - return $ succ i + return $ succ i makeResultUploadForm :: Form FileInfo makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV" @@ -230,23 +230,23 @@ getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand getLmsResultUploadR = postLmsResultUploadR postLmsResultUploadR sid qsh = do ((result,widget), enctype) <- runFormPost makeResultUploadForm - case result of + case result of FormSuccess file -> do - -- content <- fileSourceByteString file - -- return $ Just (fileName file, content) - nr <- runDBJobs $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - nr <- runConduit $ fileSource file + -- content <- fileSourceByteString file + -- return $ Just (fileName file, content) + nr <- runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveResultCsv qid) 0 queueDBJob $ JobLmsResults qid return nr addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") - redirect $ LmsResultR sid qsh + redirect $ LmsResultR sid qsh FormFailure errs -> do forM_ errs $ addMessage Error . toHtml - redirect $ LmsResultUploadR sid qsh - FormMissing -> + redirect $ LmsResultUploadR sid qsh + FormMissing -> siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsUpload [whamlet|$newline never @@ -258,36 +258,32 @@ postLmsResultUploadR sid qsh = do postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html -postLmsResultDirectR sid qsh = do - (_params, files) <- runRequestBody +postLmsResultDirectR sid qsh = do + (_params, files) <- runRequestBody (status, msg) <- case files of [(fhead,file)] -> do - LmsConf{..} <- getsYesod $ view _appLmsConf - let fmtOpts = def { csvDelimiter = lmsUploadDelimiter - , csvIncludeHeader = lmsUploadHeadedness - } - csvOpts = def { csvFormat = fmtOpts } - runDBJobs $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + lmsDecoder <- getLmsCsvDecoder + runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh enr <- try $ runConduit $ fileSource file - .| decodeCsvWith csvOpts + .| lmsDecoder .| foldMC (saveResultCsv qid) 0 - case enr of + case enr of Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e return (badRequest400, "Exception: " <> tshow e) - Right nr -> do + Right nr -> do let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead $logWarnS "LMS" msg -- TODO: change to Info Level in the future queueDBJob $ JobLmsResults qid - return (ok200, msg) + return (ok200, msg) [] -> do let msg = "Result upload file missing." - $logWarnS "LMS" msg + $logWarnS "LMS" msg return (badRequest400, msg) _other -> do let msg = "Result upload received multiple files; all ignored." - $logWarnS "LMS" msg + $logWarnS "LMS" msg return (badRequest400, msg) sendResponseStatus status msg - + diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 3ef15737e..25d57e3ed 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -1,8 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances module Handler.LMS.Userlist - ( getLmsUserlistR, postLmsUserlistR - , getLmsUserlistUploadR, postLmsUserlistUploadR + ( getLmsUserlistR, postLmsUserlistR + , getLmsUserlistUploadR, postLmsUserlistUploadR , postLmsUserlistDirectR ) where @@ -23,20 +23,20 @@ import Jobs.Queue data LmsUserlistTableCsv = LmsUserlistTableCsv { csvLULident :: LmsIdent - , csvLULfailed :: LmsBool + , csvLULfailed :: LmsBool } deriving Generic makeLenses_ ''LmsUserlistTableCsv --- csv without headers +-- csv without headers instance Csv.ToRecord LmsUserlistTableCsv instance Csv.FromRecord LmsUserlistTableCsv --- csv with headers -instance DefaultOrdered LmsUserlistTableCsv where +-- csv with headers +instance DefaultOrdered LmsUserlistTableCsv where headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ] -instance ToNamedRecord LmsUserlistTableCsv where +instance ToNamedRecord LmsUserlistTableCsv where toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord [ csvLmsIdent Csv..= csvLULident , csvLmsBlocked Csv..= csvLULfailed @@ -57,7 +57,7 @@ instance CsvColumnsExplained LmsUserlistTableCsv where single k v = singletonMap k [whamlet|_{v}|] -data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate +data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded) embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id @@ -72,12 +72,12 @@ deriveJSON defaultOptions } ''LmsUserlistCsvAction -data LmsUserlistCsvException +data LmsUserlistCsvException = LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! deriving (Show, Generic, Typeable) instance Exception LmsUserlistCsvException -embedRenderMessage ''UniWorX ''LmsUserlistCsvException id +embedRenderMessage ''UniWorX ''LmsUserlistCsvException id mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkUserlistTable sid qsh qid = do @@ -105,7 +105,7 @@ mkUserlistTable sid qsh qid = do [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) , (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed)) ] - dbtFilterUI = \mPrev -> mconcat + dbtFilterUI = \mPrev -> mconcat [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed) ] @@ -114,9 +114,9 @@ mkUserlistTable sid qsh qid = do dbtIdent :: Text dbtIdent = "lms-userlist" dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample - where + where addExample dce = dce{ dbtCsvExampleData = csvExample } - csvExample = Just + csvExample = Just [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl} | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False] ] @@ -125,47 +125,47 @@ mkUserlistTable sid qsh qid = do <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool) dbtCsvDecode = Just DBTCsvDecode {..} where - dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} -> + dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} -> fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident dbtCsvComputeActions = \case -- shows a diff first - DBCsvDiffNew{dbCsvNew} -> do - yield $ LmsUserlistInsertData + DBCsvDiffNew{dbCsvNew} -> do + yield $ LmsUserlistInsertData { lmsUserlistInsertIdent = csvLULident dbCsvNew , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew } - DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do + DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do let failedBool = lms2bool csvLULfailed when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $ - yield $ LmsUserlistUpdateData - { lmsUserlistInsertIdent = csvLULident - , lmsUserlistInsertFailed = csvLULfailed & lms2bool + yield $ LmsUserlistUpdateData + { lmsUserlistInsertIdent = csvLULident + , lmsUserlistInsertFailed = csvLULfailed & lms2bool } - DBCsvDiffMissing{} -> return () -- no deletion - dbtCsvClassifyAction = \case + DBCsvDiffMissing{} -> return () -- no deletion + dbtCsvClassifyAction = \case LmsUserlistInsertData{} -> LmsUserlistInsert - LmsUserlistUpdateData{} -> LmsUserlistUpdate - dbtCsvCoarsenActionClass = \case - LmsUserlistInsert -> DBCsvActionNew + LmsUserlistUpdateData{} -> LmsUserlistUpdate + dbtCsvCoarsenActionClass = \case + LmsUserlistInsert -> DBCsvActionNew LmsUserlistUpdate -> DBCsvActionExisting - dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error + dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error dbtCsvExecuteActions = do C.mapM_ $ \actionData -> do now <- liftIO getCurrentTime void $ upsert LmsUserlist { - lmsUserlistQualification = qid + lmsUserlistQualification = qid , lmsUserlistIdent = lmsUserlistInsertIdent actionData , lmsUserlistFailed = lmsUserlistInsertFailed actionData - , lmsUserlistTimestamp = now + , lmsUserlistTimestamp = now } [ LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False? , LmsUserlistTimestamp =. now - ] - -- audit + ] + -- audit lift . queueDBJob $ JobLmsUserlist qid return $ LmsUserlistR sid qsh - dbtCsvRenderKey = const $ \case + dbtCsvRenderKey = const $ \case LmsUserlistInsertData{..} -> do -- TODO: i18n [whamlet| $newline never @@ -195,7 +195,7 @@ mkUserlistTable sid qsh qid = do getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistR = postLmsUserlistR +getLmsUserlistR = postLmsUserlistR postLmsUserlistR sid qsh = do lmsTable <- runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh @@ -211,17 +211,17 @@ postLmsUserlistR sid qsh = do saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int saveUserlistCsv qid i LmsUserlistTableCsv{..} = do now <- liftIO getCurrentTime - void $ upsert + void $ upsert LmsUserlist - { lmsUserlistQualification = qid + { lmsUserlistQualification = qid , lmsUserlistIdent = csvLULident , lmsUserlistFailed = csvLULfailed & lms2bool - , lmsUserlistTimestamp = now + , lmsUserlistTimestamp = now } [ LmsUserlistFailed =. (csvLULfailed & lms2bool) , LmsUserlistTimestamp =. now ] - return $ succ i + return $ succ i makeUserlistUploadForm :: Form FileInfo makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV" @@ -230,19 +230,19 @@ getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorth getLmsUserlistUploadR = postLmsUserlistUploadR postLmsUserlistUploadR sid qsh = do ((result,widget), enctype) <- runFormPost makeUserlistUploadForm - case result of + case result of FormSuccess file -> do - nr <- runDBJobs $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + nr <- runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0 queueDBJob $ JobLmsUserlist qid return nr addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") - redirect $ LmsUserlistR sid qsh + redirect $ LmsUserlistR sid qsh FormFailure errs -> do forM_ errs $ addMessage Error . toHtml - redirect $ LmsUserlistUploadR sid qsh - FormMissing -> + redirect $ LmsUserlistUploadR sid qsh + FormMissing -> siteLayoutMsg MsgMenuLmsUserlist $ do setTitleI MsgMenuLmsUpload [whamlet|$newline never @@ -255,35 +255,30 @@ postLmsUserlistUploadR sid qsh = do postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html postLmsUserlistDirectR sid qsh = do - (_params, files) <- runRequestBody + (_params, files) <- runRequestBody (status, msg) <- case files of [(fhead,file)] -> do - LmsConf{..} <- getsYesod $ view _appLmsConf - let fmtOpts = def { csvDelimiter = lmsUploadDelimiter - , csvIncludeHeader = lmsUploadHeadedness - } - csvOpts = def { csvFormat = fmtOpts } - runDBJobs $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + lmsDecoder <- getLmsCsvDecoder + runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh enr <- try $ runConduit $ fileSource file - .| decodeCsvWith csvOpts + .| lmsDecoder .| foldMC (saveUserlistCsv qid) 0 - case enr of + case enr of Left (e :: SomeException) -> do $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e return (badRequest400, "Exception: " <> tshow e) - Right nr -> do + Right nr -> do let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead $logWarnS "LMS" msg -- TODO: change to Info Level in the future queueDBJob $ JobLmsResults qid return (ok200, msg) [] -> do let msg = "Userlist upload file missing." - $logWarnS "LMS" msg + $logWarnS "LMS" msg return (badRequest400, msg) _other -> do let msg = "Userlist upload received multiple files; all ignored." - $logWarnS "LMS" msg + $logWarnS "LMS" msg return (badRequest400, msg) sendResponseStatus status msg - \ No newline at end of file diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 772f7910a..216c74270 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -27,30 +27,30 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only , csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool } deriving Generic -makeLenses_ ''LmsUserTableCsv +makeLenses_ ''LmsUserTableCsv -- | Mundane conversion needed for direct download without dbTable onlu lmsUser2csv :: LmsUser -> LmsUserTableCsv lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv - { csvLUTident = lmsUserIdent + { csvLUTident = lmsUserIdent , csvLUTpin = lmsUserPin - , csvLUTresetPin = lmsUserResetPin & LmsBool + , csvLUTresetPin = lmsUserResetPin & LmsBool , csvLUTdelete = lmsUserToDelete lu & LmsBool , csvLUTstaff = False & LmsBool } --- csv without headers +-- csv without headers instance Csv.ToRecord LmsUserTableCsv instance Csv.FromRecord LmsUserTableCsv --- csv with headers +-- csv with headers lmsUserTableCsvHeader :: Csv.Header lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff ] -instance ToNamedRecord LmsUserTableCsv where +instance ToNamedRecord LmsUserTableCsv where toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord [ csvLmsIdent Csv..= csvLUTident - , csvLmsPin Csv..= csvLUTpin + , csvLmsPin Csv..= csvLUTpin , csvLmsResetPin Csv..= csvLUTresetPin , csvLmsDelete Csv..= csvLUTdelete , csvLmsStaff Csv..= csvLUTstaff @@ -79,14 +79,14 @@ instance CsvColumnsExplained LmsUserTableCsv where mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkUserTable _sid qsh qid = do +mkUserTable _sid qsh qid = do dbtCsvName <- csvFilenameLmsUser qsh let dbtCsvSheetName = dbtCsvName let userDBTable = DBTable{..} where dbtSQLQuery lmsuser = do - E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid + E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (lmsuser E.^. LmsUserEnded) return lmsuser dbtRowKey = (E.^. LmsUserId) @@ -94,7 +94,7 @@ mkUserTable _sid qsh qid = do dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] - ) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin + ) $ \(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 Nothing (i18nCell MsgTableLmsStaff) $ const mempty @@ -109,16 +109,16 @@ mkUserTable _sid qsh qid = do [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent )) , (csvLmsResetPin , FilterColumn $ E.mkExactFilter (E.^. LmsUserResetPin)) ] - dbtFilterUI = \mPrev -> mconcat + dbtFilterUI = \mPrev -> mconcat [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsResetPin) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text - dbtIdent = "lms-user" + dbtIdent = "lms-user" dbtCsvEncode = Just DBTCsvEncode {..} - where + where dbtCsvExportForm = pure () dbtCsvNoExportData = Just id dbtCsvExampleData = Nothing @@ -129,7 +129,7 @@ mkUserTable _sid qsh qid = do <*> view (_dbrOutput . _entityVal . _lmsUserPin) <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool) - <*> const (LmsBool False) + <*> const (LmsBool False) dbtCsvDecode = Nothing dbtExtraReps = [] @@ -140,9 +140,9 @@ mkUserTable _sid qsh qid = do getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html getLmsUsersR sid qsh = do - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkUserTable sid qsh qid + lmsTable <- runDB $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + view _2 <$> mkUserTable sid qsh qid siteLayoutMsg MsgMenuLmsUsers $ do setTitleI MsgMenuLmsUsers $(widgetFile "lms-user") @@ -150,34 +150,34 @@ getLmsUsersR sid qsh = do getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsUsersDirectR sid qsh = do lms_users <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort 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 + qid <- getKeyBy404 $ SchoolQualificationShort 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.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded) pure $ LmsUserTableCsv - { csvLUTident = lmsuser Ex.^. LmsUserIdent - , csvLUTpin = lmsuser Ex.^. LmsUserPin + { 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.^. LmsUserStatus) , csvLUTstaff = LmsBool False } - -} + -} LmsConf{..} <- getsYesod $ view _appLmsConf - let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users - --csvRenderedHeader = lmsUserTableCsvHeader + let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users + --csvRenderedHeader = lmsUserTableCsvHeader --cvsRendered = CsvRendered {..} csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv . entityVal <$> lms_users - fmtOpts = def { csvDelimiter = lmsDownloadDelimiter + fmtOpts = def { csvIncludeHeader = lmsDownloadHeader + , csvDelimiter = lmsDownloadDelimiter , csvUseCrLf = lmsDownloadCrLf - , csvIncludeHeader = lmsDownloadHeadedness } csvOpts = def { csvFormat = fmtOpts } - csvSheetName <- csvFilenameLmsUser qsh + csvSheetName <- csvFilenameLmsUser qsh addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered - + -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 3cd3e3403..79a306756 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -1,17 +1,18 @@ {-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter module Handler.Utils.LMS - ( csvLmsIdent + ( getLmsCsvDecoder + , csvLmsIdent , csvLmsTimestamp , csvLmsBlocked , csvLmsSuccess - , csvLmsPin + , csvLmsPin , csvLmsResetPin - , csvLmsDelete - , csvLmsStaff - , csvFilenameLmsUser + , csvLmsDelete + , csvLmsStaff + , csvFilenameLmsUser , csvFilenameLmsUserlist - , csvFilenameLmsResult + , csvFilenameLmsResult , lmsUserToDelete, _lmsUserToDelete , lmsUserToDeleteExpr , randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries @@ -19,14 +20,30 @@ module Handler.Utils.LMS -- general utils for LMS Interface Handlers -import Import +import Import import Handler.Utils +import Handler.Utils.Csv +import Data.Csv (HasHeader(..), FromRecord) + import qualified Database.Esqueleto.Legacy as E import Control.Monad.Random.Class (uniform) import Control.Monad.Trans.Random (evalRandTIO) --- generic Column names + +getLmsCsvDecoder :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv, FromRecord csv) => Handler (ConduitT ByteString csv m ()) +getLmsCsvDecoder = do + LmsConf{..} <- getsYesod $ view _appLmsConf + if | Just upDelim <- lmsUploadDelimiter -> do + let fmtOpts = def { csvDelimiter = upDelim + , csvIncludeHeader = lmsUploadHeader + } + csvOpts = def { csvFormat = fmtOpts } + return $ decodeCsvWith csvOpts + | lmsUploadHeader -> return decodeCsv + | otherwise -> return $ decodeCsvPositional NoHeader + +-- generic Column names csvLmsIdent :: IsString a => a csvLmsIdent = fromString "user" -- "Benutzerkennung" @@ -81,44 +98,43 @@ getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus) -lmsUserToDelete :: LmsUser -> Bool +lmsUserToDelete :: LmsUser -> Bool lmsUserToDelete LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && isJust lmsUserStatus -_lmsUserToDelete :: Getter LmsUser Bool +_lmsUserToDelete :: Getter LmsUser Bool _lmsUserToDelete = to lmsUserToDelete -- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y? -lengthIdent :: Int -lengthIdent = 8 +lengthIdent :: Int +lengthIdent = 8 -lengthPassword :: Int -lengthPassword = 8 +lengthPassword :: Int +lengthPassword = 8 --- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent -maxLmsUserIdentRetries :: Int +-- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent +maxLmsUserIdentRetries :: Int maxLmsUserIdentRetries = 27 -- | Generate Random Text of specified length using numbers and lower case letters plus supplied extra characters -randomText :: MonadIO m => String -> Int -> m Text -randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range - where +randomText :: MonadIO m => String -> Int -> m Text +randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range + where num_letters = ['0'..'9'] ++ ['a'..'z'] range = extra ++ num_letters --TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though -- import qualified Data.Elocrypt as Elo --- randomLMSIdent :: MonadRandom m => m LmsIdent --- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt --- where +-- randomLMSIdent :: MonadRandom m => m LmsIdent +-- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt +-- where -- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True } -randomLMSIdent :: MonadIO m => m LmsIdent +randomLMSIdent :: MonadIO m => m LmsIdent randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -randomLMSpw :: MonadIO m => m Text +randomLMSpw :: MonadIO m => m Text randomLMSpw = randomText extra lengthPassword - where + where extra = "_-+*.:;=!?#" - \ No newline at end of file diff --git a/src/Settings.hs b/src/Settings.hs index 6f8b502da..fb471d603 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -304,10 +304,10 @@ data LdapConf = LdapConf } deriving (Show) data LmsConf = LmsConf - { lmsUploadDelimiter :: Char - , lmsUploadHeadedness :: Bool + { lmsUploadHeader :: Bool + , lmsUploadDelimiter :: Maybe Char + , lmsDownloadHeader :: Bool , lmsDownloadDelimiter :: Char - , lmsDownloadHeadedness :: Bool , lmsDownloadCrLf :: Bool } deriving (Show) @@ -492,11 +492,11 @@ deriveFromJSON instance FromJSON LmsConf where parseJSON = withObject "LmsConf" $ \o -> do - lmsUploadDelimiter <- o .: "upload-delimiter" - lmsUploadHeadedness <- o .: "upload-headedness" - lmsDownloadDelimiter <- o .: "download-delimiter" - lmsDownloadHeadedness <- o .: "download-headedness" - lmsDownloadCrLf <- o .: "download-cr-lf" + lmsUploadHeader <- o .: "upload-header" + lmsUploadDelimiter <- o .:? "upload-delimiter" + lmsDownloadHeader <- o .: "download-header" + lmsDownloadDelimiter <- o .: "download-delimiter" + lmsDownloadCrLf <- o .: "download-cr-lf" return LmsConf{..} makeLenses_ ''LmsConf @@ -597,7 +597,7 @@ instance FromJSON AppSettings where Ldap.Tls host _ -> not $ null host Ldap.Plain host -> not $ null host appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= [] - appLmsConf <- o .: "lms" + appLmsConf <- o .: "lms-direct" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" appLprConf <- o .: "lpr" appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" From 77f76fbe8d838292f97f979ef07755b43382844c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 9 Sep 2022 12:32:09 +0200 Subject: [PATCH 06/39] refactor(avs): prioritise card color by choosing among several avs cards --- src/Model/Types/Avs.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index a259654b8..7f84fa578 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -79,7 +79,7 @@ licence2char AvsLicenceVorfeld = 'F' licence2char AvsLicenceRollfeld = 'R' -data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text +data AvsDataCardColor = AvsCardColorMisc Text | AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving anyclass (NFData) @@ -104,12 +104,12 @@ data AvsDataPersonCard = AvsDataPersonCard { avsDataValid :: Bool -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans , avsDataValidTo :: Maybe Day -- always Nothing if returned with AvsResponseStatus , avsDataIssueDate :: Maybe Day -- always Nothing if returned with AvsResponseStatus + , avsDataCardColor :: AvsDataCardColor , avsDataCardAreas :: Set Char -- logically a set of upper-case letters , avsDataStreet :: Maybe Text -- always Nothing if returned with AvsResponseStatus , avsDataPostalCode:: Maybe Text -- always Nothing if returned with AvsResponseStatus , avsDataCity :: Maybe Text -- always Nothing if returned with AvsResponseStatus - , avsDataFirm :: Maybe Text -- always Nothing if returned with AvsResponseStatus - , avsDataCardColor :: AvsDataCardColor + , avsDataFirm :: Maybe Text -- always Nothing if returned with AvsResponseStatus , avsDataCardNo :: Text -- always 8 digits , avsDataVersionNo :: Text } @@ -134,12 +134,12 @@ instance FromJSON AvsDataPersonCard where <$> ((v .: "Valid") <&> sloppyBool) <*> v .:? "ValidTo" <*> v .:? "IssueDate" + <*> v .: "CardColor" <*> ((v .: "CardAreas") <&> charSet) <*> v .:? "Street" <*> v .:? "PostalCode" <*> v .:? "City" - <*> v .:? "Firm" - <*> v .: "CardColor" + <*> v .:? "Firm" <*> v .: "CardNo" <*> v .: "VersionNo" @@ -298,6 +298,8 @@ pickLicenceAddress a b | Just r <- pickBetter' avsDataValid = r -- prefer valid cards | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards + | avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc. + | avsDataCardColor a < avsDataCardColor b = b | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date | avsDataIssueDate a < avsDataIssueDate b = b | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date From 2221b30771557716c875c1deb044357aa23bd264 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 9 Sep 2022 12:33:20 +0200 Subject: [PATCH 07/39] refactor(lpr): lms link switched to https and includes pre-filled login --- src/Jobs/Handler/SendNotification/Qualification.hs | 6 ++++-- templates/letter/fraport_renewal.md | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 52334c689..5e5c1a6eb 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -66,16 +66,18 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient let printJobName = "RenewalPin" - prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address + prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address + lmsIdent = lmsUserIdent & getLmsIdent pdfMeta = mkMeta [ toMeta "date" letterDate , toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang - , toMeta "login" (lmsUserIdent & getLmsIdent) + , toMeta "login" lmsIdent , toMeta "pin" lmsUserPin , toMeta "recipient" userDisplayName , mbMeta "address" (prepAddress <$> userPostAddress) , toMeta "expiry" expiryDate , mbMeta "validduration" (show <$> qualificationValidDuration) + , toMeta "url" ("") ] pdfRenewal pdfMeta >>= \case Left err -> do diff --git a/templates/letter/fraport_renewal.md b/templates/letter/fraport_renewal.md index 0c0510006..9c86edb03 100644 --- a/templates/letter/fraport_renewal.md +++ b/templates/letter/fraport_renewal.md @@ -6,7 +6,6 @@ en-subject: Renewal of apron driving License author: Fraport AG - Fahrerausbildung (AVN-AR) phone: +49 69 690-30306 email: fahrerausbildung@fraport.de -url: place: Frankfurt/Main return-address: - 60547 Frankfurt @@ -22,6 +21,7 @@ encludes: hyperrefoptions: hidelinks ### Metadaten, welche automatisch ersetzt werden: +url: date: 11.11.1111 expiry: 00.00.0000 lang: de-de From fc926c23cbb743e88627b216a6132f7d9c549dcd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 9 Sep 2022 13:29:40 +0200 Subject: [PATCH 08/39] refactor(lpr): fix sender recipient switch and remove printjob uuid column from print center --- src/Handler/PrintCenter.hs | 15 +++++---------- .../Handler/SendNotification/Qualification.hs | 2 +- src/Utils/Print.hs | 8 ++++++-- 3 files changed, 12 insertions(+), 13 deletions(-) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 2768ff791..c8656153c 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -183,21 +183,16 @@ mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget) mkPJTable = do currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here let - showId :: PrintJobId -> Widget - showId k = do - c <- encrypt k - let f :: CryptoUUIDPrintJob -> Text - f x = toPathPiece x - [whamlet|#{f c}|] dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) dbtProj = dbtProjFilteredPostId dbtColonnade = mconcat [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) , sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t - , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t - , sortable (Just "pj-filename") (i18nCell MsgPrintJobFilename) $ \( view $ resultPrintJob . _entityVal . _printJobFilename -> t) -> textCell t - , sortable (toNothingS "pdf") (i18nCell MsgPrintPDF) $ \( view $ resultPrintJob . _entityKey -> k) -> anchorCellM (PrintDownloadR <$> encrypt k) (showId k) + , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t + , sortable (Just "pj-filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey + t = r ^. resultPrintJob . _entityVal . _printJobFilename + in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t) -- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> textCell (tshow . E.unSqlBackendKey $ unPrintJobKey k) -- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> cell (showId k) , sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n @@ -307,7 +302,7 @@ postPrintSendR = do -- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" uID <- maybeAuthId - runDB (sendLetter "Test-Brief" bs mbRecipient uID Nothing Nothing) >>= \case -- calls lpr + runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing) >>= \case -- calls lpr Left err -> do let msg = "PDF printing failed with error: " <> err $logErrorS "LPR" msg diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 5e5c1a6eb..e555381ca 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -87,7 +87,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do Right pdf | userPrefersLetter recipient -> do let printSender = Nothing - runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case + runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification)) >>= \case Left err -> do let msg = "Notify " <> tshow encRecipient <> " PDF printing to send letter failed with error: " <> err $logErrorS "LMS" msg diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index e6b7f3f5d..b9811208e 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -263,8 +263,8 @@ pdfRenewal' meta = do -- PrintJobs -- --------------- -sendLetter :: Text -> LBS.ByteString -> Maybe UserId -> Maybe UserId -> Maybe CourseId -> Maybe QualificationId -> DB (Either Text (Text, FilePath)) -sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse printJobQualification = do +sendLetter :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> DB (Either Text (Text, FilePath)) +sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification = do recipient <- join <$> mapM get printJobRecipient sender <- join <$> mapM get printJobSender course <- join <$> mapM get printJobCourse @@ -280,6 +280,10 @@ sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse prin printJobFile = LBS.toStrict pdf lprPDF jobFullName pdf >>= \case Left err -> do + -- for testing + printJobCreated <- liftIO getCurrentTime + insert_ PrintJob {..} + -- for testing return $ Left err Right ok -> do printJobCreated <- liftIO getCurrentTime From cac4870c95f5367536ee48644fea8a526a0da5a3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 9 Sep 2022 15:46:18 +0200 Subject: [PATCH 09/39] feat(lpr): print center allows filtering by day now --- src/Database/Esqueleto/Utils.hs | 15 +++++++++++++-- src/Handler/PrintCenter.hs | 13 ++++++------- src/Utils/Print.hs | 4 ---- test/Database/Fill.hs | 9 +++++++++ 4 files changed, 28 insertions(+), 13 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 2990ca28f..f5afda286 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -14,6 +14,7 @@ module Database.Esqueleto.Utils , mkExactFilter, mkExactFilterWith , mkExactFilterLast, mkExactFilterLastWith , mkContainsFilter, mkContainsFilterWith + , mkDayFilter , mkExistsFilter , anyFilter, allFilter , orderByList @@ -222,7 +223,7 @@ mkExactFilterWith cast lenslike row criterias mkExactFilterLast :: (PersistField a) => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element -> t -- ^ query row - -> Last a -- ^ needle collection + -> Last a -- ^ needle -> E.SqlExpr (E.Value Bool) mkExactFilterLast = mkExactFilterLastWith id @@ -231,7 +232,7 @@ mkExactFilterLastWith :: (PersistField b) => (a -> b) -- ^ type conversion -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element -> t -- ^ query row - -> Last a -- ^ needle collection + -> Last a -- ^ needle -> E.SqlExpr (E.Value Bool) mkExactFilterLastWith cast lenslike row criterias | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit) @@ -258,6 +259,16 @@ mkContainsFilterWith cast lenslike row criterias | Set.null criterias = true | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) + +mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Last Day -- ^ a day to filter for + -> E.SqlExpr (E.Value Bool) +mkDayFilter lenslike row criterias + | Last (Just crit) <- criterias = day (lenslike row) E.==. E.val crit + | otherwise = true + + mkExistsFilter :: PathPiece a => (t -> a -> E.SqlQuery ()) -> t diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index c8656153c..a05d70ab3 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -193,8 +193,6 @@ mkPJTable = do , sortable (Just "pj-filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey t = r ^. resultPrintJob . _entityVal . _printJobFilename in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t) - -- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> textCell (tshow . E.unSqlBackendKey $ unPrintJobKey k) - -- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> cell (showId k) , sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n , sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR @@ -203,8 +201,7 @@ mkPJTable = do ] dbtSorting = mconcat [ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) - , single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) - -- , single ("pj-id" , SortColumn $ queryPrintJob >>> (E.^. PrintJobId)) + , single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) , single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) , single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , single ("pj-recipient" , sortUserNameBareM queryRecipient) @@ -215,15 +212,17 @@ mkPJTable = do dbtFilter = mconcat [ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) , single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) + , single ("pj-created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName)) , single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName)) , single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName)) , single ("pj-qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName)) - , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) + , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) ] dbtFilterUI mPrev = mconcat - [ prismAForm (singletonFilter "pj-filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename) - , prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName) + [ prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName) + , prismAForm (singletonFilter "pj-filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename) + , prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) , prismAForm (singletonFilter "pj-recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient) , prismAForm (singletonFilter "pj-sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender) , prismAForm (singletonFilter "pj-course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index b9811208e..04b088fb6 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -280,10 +280,6 @@ sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse p printJobFile = LBS.toStrict pdf lprPDF jobFullName pdf >>= \case Left err -> do - -- for testing - printJobCreated <- liftIO getCurrentTime - insert_ PrintJob {..} - -- for testing return $ Left err Right ok -> do printJobCreated <- liftIO getCurrentTime diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8056ccd87..61f80af29 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -528,6 +528,15 @@ fillDb = do void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing Nothing void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-1)) + void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) + void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-1)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_f) + void . insert $ PrintJob "TestJob3" "job3" "No Text herein." (n_day' (-2)) Nothing Nothing Nothing Nothing Nothing + void . insert $ PrintJob "TestJob4" "job4" "No Text herein." (n_day' (-2)) Nothing (Just jost) Nothing Nothing Nothing + void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-4)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_r) + void . insert $ PrintJob "TestJob6" "job6" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing Nothing (Just qid_r) + void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing Nothing Nothing + + let examLabels = Map.fromList [ ( sbarth From a9865c4c2d047874e615bc18129e6ac8bb1aaddc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 9 Sep 2022 16:45:58 +0200 Subject: [PATCH 10/39] chore(release): 26.5.0 --- CHANGELOG.md | 7 +++++++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 12 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1fa5a2150..76ab26d39 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [26.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.4.0...v26.5.0) (2022-09-09) + + +### Features + +* **lpr:** print center allows filtering by day now ([cac4870](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cac4870c95f5367536ee48644fea8a526a0da5a3)) + ## [26.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.3.1...v26.4.0) (2022-09-08) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index dfcd8eed7..f54e8f744 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "26.4.0" + "version": "26.5.0" } diff --git a/nix/docker/version.json b/nix/docker/version.json index dfcd8eed7..f54e8f744 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "26.4.0" + "version": "26.5.0" } diff --git a/package-lock.json b/package-lock.json index e822225a1..99fbe45dc 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.4.0", + "version": "26.5.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 08a77cd85..171ed51bc 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.4.0", + "version": "26.5.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 581d03a75..a2bc2c95e 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 26.4.0 +version: 26.5.0 dependencies: - base - yesod From 0c985fef0c1a7bd36027c9972d848cee27b7b141 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 14 Sep 2022 10:52:05 +0200 Subject: [PATCH 11/39] chore(ldap): add ldap test interface --- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 1 + src/Auth/LDAP.hs | 7 +- src/Database/Esqueleto/Utils.hs | 11 ++- src/Foundation/Navigation.hs | 9 +++ src/Foundation/Yesod/Auth.hs | 12 +++- src/Handler/Admin.hs | 1 + src/Handler/Admin/Avs.hs | 2 +- src/Handler/Admin/Ldap.hs | 70 +++++++++++++++++++ src/Handler/PrintCenter.hs | 26 ++++--- src/Handler/Utils/LMS.hs | 2 +- src/Utils/Form.hs | 2 +- templates/ldap.hamlet | 11 +++ 14 files changed, 137 insertions(+), 19 deletions(-) create mode 100644 src/Handler/Admin/Ldap.hs create mode 100644 templates/ldap.hamlet diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 569028694..a6b97fc6c 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -135,6 +135,7 @@ MenuLmsDirectDownload: Direkter Download MenuLmsFake: Testnutzer generieren MenuAvs: Schnittstelle AVS +MenuLdap: Schnittstelle LDAP MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index ee8b49b0b..391796b5d 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -136,6 +136,7 @@ MenuLmsDirectDownload: Direct Download MenuLmsFake: Generate test users MenuAvs: AVS Interface +MenuLdap: LDAP Interface MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter diff --git a/routes b/routes index 2e68773a5..f1c0adf0e 100644 --- a/routes +++ b/routes @@ -62,6 +62,7 @@ /admin/tokens AdminTokensR GET POST /admin/crontab AdminCrontabR GET /admin/avs AdminAvsR GET POST +/admin/ldap AdminLdapR GET POST /print PrintCenterR GET POST !system-printer /print/send PrintSendR GET POST diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index e96b1a90d..6d408e270 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -5,7 +5,7 @@ module Auth.LDAP , ADError(..), ADInvalidCredentials(..) , campusLogin , CampusUserException(..) - , campusUser, campusUser' + , campusUser, campusUser', campusUser'' , campusUserReTest, campusUserReTest' , campusUserMatr, campusUserMatr' , CampusMessage(..) @@ -145,8 +145,11 @@ campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList [])) campusUser' pool mode User{userIdent} - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap (CI.original userIdent) []) + = campusUser'' pool mode $ CI.original userIdent +campusUser'' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Text -> m (Maybe (Ldap.AttrList [])) +campusUser'' pool mode ident + = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap ident []) campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList []) campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f5afda286..c20e865db 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -14,7 +14,7 @@ module Database.Esqueleto.Utils , mkExactFilter, mkExactFilterWith , mkExactFilterLast, mkExactFilterLastWith , mkContainsFilter, mkContainsFilterWith - , mkDayFilter + , mkDayFilter, mkDayBetweenFilter , mkExistsFilter , anyFilter, allFilter , orderByList @@ -269,6 +269,15 @@ mkDayFilter lenslike row criterias | otherwise = true +mkDayBetweenFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Last (Day,Day) -- ^ a day range to filter for + -> E.SqlExpr (E.Value Bool) +mkDayBetweenFilter lenslike row criterias + | Last (Just (from,to)) <- criterias = day (lenslike row) `E.between` (E.val from, E.val to) + | otherwise = true + + mkExistsFilter :: PathPiece a => (t -> a -> E.SqlQuery ()) -> t diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 33fbaf5f8..f4a95c6c3 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -105,6 +105,7 @@ breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR +breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR @@ -819,6 +820,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navQuick' = mempty , navForceActive = False } + , NavLink + { navLabel = MsgMenuLdap + , navRoute = AdminLdapR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } ] } , return NavHeaderContainer diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 785acc5d1..0d74c98e5 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -168,6 +168,14 @@ upsertCampusUser upsertMode ldapData = do = return t | otherwise = throwM err + -- accept multiple successful decodings, ignoring all others + decodeLdapN attr err + | t@(_:_) <- rights vs + = return $ Text.unwords t + | otherwise = throwM err + where + vs = Text.decodeUtf8' <$> (ldapMap !!! attr) + -- accept any successful decoding or empty; only throw an error if all decodings fail -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text decodeLdap' attr err @@ -175,7 +183,7 @@ upsertCampusUser upsertMode ldapData = do | (h:_) <- rights vs = return $ Just h | otherwise = throwM err where - vs = Text.decodeUtf8' <$> ldapMap !!! attr + vs = Text.decodeUtf8' <$> (ldapMap !!! attr) -- just returns Nothing on error, pure decodeLdap :: Ldap.Attr -> Maybe Text @@ -208,7 +216,7 @@ upsertCampusUser upsertMode ldapData = do -> return $ CI.mk userEmail | otherwise -> throwM CampusUserInvalidEmail - userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName + userFirstName <- decodeLdapN ldapUserFirstName CampusUserInvalidGivenName userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 262223ac4..12d71ee45 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -9,6 +9,7 @@ import Handler.Admin.ErrorMessage as Handler.Admin import Handler.Admin.Tokens as Handler.Admin import Handler.Admin.Crontab as Handler.Admin import Handler.Admin.Avs as Handler.Admin +import Handler.Admin.Ldap as Handler.Admin getAdminR :: Handler Html getAdminR = diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 43ef56e44..6ee40f5c3 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -51,7 +51,7 @@ validateAvsQueryStatus = do AvsQueryStatus ids <- State.get guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids) -getAdminAvsR, postAdminAvsR :: Handler Html +getAdminAvsR, postAdminAvsR :: Handler Html getAdminAvsR = postAdminAvsR postAdminAvsR = do mAvsQuery <- getsYesod $ view _appAvsQuery diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs new file mode 100644 index 000000000..45c1f1bf7 --- /dev/null +++ b/src/Handler/Admin/Ldap.hs @@ -0,0 +1,70 @@ + + +module Handler.Admin.Ldap + ( getAdminLdapR + , postAdminLdapR + ) where + +import Import +-- import qualified Control.Monad.State.Class as State +-- import Data.Aeson (encode) +-- import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +-- import qualified Data.Set as Set + +import Handler.Utils + +import qualified Ldap.Client as Ldap +import Auth.LDAP + +newtype LdapQueryPerson = LdapQueryPerson + { ldapQueryIdent :: Text + -- , ldapQueryName :: Maybe Text + -- , ldapQueryPNum :: Maybe Text + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +makeLdapPersonForm :: Maybe LdapQueryPerson -> Form LdapQueryPerson +makeLdapPersonForm tmpl = validateForm validateLdapQueryPerson $ \html -> + flip (renderAForm FormStandard) html $ LdapQueryPerson + <$> areq textField (fslI MsgAdminUserIdent) (ldapQueryIdent <$> tmpl) + -- <*> aopt textField (fslI MsgAdminUserSurname) (ldapQueryName <$> tmpl) + -- <*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum <$> tmpl) + +validateLdapQueryPerson :: FormValidator LdapQueryPerson Handler () +validateLdapQueryPerson = return () -- currently no tests needed + --LdapQueryPerson{..} <- State.get + --guardValidation MsgAvsQueryEmpty + --is _Just ldapQueryIdent || + --is _Just ldapQueryName || + --is _Just ldapQueryPNum + + + +getAdminLdapR, postAdminLdapR :: Handler Html +getAdminLdapR = postAdminLdapR +postAdminLdapR = do + ((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing + + let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList [])) + procFormPerson LdapQueryPerson{..} = do + ldapPool' <- getsYesod $ view _appLdapPool + if isNothing ldapPool' + then addMessage Warning $ text2Html "LDAP Configuration missing." + else addMessage Info $ text2Html "Input for LDAP test received." + fmap join . for ldapPool' $ \ldapPool -> + campusUser'' ldapPool FailoverUnlimited ldapQueryIdent + + mbLdapData <- formResultMaybe presult procFormPerson + + + actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute + siteLayoutMsg MsgMenuLdap $ do + setTitleI MsgMenuLdap + let personForm = wrapForm pwidget def + { formAction = Just $ SomeRoute actionUrl + , formEncoding = penctype + } + -- TODO: use i18nWidgetFile instead if this is to become permanent + $(widgetFile "ldap") + diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index a05d70ab3..784ce47a1 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -3,7 +3,7 @@ module Handler.PrintCenter ( getPrintCenterR, postPrintCenterR , getPrintSendR , postPrintSendR - , getPrintDownloadR + , getPrintDownloadR ) where import Import @@ -98,10 +98,10 @@ mprToMeta MetaPinRenewal{..} = mkMeta where deOrEn = if isDe mppLang then "de" else "en" keyOpening = deOrEn <> "-opening" - keyClosing = deOrEn <> "-closing" + keyClosing = deOrEn <> "-closing" mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta -mprToMetaUser entUser@Entity{entityVal = u} mpr = do +mprToMetaUser entUser@Entity{entityVal = u} mpr = do let userLang = userLanguages u >>= (listToMaybe . view _Wrapped) -- auch möglich `op Languages` statt `view _Wrapped` meta = mprToMeta mpr{ mppRecipient = userDisplayName u -- , mppAddress = userDisplayName u : html2textlines userAddress --TODO once we have User addresses within the DB @@ -189,11 +189,11 @@ mkPJTable = do dbtColonnade = mconcat [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) , sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t - , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t + , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t , sortable (Just "pj-filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey t = r ^. resultPrintJob . _entityVal . _printJobFilename - in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t) - , sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n + in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t) + , sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n , sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell @@ -201,7 +201,7 @@ mkPJTable = do ] dbtSorting = mconcat [ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) - , single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) + , single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) , single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) , single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , single ("pj-recipient" , sortUserNameBareM queryRecipient) @@ -213,16 +213,20 @@ mkPJTable = do [ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) , single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) , single ("pj-created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + --, single ("pj-created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName)) , single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName)) , single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName)) , single ("pj-qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName)) - , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) + , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName) , prismAForm (singletonFilter "pj-filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename) , prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) + --, prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) + -- <*> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) + -- ) , prismAForm (singletonFilter "pj-recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient) , prismAForm (singletonFilter "pj-sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender) , prismAForm (singletonFilter "pj-course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse) @@ -301,13 +305,13 @@ postPrintSendR = do -- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" uID <- maybeAuthId - runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing) >>= \case -- calls lpr + runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing) >>= \case -- calls lpr Left err -> do let msg = "PDF printing failed with error: " <> err $logErrorS "LPR" msg addMessage Error $ toHtml msg pure False - Right (ok, fpath) -> do + Right (ok, fpath) -> do let response = if null ok then mempty else " Response: " <> ok addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response pure True @@ -319,7 +323,7 @@ postPrintSendR = do pure False when (or oks) $ redirect PrintCenterR formResult sendResult procFormSend - -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute + -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute siteLayoutMsg MsgPrintManualRenewal $ do setTitleI MsgMenuPrintSend let sendForm = wrapForm sendWidget def diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 79a306756..7556085ca 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -137,4 +137,4 @@ randomLMSIdent = LmsIdent <$> randomText [] lengthIdent randomLMSpw :: MonadIO m => m Text randomLMSpw = randomText extra lengthPassword where - extra = "_-+*.:;=!?#" + extra = "-+*.:;=!?#$" diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a26776c30..13e9e703f 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -297,7 +297,7 @@ data FormIdentifier | FIDAllocationRegister | FIDAllocationNotification | FIDAvsQueryPerson - | FIDAvsQueryStatus + | FIDAvsQueryStatus | FIDLmsLetter deriving (Eq, Ord, Read, Show) diff --git a/templates/ldap.hamlet b/templates/ldap.hamlet new file mode 100644 index 000000000..a02df7d65 --- /dev/null +++ b/templates/ldap.hamlet @@ -0,0 +1,11 @@ +
+

+ LDAP Person Search: + ^{personForm} + $maybe answers <- mbLdapData +

+ Antwort: # +
+ $forall (lk, lv) <- answers +
#{show lk} +
#{show (fmap Text.decodeUtf8' lv)} From bb093b122105970d8a3dc6e2e94f42ab182f37fb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 14 Sep 2022 11:20:56 +0200 Subject: [PATCH 12/39] chore(release): 26.5.1 --- CHANGELOG.md | 2 ++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 7 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 76ab26d39..4703f0921 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [26.5.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.0...v26.5.1) (2022-09-14) + ## [26.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.4.0...v26.5.0) (2022-09-09) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index f54e8f744..fb3c40189 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "26.5.0" + "version": "26.5.1" } diff --git a/nix/docker/version.json b/nix/docker/version.json index f54e8f744..fb3c40189 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "26.5.0" + "version": "26.5.1" } diff --git a/package-lock.json b/package-lock.json index 99fbe45dc..1393d27b5 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.5.0", + "version": "26.5.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 171ed51bc..d1ba32815 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.5.0", + "version": "26.5.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index a2bc2c95e..514bc759a 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 26.5.0 +version: 26.5.1 dependencies: - base - yesod From ce277af443acfb773210d08908e93fd17d65c8a1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 14 Sep 2022 16:00:18 +0200 Subject: [PATCH 13/39] chore(ldap): add ldap parsing test to ldap admin route --- .../categories/authorization/de-de-formal.msg | 2 +- src/Foundation/Yesod/Auth.hs | 255 +++++++++--------- src/Handler/Admin/Ldap.hs | 15 +- 3 files changed, 147 insertions(+), 125 deletions(-) diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index fab2eb322..3f9d02ca2 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -106,7 +106,7 @@ PWHashLoginTitle: FRADrive Login PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden! DummyLoginTitle: Development-Login InternalLdapError: Interner Fehler beim Fraport Büko-Login -CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation +CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln CampusUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 0d74c98e5..fea6d250c 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -1,6 +1,7 @@ module Foundation.Yesod.Auth ( authenticate , upsertCampusUser + , decodeUserTest , CampusUserConversionException(..) , campusUserFailoverMode, updateUserLanguage ) where @@ -154,132 +155,16 @@ upsertCampusUser :: forall m. => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) upsertCampusUser upsertMode ldapData = do now <- liftIO getCurrentTime - UserDefaultConf{..} <- getsYesod $ view _appUserDefaults - - let - ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString - ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) - - -- only accept a single result, throw error otherwise - -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text - decodeLdap1 attr err - | [bs] <- ldapMap !!! attr - , Right t <- Text.decodeUtf8' bs - = return t - | otherwise = throwM err - - -- accept multiple successful decodings, ignoring all others - decodeLdapN attr err - | t@(_:_) <- rights vs - = return $ Text.unwords t - | otherwise = throwM err - where - vs = Text.decodeUtf8' <$> (ldapMap !!! attr) - - -- accept any successful decoding or empty; only throw an error if all decodings fail - -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text - decodeLdap' attr err - | [] <- vs = return Nothing - | (h:_) <- rights vs = return $ Just h - | otherwise = throwM err - where - vs = Text.decodeUtf8' <$> (ldapMap !!! attr) - - -- just returns Nothing on error, pure - decodeLdap :: Ldap.Attr -> Maybe Text - decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr - - userTelephone = decodeLdap ldapUserTelephone - userMobile = decodeLdap ldapUserMobile - userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer - userCompanyDepartment = decodeLdap ldapUserFraportAbteilung - - userAuthentication - | is _UpsertCampusUserLoginOther upsertMode - = error "Non-LDAP logins should only work for users that are already known" - | otherwise = AuthLDAP - userLastAuthentication = guardOn isLogin now - isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode - - userIdent <- if - | [bs] <- ldapMap !!! ldapUserPrincipalName - , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs - , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode - -> return userIdent' - | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent - -> return userIdent' - | otherwise - -> throwM CampusUserInvalidIdent - - userEmail <- if - | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) - -> return $ CI.mk userEmail - | otherwise - -> throwM CampusUserInvalidEmail - userFirstName <- decodeLdapN ldapUserFirstName CampusUserInvalidGivenName - userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname - userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle - - userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= - (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname) - - userLdapPrimaryKey <- if - | [bs] <- ldapMap !!! ldapPrimaryKey - , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs - , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey'' - -> return $ Just userLdapPrimaryKey''' - | otherwise - -> return Nothing - - let - newUser = User - { userMaxFavourites = userDefaultMaxFavourites - , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userShowSex = userDefaultShowSex - , userSex = Nothing - , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced - , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels - , userNotificationSettings = def - , userLanguages = Nothing - , userCsvOptions = def - , userTokensIssuedAfter = Nothing - , userCreated = now - , userLastLdapSynchronisation = Just now - , userDisplayName = userDisplayName' - , userDisplayEmail = userEmail - , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO - , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO - , userPinPassword = Nothing -- must be derived via AVS - , userPrefersPostal = False - , .. - } - userUpdate = [ - -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 - UserFirstName =. userFirstName - , UserSurname =. userSurname - , UserEmail =. userEmail - , UserLastLdapSynchronisation =. Just now - , UserLdapPrimaryKey =. userLdapPrimaryKey - , UserMobile =. userMobile - , UserTelephone =. userTelephone - , UserCompanyPersonalNumber =. userCompanyPersonalNumber - , UserCompanyDepartment =. userCompanyDepartment - ] ++ - [ UserLastAuthentication =. Just now | isLogin ] + userDefaultConf <- getsYesod $ view _appUserDefaults + (newUser@User{..},userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] user@(Entity userId userRec) <- case oldUsers of Just [oldUserId] -> updateGetEntity oldUserId userUpdate _other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate - unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ - update userId [ UserDisplayName =. userDisplayName' ] + unless (validDisplayName userTitle userFirstName userSurname $ userRec ^. _userDisplayName) $ + update userId [ UserDisplayName =. userDisplayName ] let userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' @@ -297,6 +182,136 @@ upsertCampusUser upsertMode ldapData = do return user +decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) + => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User])) +decodeUserTest mbIdent ldapData = do + now <- liftIO getCurrentTime + userDefaultConf <- getsYesod $ view _appUserDefaults + let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent + try $ decodeUser now userDefaultConf mode ldapData + + +decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_) +decodeUser now UserDefaultConf{..} upsertMode ldapData = do + let + userTelephone = decodeLdap ldapUserTelephone + userMobile = decodeLdap ldapUserMobile + userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer + userCompanyDepartment = decodeLdap ldapUserFraportAbteilung + + userAuthentication + | is _UpsertCampusUserLoginOther upsertMode + = error "Non-LDAP logins should only work for users that are already known" + | otherwise = AuthLDAP + userLastAuthentication = guardOn isLogin now + isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode + + userIdent <- if + | [bs] <- ldapMap !!! ldapUserPrincipalName + , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs + , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode + -> return userIdent' + | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent + -> return userIdent' + | otherwise + -> throwM CampusUserInvalidIdent + + userEmail <- if + | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) + -> return $ CI.mk userEmail + | otherwise + -> throwM CampusUserInvalidEmail + userFirstName <- decodeLdapN ldapUserFirstName CampusUserInvalidGivenName + userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname + userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle + + userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= + (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname) + + userLdapPrimaryKey <- if + | [bs] <- ldapMap !!! ldapPrimaryKey + , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs + , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey'' + -> return $ Just userLdapPrimaryKey''' + | otherwise + -> return Nothing + + let + newUser = User + { userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userShowSex = userDefaultShowSex + , userSex = Nothing + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels + , userNotificationSettings = def + , userLanguages = Nothing + , userCsvOptions = def + , userTokensIssuedAfter = Nothing + , userCreated = now + , userLastLdapSynchronisation = Just now + , userDisplayName = userDisplayName' + , userDisplayEmail = userEmail + , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO + , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO + , userPinPassword = Nothing -- must be derived via AVS + , userPrefersPostal = False + , .. + } + userUpdate = [ + -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 + UserFirstName =. userFirstName + , UserSurname =. userSurname + , UserEmail =. userEmail + , UserLastLdapSynchronisation =. Just now + , UserLdapPrimaryKey =. userLdapPrimaryKey + , UserMobile =. userMobile + , UserTelephone =. userTelephone + , UserCompanyPersonalNumber =. userCompanyPersonalNumber + , UserCompanyDepartment =. userCompanyDepartment + ] ++ + [ UserLastAuthentication =. Just now | isLogin ] + return (newUser, userUpdate) + + where + ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString + ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) + + -- only accept a single result, throw error otherwise + -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text + decodeLdap1 attr err + | [bs] <- ldapMap !!! attr + , Right t <- Text.decodeUtf8' bs + = return t + | otherwise = throwM err + + -- accept multiple successful decodings, ignoring all others + decodeLdapN attr err + | t@(_:_) <- rights vs + = return $ Text.unwords t + | otherwise = throwM err + where + vs = Text.decodeUtf8' <$> (ldapMap !!! attr) + + -- accept any successful decoding or empty; only throw an error if all decodings fail + -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text + decodeLdap' attr err + | [] <- vs = return Nothing + | (h:_) <- rights vs = return $ Just h + | otherwise = throwM err + where + vs = Text.decodeUtf8' <$> (ldapMap !!! attr) + + -- just returns Nothing on error, pure + decodeLdap :: Ldap.Attr -> Maybe Text + decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr + associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () associateUserSchoolsByTerms uid = do sfs <- selectList [StudyFeaturesUser ==. uid] [] diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs index 45c1f1bf7..13a40c501 100644 --- a/src/Handler/Admin/Ldap.hs +++ b/src/Handler/Admin/Ldap.hs @@ -8,9 +8,11 @@ module Handler.Admin.Ldap import Import -- import qualified Control.Monad.State.Class as State -- import Data.Aeson (encode) +import qualified Data.CaseInsensitive as CI -- import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -- import qualified Data.Set as Set +import Foundation.Yesod.Auth (decodeUserTest) import Handler.Utils @@ -47,13 +49,18 @@ postAdminLdapR = do ((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList [])) - procFormPerson LdapQueryPerson{..} = do - ldapPool' <- getsYesod $ view _appLdapPool + procFormPerson LdapQueryPerson{..} = do + ldapPool' <- getsYesod $ view _appLdapPool + if isNothing ldapPool' then addMessage Warning $ text2Html "LDAP Configuration missing." else addMessage Info $ text2Html "Input for LDAP test received." - fmap join . for ldapPool' $ \ldapPool -> - campusUser'' ldapPool FailoverUnlimited ldapQueryIdent + fmap join . for ldapPool' $ \ldapPool -> do + ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent + eitherErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData + whenIsLeft eitherErr $ addMessageI Error + return ldapData + mbLdapData <- formResultMaybe presult procFormPerson From cceb60074fbb26d7ed2d10a1c37297fa6e52292a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 14 Sep 2022 17:20:07 +0200 Subject: [PATCH 14/39] fix(lms): trigger userlist job after upload --- src/Handler/LMS/Userlist.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 25d57e3ed..ab904ba52 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -271,7 +271,7 @@ postLmsUserlistDirectR sid qsh = do Right nr -> do let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead $logWarnS "LMS" msg -- TODO: change to Info Level in the future - queueDBJob $ JobLmsResults qid + queueDBJob $ JobLmsUserlist qid return (ok200, msg) [] -> do let msg = "Userlist upload file missing." From ae182163314ddf473a917eb8f195967139028337 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 14 Sep 2022 17:20:48 +0200 Subject: [PATCH 15/39] chore(mail): add link to root to welcome letter --- .../categories/send/send_notifications/de-de-formal.msg | 2 ++ .../uniworx/categories/send/send_notifications/en-eu.msg | 2 ++ src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs | 3 ++- templates/mail/userAuthModeUpdate.hamlet | 5 +++++ 4 files changed, 11 insertions(+), 1 deletion(-) diff --git a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg index 88ef6d0a3..cb5f69e13 100644 --- a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg +++ b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg @@ -130,6 +130,8 @@ UserAuthModePWHashChangedToLDAP: Sie können sich nun mit Ihrer Fraport AG Kennu UserAuthModeLDAPChangedToPWHash: Sie können sich nun mit einer FRADrive-internen Kennung einloggen AuthPWHashTip: Sie müssen nun das mit "FRADrive-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden. PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail. +MailFradrive !ident-ok: FRADrive +MailBodyFradrive: die Führerscheinverwaltungsapp der Fraport AG. #userRightsUpdate.hs + templates MailSubjectUserRightsUpdate name@Text: Berechtigungen für #{name} aktualisiert diff --git a/messages/uniworx/categories/send/send_notifications/en-eu.msg b/messages/uniworx/categories/send/send_notifications/en-eu.msg index d9a207576..37aca5b64 100644 --- a/messages/uniworx/categories/send/send_notifications/en-eu.msg +++ b/messages/uniworx/categories/send/send_notifications/en-eu.msg @@ -130,6 +130,8 @@ UserAuthModePWHashChangedToLDAP: You can now log in to FRADrive using your Frapo UserAuthModeLDAPChangedToPWHash: You can now log in using your FRADrive-internal account AuthPWHashTip: You now need to use the login form labeled "FRADrive login". Please ensure that you have already set a password when you try to log in. PasswordResetEmailIncoming: For security reasons you will receive a link to the page on which you can set and later change your password in a separate email. +MailFradrive: FRADrive +MailBodyFradrive: the apron driving licence management app of Fraport AG. #userRightsUpdate.hs + templates MailSubjectUserRightsUpdate name: Permissions for #{name} changed diff --git a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs index 2c9064fad..602636a05 100644 --- a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs @@ -9,6 +9,7 @@ import Import import Auth.PWHash (PWHashMessage(..)) import Handler.Utils.Mail +-- import Handler.Utils.Widgets (simpleLink, simpleLinkI) import Jobs.Handler.SendNotification.Utils import Text.Hamlet @@ -21,6 +22,6 @@ dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient = us setSubjectI MsgMailSubjectUserAuthModeUpdate editNotifications <- ihamletSomeMessage <$> mkEditNotifications jRecipient - + -- let linkRoot :: Widget = simpleLink (text2widget "FRADrive") NewsR -- TODO: use MsgMailFradrive instead addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userAuthModeUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/templates/mail/userAuthModeUpdate.hamlet b/templates/mail/userAuthModeUpdate.hamlet index 10938a372..93941e626 100644 --- a/templates/mail/userAuthModeUpdate.hamlet +++ b/templates/mail/userAuthModeUpdate.hamlet @@ -19,6 +19,11 @@ $newline never _{SomeMessage MsgUserAuthModePWHashChangedToLDAP} $of AuthPWHash _ _{SomeMessage MsgUserAuthModeLDAPChangedToPWHash} +

+ + FRADrive + _{SomeMessage MsgMailBodyFradrive} + $if is _AuthPWHash userAuthentication

_{SomeMessage MsgAuthPWHashTip} From 3b7d4abd421fb22321be236409f1df4b4672fcc8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 14 Sep 2022 17:51:42 +0200 Subject: [PATCH 16/39] chore(lms): better link formatting in letter --- src/Jobs/Handler/SendNotification/Qualification.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index e555381ca..3b1b5a30b 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -77,7 +77,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do , mbMeta "address" (prepAddress <$> userPostAddress) , toMeta "expiry" expiryDate , mbMeta "validduration" (show <$> qualificationValidDuration) - , toMeta "url" ("") + , toMeta "url" ("[https://drive.fraport.de](https://drive.fraport.de/?login=" <> lmsIdent <> ")") ] pdfRenewal pdfMeta >>= \case Left err -> do From 44945068c47f6b3b247ca5fba735d1fa6796dd5d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 14 Sep 2022 17:52:19 +0200 Subject: [PATCH 17/39] chore(mail): fix build --- templates/mail/userAuthModeUpdate.hamlet | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/templates/mail/userAuthModeUpdate.hamlet b/templates/mail/userAuthModeUpdate.hamlet index 93941e626..79cf44dc6 100644 --- a/templates/mail/userAuthModeUpdate.hamlet +++ b/templates/mail/userAuthModeUpdate.hamlet @@ -21,7 +21,7 @@ $newline never _{SomeMessage MsgUserAuthModeLDAPChangedToPWHash}

- FRADrive + _{SomeMessage MsgMailFradrive} _{SomeMessage MsgMailBodyFradrive} $if is _AuthPWHash userAuthentication From 17f760a52203cab6335428e55846fdd98a4ff0c6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 14 Sep 2022 18:28:19 +0200 Subject: [PATCH 18/39] chore(release): 26.5.2 --- CHANGELOG.md | 7 +++++++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 12 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4703f0921..ea6a51fe1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [26.5.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.1...v26.5.2) (2022-09-14) + + +### Bug Fixes + +* **lms:** trigger userlist job after upload ([cceb600](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cceb60074fbb26d7ed2d10a1c37297fa6e52292a)) + ## [26.5.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.0...v26.5.1) (2022-09-14) ## [26.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.4.0...v26.5.0) (2022-09-09) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index fb3c40189..f1e917cd6 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "26.5.1" + "version": "26.5.2" } diff --git a/nix/docker/version.json b/nix/docker/version.json index fb3c40189..f1e917cd6 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "26.5.1" + "version": "26.5.2" } diff --git a/package-lock.json b/package-lock.json index 1393d27b5..3d7b885c8 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.5.1", + "version": "26.5.2", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index d1ba32815..2d1e3f407 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.5.1", + "version": "26.5.2", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 514bc759a..6666fe297 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 26.5.1 +version: 26.5.2 dependencies: - base - yesod From 4d375e76801ba6a52e0d20b0e2490ac81e8ea8dc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 15 Sep 2022 15:42:27 +0200 Subject: [PATCH 19/39] chore(lms): fix convenience link formatting in lms mails and pdf --- src/Jobs/Handler/SendNotification/Qualification.hs | 4 +++- templates/letter/fraport_renewal.md | 7 ++++--- templates/mail/userAuthModeUpdate.hamlet | 2 +- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 3b1b5a30b..5a963e4c8 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -66,6 +66,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient let printJobName = "RenewalPin" + lmsUrl = "https://drive.fraport.de" prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address lmsIdent = lmsUserIdent & getLmsIdent pdfMeta = mkMeta @@ -77,7 +78,8 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do , mbMeta "address" (prepAddress <$> userPostAddress) , toMeta "expiry" expiryDate , mbMeta "validduration" (show <$> qualificationValidDuration) - , toMeta "url" ("[https://drive.fraport.de](https://drive.fraport.de/?login=" <> lmsIdent <> ")") + , toMeta "url-text" lmsUrl + , toMeta "url" (lmsUrl <> "/?login=" <> lmsIdent) ] pdfRenewal pdfMeta >>= \case Left err -> do diff --git a/templates/letter/fraport_renewal.md b/templates/letter/fraport_renewal.md index 9c86edb03..a23833298 100644 --- a/templates/letter/fraport_renewal.md +++ b/templates/letter/fraport_renewal.md @@ -21,7 +21,8 @@ encludes: hyperrefoptions: hidelinks ### Metadaten, welche automatisch ersetzt werden: -url: +url-text: 'https://drive.fraport.de' +url: 'https://drive.fraport.de' date: 11.11.1111 expiry: 00.00.0000 lang: de-de @@ -66,7 +67,7 @@ Prüfling URL - : $url$ + : [$url-text$]($url$) Sobald die Frist abgelaufen ist, muss zur Wiedererlangung des Vorfeldführerscheins @@ -93,7 +94,7 @@ Examinee URL - : $url$ + :[$url-text$]($url$) Should your apron driving licence expire before completing this diff --git a/templates/mail/userAuthModeUpdate.hamlet b/templates/mail/userAuthModeUpdate.hamlet index 79cf44dc6..3ac3aeaf5 100644 --- a/templates/mail/userAuthModeUpdate.hamlet +++ b/templates/mail/userAuthModeUpdate.hamlet @@ -27,7 +27,7 @@ $newline never $if is _AuthPWHash userAuthentication

_{SomeMessage MsgAuthPWHashTip} -

+
_{SomeMessage MsgPWHashIdent}
From 4419245e17c3c8e40e8be76e2d2e30ab0f74e3ce Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 15 Sep 2022 15:42:55 +0200 Subject: [PATCH 20/39] refactor(ldap): make ldap response parsing way more lenient --- src/Foundation/Yesod/Auth.hs | 71 +++++++++++++++++++----------------- src/Handler/Admin/Ldap.hs | 10 +++-- src/Handler/Profile.hs | 2 + src/Handler/Utils/Profile.hs | 9 ++++- src/Utils.hs | 5 +++ templates/ldap.hamlet | 14 ++++--- 6 files changed, 68 insertions(+), 43 deletions(-) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index fea6d250c..5496155c1 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -206,6 +206,14 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do userLastAuthentication = guardOn isLogin now isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode + userTitle = decodeLdap ldapUserTitle -- CampusUserInvalidTitle + userFirstName = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName + userSurname = decodeLdap' ldapUserSurname -- CampusUserInvalidSurname + userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName + + --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= + -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname) + userIdent <- if | [bs] <- ldapMap !!! ldapUserPrincipalName , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs @@ -221,13 +229,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do -> return $ CI.mk userEmail | otherwise -> throwM CampusUserInvalidEmail - userFirstName <- decodeLdapN ldapUserFirstName CampusUserInvalidGivenName - userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname - userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle - - userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= - (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname) - + userLdapPrimaryKey <- if | [bs] <- ldapMap !!! ldapPrimaryKey , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs @@ -256,7 +258,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do , userTokensIssuedAfter = Nothing , userCreated = now , userLastLdapSynchronisation = Just now - , userDisplayName = userDisplayName' + , userDisplayName = userDisplayName , userDisplayEmail = userEmail , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO @@ -283,35 +285,38 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) - -- only accept a single result, throw error otherwise - -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text - decodeLdap1 attr err - | [bs] <- ldapMap !!! attr - , Right t <- Text.decodeUtf8' bs - = return t - | otherwise = throwM err - - -- accept multiple successful decodings, ignoring all others - decodeLdapN attr err - | t@(_:_) <- rights vs - = return $ Text.unwords t - | otherwise = throwM err - where - vs = Text.decodeUtf8' <$> (ldapMap !!! attr) - - -- accept any successful decoding or empty; only throw an error if all decodings fail - -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text - decodeLdap' attr err - | [] <- vs = return Nothing - | (h:_) <- rights vs = return $ Just h - | otherwise = throwM err - where - vs = Text.decodeUtf8' <$> (ldapMap !!! attr) - -- just returns Nothing on error, pure decodeLdap :: Ldap.Attr -> Maybe Text decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr + decodeLdap' :: Ldap.Attr -> Text + decodeLdap' = fromMaybe "" . decodeLdap + -- accept the first successful decoding or empty; only throw an error if all decodings fail + -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text) + -- decodeLdap' attr err + -- | [] <- vs = return Nothing + -- | (h:_) <- rights vs = return $ Just h + -- | otherwise = throwM err + -- where + -- vs = Text.decodeUtf8' <$> (ldapMap !!! attr) + + -- only accepts the first successful decoding, ignoring all others, but failing if there is none + -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text + decodeLdap1 attr err + | (h:_) <- rights vs = return h + | otherwise = throwM err + where + vs = Text.decodeUtf8' <$> (ldapMap !!! attr) + + -- accept and merge one or more successful decodings, ignoring all others + -- decodeLdapN attr err + -- | t@(_:_) <- rights vs + -- = return $ Text.unwords t + -- | otherwise = throwM err + -- where + -- vs = Text.decodeUtf8' <$> (ldapMap !!! attr) + + associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () associateUserSchoolsByTerms uid = do sfs <- selectList [StudyFeaturesUser ==. uid] [] diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs index 13a40c501..9f305fb37 100644 --- a/src/Handler/Admin/Ldap.hs +++ b/src/Handler/Admin/Ldap.hs @@ -9,7 +9,7 @@ import Import -- import qualified Control.Monad.State.Class as State -- import Data.Aeson (encode) import qualified Data.CaseInsensitive as CI --- import qualified Data.Text as Text +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -- import qualified Data.Set as Set import Foundation.Yesod.Auth (decodeUserTest) @@ -57,8 +57,8 @@ postAdminLdapR = do else addMessage Info $ text2Html "Input for LDAP test received." fmap join . for ldapPool' $ \ldapPool -> do ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent - eitherErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData - whenIsLeft eitherErr $ addMessageI Error + decodedErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData + whenIsLeft decodedErr $ addMessageI Error return ldapData @@ -72,6 +72,10 @@ postAdminLdapR = do { formAction = Just $ SomeRoute actionUrl , formEncoding = penctype } + + presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv) + presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv) + -- TODO: use i18nWidgetFile instead if this is to become permanent $(widgetFile "ldap") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index b014a6a4e..2d75f2ac1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -439,7 +439,9 @@ validateSettings :: User -> FormValidator SettingsForm Handler () validateSettings User{..} = do userDisplayName' <- use _stgDisplayName guardValidation MsgUserDisplayNameInvalid $ + userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved) validDisplayName userTitle userFirstName userSurname userDisplayName' + userPinPassword' <- use _stgPinPassword guardValidation MsgPDFPasswordInvalid $ diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 082048456..7732d66af 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -14,12 +14,16 @@ import qualified Data.Text.Lazy as LT import qualified Data.MultiSet as MultiSet import qualified Data.Set as Set +-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc. +stripFold :: Text -> Text +stripFold = Text.toCaseFold . Text.strip + -- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname". -- Input "givennames surname" is left unchanged, except for removing excess whitespace fixDisplayName :: UserDisplayName -> UserDisplayName fixDisplayName udn = let (Text.strip . Text.dropEnd 1 -> surname, Text.strip -> firstnames) = Text.breakOnEnd "," udn - in Text.strip $ firstnames <> Text.cons ' ' surname + in Text.toTitle $ Text.strip $ firstnames <> Text.cons ' ' surname -- | Like `validDisplayName` but may return an automatically corrected name checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName @@ -32,7 +36,7 @@ validDisplayName :: Maybe UserTitle -> UserSurname -> UserDisplayName -> Bool -validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -> sName) (Text.strip -> dName) +validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> sName) (stripFold -> dName) = and [ dNameFrags `MultiSet.isSubsetOf` MultiSet.unions [titleFrags, fNameFrags, sNameFrags] , sName `Text.isInfixOf` dName , all ((<= 1) . Text.length) . filter (Text.any isAdd) $ Text.group dName @@ -53,6 +57,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip - isAdd = (`Set.member` addLetters) splitAdd = Text.split isAdd makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd + -- | Primitive postal address requires at least one alphabetic character, one digit and a line break validPostAddress :: Maybe StoredMarkup -> Bool diff --git a/src/Utils.hs b/src/Utils.hs index 7c565484b..c9043998e 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -275,6 +275,11 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs stripAll :: Text -> Text stripAll = Text.filter (not . isSpace) +-- | strip leading and trailing whitespace and make case insensitive +-- also helps to avoid the need to import just for CI.mk +stripCI :: Text -> CI Text +stripCI = CI.mk . Text.strip + citext2lower :: CI Text -> Text citext2lower = Text.toLower . CI.original diff --git a/templates/ldap.hamlet b/templates/ldap.hamlet index a02df7d65..0b5873a55 100644 --- a/templates/ldap.hamlet +++ b/templates/ldap.hamlet @@ -3,9 +3,13 @@ LDAP Person Search: ^{personForm} $maybe answers <- mbLdapData -
+

Antwort: # -
- $forall (lk, lv) <- answers -
#{show lk} -
#{show (fmap Text.decodeUtf8' lv)} +
+ $forall (lk, lv) <- answers +
+ #{show lk} +
+ UTF8: #{presentUtf8 lv} + — + Latin: #{presentLatin1 lv} From bd539358bdbaadd496501918b2a66ce13ecf82ab Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 15 Sep 2022 18:44:53 +0200 Subject: [PATCH 21/39] refactor(lms): send user notifications only after lms acknowleged e-learning --- .../categories/qualification/de-de-formal.msg | 2 + .../categories/qualification/en-eu.msg | 2 + models/lms.model | 1 + src/Handler/LMS.hs | 13 +- src/Jobs/Handler/LMS.hs | 188 +++++++++--------- .../Handler/SendNotification/Qualification.hs | 6 +- test/Database/Fill.hs | 174 ++++++++-------- 7 files changed, 201 insertions(+), 185 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index bf0630997..1706eeef9 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -23,12 +23,14 @@ TableLmsDelete: Löschen? TableLmsStaff: Interner Mitarbeiter? TableLmsStarted: Begonnen TableLmsReceived: Letzte Rückmeldung +TableLmsNotified: Versand Benachrichtigung TableLmsEnded: Beended TableLmsStatus: Status E-Lernen TableLmsSuccess: Bestanden TableLmsFailed: Gesperrt FilterLmsValid: Aktuell gültig FilterLmsRenewal: Erneuerung anstehend +FilterLmsNotified: Benachrichtigt CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer CsvColumnLmsPin: PIN des E-Lernen Zugangs CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt? diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 9ac082788..6d89b424b 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -23,12 +23,14 @@ TableLmsDelete: Delete? TableLmsStaff: Staff? TableLmsStarted: Started TableLmsReceived: Last update +TableLmsNotified: Notification sent TableLmsEnded: Ended TableLmsStatus: Status e-learning TableLmsSuccess: Completed TableLmsFailed: Blocked FilterLmsValid: Currently valid FilterLmsRenewal: Renewal due +FilterLmsNotified: Notified CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user CsvColumnLmsPin: PIN for e-learning access CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation? diff --git a/models/lms.model b/models/lms.model index 986ee5d27..18466434b 100644 --- a/models/lms.model +++ b/models/lms.model @@ -100,6 +100,7 @@ LmsUser --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete started UTCTime default=now() received UTCTime Maybe -- last acknowledgement by LMS + notified UTCTime Maybe -- last notified by FRADrive ended UTCTime Maybe -- ident was deleted from LMS -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS! diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 292388fca..75284be67 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -343,6 +343,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) , single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin)) , single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) + , single ("lms-notified", SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) ] dbtFilter = mconcat @@ -356,12 +357,19 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | otherwise -> E.true ) + , single ("lms-notified", FilterColumn $ \(view (to queryLmsUser) -> luser) criterion -> + case getLast criterion of + Just True -> E.isJust $ luser E.?. LmsUserNotified + Just False -> E.isNothing $ luser E.?. LmsUserNotified + Nothing -> E.true + ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev - , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) - , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) ] @@ -446,6 +454,7 @@ postLmsR sid qsh = do , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d + , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d ] where diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index a23ca6467..37eae1275 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,15 +1,15 @@ {-# LANGUAGE TypeApplications #-} -module Jobs.Handler.LMS +module Jobs.Handler.LMS ( dispatchJobLmsQualificationsEnqueue , dispatchJobLmsQualificationsDequeue , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsDequeue , dispatchJobLmsResults , dispatchJobLmsUserlist - ) where + ) where -import Import +import Import import Jobs.Queue -- import Jobs.Handler.Intervals.Utils @@ -23,198 +23,196 @@ import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries) dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX -dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic act - where - act :: YesodJobDB UniWorX () - act = do - qids <- E.select $ do - q <- E.from $ E.table @Qualification - E.where_ $ E.isJust (q E.^. QualificationRefreshWithin) - -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless - pure $ q E.^. QualificationId - forM_ qids $ \(E.unValue -> qid) -> - queueDBJob $ JobLmsEnqueue qid +dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue + +dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX +dispatchJobLmsQualificationsDequeue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsDequeue + +-- execute given job for all qualifications that allow refreshs +fetchRefreshQualifications :: (QualificationId -> Job) -> YesodJobDB UniWorX () +fetchRefreshQualifications qidJob = do + qids <- E.select $ do + q <- E.from $ E.table @Qualification + E.where_ $ E.isJust (q E.^. QualificationRefreshWithin) + pure $ q E.^. QualificationId + forM_ qids $ \(E.unValue -> qid) -> + queueDBJob $ qidJob qid --- | enlist expiring qualification holders to e-learning +-- | enlist expiring qualification holders to e-learning -- NOTE: getting rid of QualificationId parameter and using a DB-join fails, since addGregorianDurationClip cannot be performed within DB dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX dispatchJobLmsEnqueue qid = JobHandlerAtomic act - where + where -- act :: YesodJobDB UniWorX () act = do - $logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "." + $logInfoS "lms" $ "Notifying about exipiring qualification " <> tshow qid <> "." quali <- getJust qid -- may throw an error, aborting the job - now <- liftIO getCurrentTime - case qualificationRefreshWithin quali of - Nothing -> return () -- no automatic scheduling for this qid + now <- liftIO getCurrentTime + case qualificationRefreshWithin quali of + Nothing -> return () -- no automatic scheduling for this qid (Just renewalPeriod) -> do let now_day = utctDay now renewalDate = addGregorianDurationClip renewalPeriod now_day renewalUsers <- E.select $ do - quser <- E.from $ E.table @QualificationUser - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + quser <- E.from $ E.table @QualificationUser + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate E.&&. E.notExists (do luser <- E.from $ E.table @LmsUser - E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid + E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser ) pure quser - let usr_job :: Entity QualificationUser -> Job - usr_job quser = - let uid = quser ^. _entityVal . _qualificationUserUser + let usr_job :: Entity QualificationUser -> Job + usr_job quser = + let uid = quser ^. _entityVal . _qualificationUserUser uex = quser ^. _entityVal . _qualificationUserValidUntil in if qualificationElearningStart quali then JobLmsEnqueueUser { jQualification = qid, jUser = uid } - else JobSendNotification { jRecipient = uid, jNotification = + else JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } forM_ renewalUsers (queueDBJob . usr_job) - case qualificationAuditDuration quali of + case qualificationAuditDuration quali of Nothing -> return () -- no automatic removal - (Just auditDuration) -> + (Just auditDuration) -> let deleteDate = addMonths auditDuration now in deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded >. Just deleteDate] dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX -dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act - where +dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act + where act :: YesodJobDB UniWorX () - act = do + act = do now <- liftIO getCurrentTime let mkLmsUser lid lpin = LmsUser { lmsUserQualification = qid - , lmsUserUser = uid - , lmsUserIdent = lid - , lmsUserPin = lpin - , lmsUserResetPin = False + , lmsUserUser = uid + , lmsUserIdent = lid + , lmsUserPin = lpin + , lmsUserResetPin = False , lmsUserDatePin = now , lmsUserStatus = Nothing - , lmsUserStarted = now + , lmsUserStarted = now , lmsUserReceived = Nothing - , lmsUserEnded = Nothing + , lmsUserNotified = Nothing + , lmsUserEnded = Nothing } -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) startLmsUser = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw) inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser - case inserted of + case inserted of Nothing -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!" - (Just _) -> queueDBJob JobSendNotification { jRecipient = uid, jNotification = - NotificationQualificationRenewal { nQualification = qid } - } + (Just _) -> return () -- lmsUser started, but not yet notified -dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX -dispatchJobLmsQualificationsDequeue = JobHandlerAtomic act - where - act :: YesodJobDB UniWorX () - act = do - qids <- E.select $ do - q <- E.from $ E.table @Qualification - E.where_ $ E.isJust (q E.^. QualificationRefreshWithin) - -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless - pure $ q E.^. QualificationId - forM_ qids $ \(E.unValue -> qid) -> - queueDBJob $ JobLmsEnqueue qid - +-- process all received input and renew qualifications dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX dispatchJobLmsDequeue qid = JobHandlerAtomic act - -- wenn bestanden: qualification verlängern + -- wenn bestanden: qualification verlängern -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart) - where + where act = do - $logInfoS "lms" $ "Process e-learning results for qualification " <> tshow qid <> "." + $logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "." quali <- getJust qid -- may throw an error, aborting the job - case qualificationRefreshWithin quali of - Nothing -> return () -- no automatic scheduling for this qid + case qualificationRefreshWithin quali of + Nothing -> return () -- no automatic scheduling for this qid (usually job is not scheduled for these qualifications, see above) (Just renewalPeriod) -> do now_day <- utctDay <$> liftIO getCurrentTime let renewalDate = addGregorianDurationClip renewalPeriod now_day - - -- CONTINUE HERE: + + -- CONTINUE HERE: TODO -- select users that need renewal due to success - -- delete users after audit period has expired + -- delete users after audit period has expired!!! renewalUsers <- E.select $ do (quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser `E.on` (\(quser E.:& luser) -> quser E.^. QualificationUserUser E.==. luser E.^. LmsUserUser E.&&. quser E.^. QualificationUserQualification E.==. luser E.^. LmsUserQualification ) - E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification - E.&&. E.val qid E.==. luser E.^. LmsUserQualification + E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification + E.&&. E.val qid E.==. luser E.^. LmsUserQualification E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day -- still valid E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate -- due to renewal - E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known + E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known pure (quser, luser) - let usr_job (quser, luser) = + let usr_job (quser, luser) = let vold = quser ^. _entityVal . _qualificationUserValidUntil - pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualification that have infinite validity?! + pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualifications that have infinite validity?! vnew = addGregorianDurationClip pmonth vold lmsstatus = luser ^. _entityVal . _lmsUserStatus - in case lmsstatus of - Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay] + in case lmsstatus of + Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay] _ -> return () forM_ renewalUsers usr_job +-- just processes received input, but does not affect any exisitng qualifications yet dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX -dispatchJobLmsResults qid = JobHandlerAtomic act +dispatchJobLmsResults qid = JobHandlerAtomic act where -- act :: YesodJobDB UniWorX () act = hoist lift $ do now <- liftIO getCurrentTime -- result :: [(Entity LmsUser, Entity LmsResult)] - results <- E.select $ do - (luser E.:& lresult) <- E.from $ - E.table @LmsUser `E.innerJoin` E.table @LmsResult - `E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent + results <- E.select $ do + (luser E.:& lresult) <- E.from $ + E.table @LmsUser `E.innerJoin` E.table @LmsResult + `E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners return (luser, lresult) - forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do + forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do -- three separate DB operations per result is not so nice. All within one transaction though. - let lreceived = lmsResultTimestamp lresult - newStatus = lmsResultSuccess lresult & LmsSuccess + let lreceived = lmsResultTimestamp lresult + newStatus = lmsResultSuccess lresult & LmsSuccess oldStatus = lmsUserStatus luser saneDate = lmsResultSuccess lresult `inBetween` (utctDay $ lmsUserStarted luser, utctDay now) -- always log success, since this is only transmitted once - if saneDate - then + if saneDate + then update luid [ LmsUserStatus =. (oldStatus <> Just newStatus) - , LmsUserReceived =. Just lreceived + , LmsUserReceived =. Just lreceived ] - else + else $logErrorS "LmsResult" [st|LMS success with insane date #{tshow (lmsResultSuccess lresult)} received|] insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now - delete lrid + delete lrid $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] + +-- just processes received input, but does not affect any exisitng qualifications yet dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX -dispatchJobLmsUserlist qid = JobHandlerAtomic act +dispatchJobLmsUserlist qid = JobHandlerAtomic act where - -- act :: YesodJobDB UniWorX () - act = hoist lift $ do + act :: YesodJobDB UniWorX () + act = do now <- liftIO getCurrentTime -- result :: [(Entity LmsUser, Entity LmsUserlist)] - results <- E.select $ do - (luser E.:& lulist) <- E.from $ + results <- E.select $ do + (luser E.:& lulist) <- E.from $ E.table @LmsUser `E.leftJoin` E.table @LmsUserlist - `E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent + `E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification) E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners return (luser, lulist) - forM_ results $ \case - (Entity luid luser, Nothing) - | isJust $ lmsUserReceived luser - , isNothing $ lmsUserEnded luser -> + forM_ results $ \case + (Entity luid luser, Nothing) + | isJust $ lmsUserReceived luser -- mark all unreported users as ended + , isNothing $ lmsUserEnded luser -> update luid [LmsUserEnded =. Just now] - | otherwise -> return () -- likely not yet started + | otherwise -> return () -- users likely not yet started - (Entity luid luser, Just (Entity lulid lulist)) -> do + (Entity luid luser, Just (Entity lulid lulist)) -> do + when (isNothing $ lmsUserNotified luser) $ -- notify users that lms is available + queueDBJob JobSendNotification + { jRecipient = lmsUserUser luser + , jNotification = NotificationQualificationRenewal { nQualification = qid } + } let lReceived = lmsUserlistTimestamp lulist isBlocked = lmsUserlistFailed lulist newStatus = LmsBlocked $ utctDay lReceived diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 5a963e4c8..f5e08f55c 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -49,7 +49,7 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use -- NOTE: qualificationRenewal expects that LmsUser already exists for recipient dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler () dispatchNotificationQualificationRenewal nQualification jRecipient = do - (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity _ LmsUser{..}) <- runDB $ (,,,) + (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity luid LmsUser{..}) <- runDB $ (,,,) <$> getJust jRecipient <*> getJust nQualification <*> getJustBy (UniqueQualificationUser nQualification jRecipient) @@ -120,5 +120,9 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do editNotifications <- mkEditNotifications jRecipient addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") + -- if we reach the end, mark the user as notified + -- TODO: defer this until the print job is marked as sent? + runDB $ + update luid [ LmsUserNotified =. Just now] \ No newline at end of file diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 61f80af29..bc556fb46 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -37,13 +37,13 @@ import Data.List (foldl) import System.Directory (getModificationTime, doesDirectoryExist) import System.FilePath.Glob (glob) -{- Needed for File Tests only +{- Needed for File Tests only import qualified Data.Conduit.Combinators as C import Paths_uniworx (getDataFileName) testdataFile :: MonadIO m => FilePath -> m FilePath testdataFile = liftIO . getDataFileName . ("testdata" ) - + insertFile :: ( HasFileReference fRef, PersistRecordBackend fRef SqlBackend ) => FileReferenceResidual fRef -> FilePath -> DB (Key fRef) insertFile residual fileTitle = do filepath <- testdataFile fileTitle @@ -60,25 +60,25 @@ fillDb = do let insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r) insert' = fmap (either entityKey id) . insertBy - - addBDays = addBusinessDays Fraport -- holiday area to use - n_day n = addBDays n $ utctDay now + + addBDays = addBusinessDays Fraport -- holiday area to use + n_day n = addBDays n $ utctDay now n_day' n = now { utctDay = n_day n } currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now - -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm + -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm nextTerm n = toEnum . (+n) $ fromEnum currentTerm - termTime :: TermIdentifier -- ^ Term - -> TermDay -- ^ Relative to which day? + termTime :: TermIdentifier -- ^ Term + -> TermDay -- ^ Relative to which day? -> Integer -- ^ Week offset from TermDayStart/End of Term (shuld be negative for TermDayEnd) -> Maybe WeekDay -- ^ Move to weekday -> (Day -> UTCTime) -- ^ Add time to day -> UTCTime termTime gTid gTD weekOffset mbWeekDay = ($ tDay) - where - gDay = addDays (7* weekOffset) $ guessDay gTid gTD - tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay - + where + gDay = addDays (7* weekOffset) $ guessDay gTid gTD + tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay + gkleen <- insert User { userIdent = "G.Kleen@campus.lmu.de" , userAuthentication = AuthLDAP @@ -107,9 +107,9 @@ fillDb = do , userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC } , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -145,9 +145,9 @@ fillDb = do , userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel } , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userMobile = Nothing - , userTelephone = Nothing - , userCompanyPersonalNumber = Nothing + , userMobile = Nothing + , userTelephone = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -227,9 +227,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -265,9 +265,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexNotApplicable , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -303,9 +303,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexFemale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -341,9 +341,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -409,9 +409,9 @@ fillDb = do , userCsvOptions = def , userSex = Nothing , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -426,7 +426,7 @@ fillDb = do Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|] matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel - + let tmin = -1 tmax = 2 trange = [tmin..tmax] @@ -434,21 +434,21 @@ fillDb = do dmax = guessDay (nextTerm tmax) TermDayEnd hdys = foldl (<>) mempty $ [bankHolidaysAreaSet Fraport y | y <- [getYear dmin..getYear dmax]] terms <- forM trange $ \nr -> do - let tid = nextTerm nr - tk = TermKey tid + let tid = nextTerm nr + tk = TermKey tid tStart = guessDay tid TermDayStart tEnd = guessDay tid TermDayEnd - term = Term { termName = tid + term = Term { termName = tid , termStart = tStart , termEnd = tEnd - , termHolidays = toList $ Set.filter (\d -> tStart <= d && d <= tEnd) hdys + , termHolidays = toList $ Set.filter (\d -> tStart <= d && d <= tEnd) hdys , termLectureStart = guessDay tid TermDayLectureStart , termLectureEnd = guessDay tid TermDayLectureEnd } - repsert tk term + repsert tk term insert_ $ TermActive tk (toMidnight $ termStart term) (Just . beforeMidnight $ termEnd term) Nothing return tk - + ifiAuthorshipStatement <- insertAuthorshipStatement I18n { i18nFallback = htmlToStoredMarkup [shamlet| @@ -501,8 +501,8 @@ fillDb = do let f_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] - let l_descr = Just $ htmlToStoredMarkup [shamlet|

für unhabilitierte|] - qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True + let l_descr = Just $ htmlToStoredMarkup [shamlet|

für unhabilitierte|] + qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3) False qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) -- TODO: better dates! @@ -516,17 +516,17 @@ fillDb = do void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) - void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now - void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now - void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now - void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now - void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now - void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now - void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing Nothing - void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing - void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing - void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing Nothing - void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-1)) + void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now + void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now + void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now + void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now + void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now + void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now + void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing Nothing Nothing + void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing Nothing + void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing Nothing + void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing (Just $ n_day' (-1)) Nothing + void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-2)) (Just $ n_day' (-1)) void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-1)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_f) @@ -535,7 +535,7 @@ fillDb = do void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-4)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_r) void . insert $ PrintJob "TestJob6" "job6" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing Nothing (Just qid_r) void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing Nothing Nothing - + let examLabels = Map.fromList @@ -718,19 +718,19 @@ fillDb = do now True Nothing - - + + -- Fahrschule F forM_ terms $ \tk -> do - let tid = unTermKey tk - jtt = (((Just .) .) .) . termTime tid + let tid = unTermKey tk + jtt = (((Just .) .) .) . termTime tid firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight - weekDay = dayOfWeek firstDay + weekDay = dayOfWeek firstDay -- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight capacity = Just 8 - mkName = CI.mk - do + mkName = CI.mk + do c <- insert' Course { courseName = mkName "Vorfeldführerschein" , courseDescription = Just $ htmlToStoredMarkup [shamlet| @@ -739,7 +739,7 @@ fillDb = do

Benötigte Unterlagen