From 841936178d091eb984a9dae7160873f86ba531a4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 23 Aug 2022 18:43:26 +0200 Subject: [PATCH 01/21] lpr: add system function printer --- models/users.model | 6 +++--- routes | 2 ++ src/Foundation/Authorization.hs | 9 +++++++++ src/Model/Types/User.hs | 1 + 4 files changed, 15 insertions(+), 3 deletions(-) diff --git a/models/users.model b/models/users.model index a3f4ba1bd..e4fe9d226 100644 --- a/models/users.model +++ b/models/users.model @@ -53,9 +53,9 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation deriving Generic UserSystemFunction user UserId - function SystemFunction - manual Bool - isOptOut Bool + function SystemFunction -- Defined in Model.Types.User + manual Bool -- Inserted manually by Admin or automatic from LDAP + isOptOut Bool -- User has currently deactivate the role for themselves UniqueUserSystemFunction user function deriving Generic UserExamOffice diff --git a/routes b/routes index 9c7b89ae8..d985255e4 100644 --- a/routes +++ b/routes @@ -9,6 +9,8 @@ -- -- Admins always have access to entities within their assigned schools. -- +-- Access tags are defined in Model.Types.Security +-- -- Access Tags: -- !free -- free for all -- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 6df5f3417..f77635ce8 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -555,6 +555,15 @@ tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False] guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice return Authorized +tagAccessPredicate AuthSystemPrinter = cacheAPSystemFunction SystemPrinter (Just $ Right diffHour) $ \mAuthId' _ _ printerList -> if + | maybe True (`Set.notMember` printerList) mAuthId' -> Right $ if + | is _Nothing mAuthId' -> return AuthenticationRequired + | otherwise -> unauthorizedI MsgUnauthorizedSystemPrinter + | otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isPrinter <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemPrinter, UserSystemFunctionIsOptOut ==. False] + guardMExceptT isPrinter $ unauthorizedI MsgUnauthorizedSystemPrinter + return Authorized tagAccessPredicate AuthStudent = cacheAPSystemFunction SystemStudent (Just $ Right diffHour) $ \mAuthId' _ _ studentList -> if | maybe True (`Set.notMember` studentList) mAuthId' -> Right $ if | is _Nothing mAuthId' -> return AuthenticationRequired diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index 1d32d639a..b5594ea38 100644 --- a/src/Model/Types/User.hs +++ b/src/Model/Types/User.hs @@ -11,6 +11,7 @@ data SystemFunction = SystemExamOffice | SystemFaculty | SystemStudent + | SystemPrinter deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite, Hashable, NFData) From 1ea047263cef7aea153b4b90a7cf7070bb2f1f32 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 24 Aug 2022 14:23:47 +0200 Subject: [PATCH 02/21] lpr: auth tag system-printer fully functional --- .../categories/authorization/de-de-formal.msg | 1 + .../uniworx/categories/authorization/en-eu.msg | 3 ++- .../categories/model_types/de-de-formal.msg | 1 + .../uniworx/categories/model_types/en-eu.msg | 1 + .../settings/auth_settings/de-de-formal.msg | 1 + .../settings/auth_settings/en-eu.msg | 1 + models/lms.model | 4 ++-- routes | 4 ++-- src/Handler/Course/Edit.hs | 2 +- src/Handler/Utils/LdapSystemFunctions.hs | 1 + .../Handler/SendNotification/Qualification.hs | 18 +++++++++++------- src/Model/Types/Languages.hs | 2 +- src/Model/Types/Security.hs | 1 + src/Utils/Lang.hs | 11 +++++++++++ 14 files changed, 37 insertions(+), 14 deletions(-) diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index 19764c991..fab2eb322 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -22,6 +22,7 @@ UnauthorizedExamOffice: Sie sind nicht mit Prüfungsverwaltung beauftragt. UnauthorizedExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:innen, für die Sie mit der Prüfungsverwaltung beauftragt sind. UnauthorizedSchoolExamOffice: Sie sind nicht mit Prüfungsverwaltung für dieses Institut beauftragt. UnauthorizedSystemExamOffice: Sie sind nicht mit systemweiter Prüfungsverwaltung beauftragt. +UnauthorizedSystemPrinter: Sie sind nicht mit systemweitem Druck und Briefversand beauftragt. UnauthorizedExternalExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:innen, für die Sie mit der Prüfungsverwaltung beauftragt sind. UnauthorizedEvaluation: Sie sind nicht mit der Kursumfragenverwaltung beauftragt. UnauthorizedAllocationAdmin: Sie sind nicht mit der Administration von Zentralanmeldungen beauftragt. diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index f2a64dbe9..f5e82dd4c 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -23,7 +23,8 @@ UnauthorizedEvaluation: You are not charged with course evaluation. UnauthorizedAllocationAdmin: You are not charged with the administration of central allocations. UnauthorizedExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam. UnauthorizedSchoolExamOffice: You are not part of an exam office for this school. -UnauthorizedSystemExamOffice: You are not charged with system wide exam administration +UnauthorizedSystemExamOffice: You are not charged with system wide exam administration. +UnauthorizedSystemPrinter: You are not charged with system wide letter printing. UnauthorizedExternalExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam. UnauthorizedSchoolLecturer: You are no lecturer for this department. UnauthorizedLecturer: You are no administrator for this course. diff --git a/messages/uniworx/categories/model_types/de-de-formal.msg b/messages/uniworx/categories/model_types/de-de-formal.msg index a3fd04ca8..fb611d0ab 100644 --- a/messages/uniworx/categories/model_types/de-de-formal.msg +++ b/messages/uniworx/categories/model_types/de-de-formal.msg @@ -14,3 +14,4 @@ BothSubmissions: Abgabe direkt in Uni2work oder extern mit Pseudonym SystemExamOffice: Prüfungsverwaltung SystemFaculty: Fakultätsmitglied SystemStudent: Student:in +SystemPrinter: Drucker:in diff --git a/messages/uniworx/categories/model_types/en-eu.msg b/messages/uniworx/categories/model_types/en-eu.msg index 2bbb34a44..dd0ec7f95 100644 --- a/messages/uniworx/categories/model_types/en-eu.msg +++ b/messages/uniworx/categories/model_types/en-eu.msg @@ -14,3 +14,4 @@ BothSubmissions: Submission either directly in Uni2work or externally via pseudo SystemExamOffice: Exam office SystemFaculty: Faculty member SystemStudent: Student +SystemPrinter: Printing staff \ No newline at end of file diff --git a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg index 8f9acaa70..95f1a6d85 100644 --- a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg @@ -9,6 +9,7 @@ AuthTagFree: Seite ist universell zugänglich AuthTagAdmin: Nutzer:in ist Administrator:in AuthTagExamOffice: Nutzer:in ist mit Prüfungsverwaltung beauftragt AuthTagSystemExamOffice: Nutzer:in ist mit systemweiter Prüfungsverwaltung beauftragt +AuthTagSystemPrinter: Nutzer:in ist mit systemweiten Druck von Briefen beauftragt AuthTagEvaluation: Nutzer:in ist mit Kursumfragenverwaltung beauftragt AuthTagAllocationAdmin: Nutzer:in ist mit der Administration von Zentralanmeldungen beauftragt AuthTagToken: Nutzer:in präsentiert Authorisierungs-Token diff --git a/messages/uniworx/categories/settings/auth_settings/en-eu.msg b/messages/uniworx/categories/settings/auth_settings/en-eu.msg index 1109b0c27..98dcfe1ac 100644 --- a/messages/uniworx/categories/settings/auth_settings/en-eu.msg +++ b/messages/uniworx/categories/settings/auth_settings/en-eu.msg @@ -9,6 +9,7 @@ AuthTagFree: Page is freely accessable AuthTagAdmin: User is administrator AuthTagExamOffice: User is part of an exam office AuthTagSystemExamOffice: User is charged with system wide exam administration +AuthTagSystemPrinter: User is responsible for system wide letter printing AuthTagEvaluation: User is charged with course evaluation AuthTagAllocationAdmin: User is charged with administration of central allocations AuthTagToken: User is presenting an authorisation-token diff --git a/models/lms.model b/models/lms.model index 8486ccc5a..0045f740b 100644 --- a/models/lms.model +++ b/models/lms.model @@ -1,10 +1,10 @@ Qualification -- INVARIANT: 2*refreshWithin < validDuration - school SchoolId --TODO: Ansprechpartner der Schule in Briefe erwähnen + school SchoolId --TODO: Ansprechpartner der Schule in Briefe erwähnen shorthand (CI Text) name (CI Text) description StoredMarkup Maybe -- user-defined large Html, ought to contain full description - validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months + validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months auditDuration Word Maybe -- number of month to keep audit log; or indefinitely refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry elearningStart Bool -- automatically schedule e-refresher diff --git a/routes b/routes index d985255e4..4563b0a5f 100644 --- a/routes +++ b/routes @@ -63,9 +63,9 @@ /admin/crontab AdminCrontabR GET /admin/avs AdminAvsR GET POST -/print PrintCenterR GET POST +/print PrintCenterR GET POST !system-printer /print/send PrintSendR GET POST -/print/download/#CryptoUUIDPrintJob PrintDownloadR GET +/print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer /health HealthR GET !free /instance InstanceR GET !free diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index a43db9ec1..b29115833 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -475,7 +475,7 @@ pgCEditR tid ssh csh = do -- | since an edit is identified via cfCourseId which is not contained in the received form data for security reasons! courseEditHandler :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Handler Html courseEditHandler miButtonAction mbCourseForm = do - aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! + aid <- requireAuthId ((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm miButtonAction mbCourseForm formResult result $ \case res@CourseForm diff --git a/src/Handler/Utils/LdapSystemFunctions.hs b/src/Handler/Utils/LdapSystemFunctions.hs index 913ddb503..e541a92e9 100644 --- a/src/Handler/Utils/LdapSystemFunctions.hs +++ b/src/Handler/Utils/LdapSystemFunctions.hs @@ -13,3 +13,4 @@ determineSystemFunctions ldapFuncs = \case SystemFaculty -> "CN=PROJ-Fahrerausbildung Admin_rw,OU=Projekte,OU=Sicherheitsgruppen,DC=fra,DC=fraport,DC=de" `Set.member` ldapFuncs -- Fahrerausbildungadmins are lecturers -- SJ: not sure this LDAP-specific key belongs here? SystemStudent -> False -- "student" `Set.member` ldapFuncs -- no such key identified at FraPort + SystemPrinter -> False -- "department=IFM-IS2" zu viele Mitglieder diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 2469d1f1d..d6837c5a2 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -38,22 +38,27 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet") -checkEmailOk :: a -> Bool +checkEmailOk :: User -> Bool checkEmailOk = const True -- TODO dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler () dispatchNotificationQualificationRenewal nQualification jRecipient = do - (User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- runDB $ (,,) + (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- runDB $ (,,) <$> getJust jRecipient <*> getJust nQualification <*> getJustBy (UniqueQualificationUser nQualification jRecipient) - let qname = CI.original qualificationName + let entRecipient = Entity jRecipient recipient + qname = CI.original qualificationName -- content = $(i18nWidgetFile "qualification/renewal") $logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " for renewal of qualification " <> qname + now <- liftIO getCurrentTime + letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient let pdfMeta = applyMetas - [ ("recipient", userDisplayName) + [ ("recipient", userDisplayName) + , ("date" , letterDate) + , ("lang" , selectDeEn userLanguages) -- select German or English, see Utils.Lang -- TODO: add more info to interpolate here! ] mempty pdfRenewal pdfMeta >>= \case @@ -61,7 +66,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do let msg = "Notify " <> tshow jRecipient <> " PDF generation failed with error: " <> err $logErrorS "LMS" msg error $ unpack msg - Right pdf | checkEmailOk userEmail -> userMailT jRecipient $ do + Right pdf | checkEmailOk recipient -> userMailT jRecipient $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectQualificationRenewal qname @@ -69,8 +74,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do editNotifications <- mkEditNotifications jRecipient -- TODO: add to hamlet file again -- let msgrenewal = $(i18nHamletFile "qualification/renewal") -- :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- addHtmlMarkdownAlternatives' msgrenewal - - now <- liftIO getCurrentTime + encryptPDF "tomatenmarmelade" pdf >>= \case Left err -> do let msg = "Notify " <> tshow jRecipient <> " PDF encryption failed with error: " <> err diff --git a/src/Model/Types/Languages.hs b/src/Model/Types/Languages.hs index 0f5568720..e9583795f 100644 --- a/src/Model/Types/Languages.hs +++ b/src/Model/Types/Languages.hs @@ -12,7 +12,7 @@ import Model.Types.TH.JSON import Control.Lens.TH (makeWrapped) -newtype Languages = Languages [Lang] +newtype Languages = Languages { getLanguages :: [Lang] } deriving (Eq, Ord, Show, Read, Generic, Typeable) deriving newtype (FromJSON, ToJSON, IsList) diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 5e2661150..dfa135002 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -75,6 +75,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthTutorControl | AuthExamOffice | AuthSystemExamOffice + | AuthSystemPrinter | AuthEvaluation | AuthAllocationAdmin | AuthAllocationRegistered diff --git a/src/Utils/Lang.hs b/src/Utils/Lang.hs index e5dc649e3..4168f4df3 100644 --- a/src/Utils/Lang.hs +++ b/src/Utils/Lang.hs @@ -2,6 +2,7 @@ module Utils.Lang where import ClassyPrelude.Yesod +import Model.Types.Languages import Utils.Cookies.Registered import Utils.Parameters import Utils.Session @@ -31,6 +32,16 @@ isDe = isPrefixOf "de" isEn :: Lang -> Bool isEn = isPrefixOf "en" +selectDeEn :: Maybe Languages -> Lang +selectDeEn = selectLanguage' availableLanguages . concatMap getLanguages + where + availableLanguages = "de" :| ["en"] -- for now, we only have german and english, with german being the default language + +selectEnDe :: Maybe Languages -> Lang +selectEnDe = selectLanguage' availableLanguages . concatMap getLanguages + where + availableLanguages = "en" :| ["de"] + selectLanguage :: MonadHandler m => NonEmpty Lang -- ^ Available translations, first is default -> m Lang From d3314b3e369af966a5be4788cc89c5974e0d5a9c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 24 Aug 2022 18:25:34 +0200 Subject: [PATCH 03/21] lpr: add postal address field to user table --- .../uniworx/categories/user/de-de-formal.msg | 2 ++ messages/uniworx/categories/user/en-eu.msg | 2 ++ models/users.model | 8 +++-- src/Foundation/Yesod/Auth.hs | 2 ++ src/Handler/PrintCenter.hs | 12 ++------ src/Handler/Users/Add.hs | 10 +++++-- src/Handler/Utils/Users.hs | 8 +++++ .../Handler/SendNotification/Qualification.hs | 29 ++++++++++--------- src/Model.hs | 1 + src/Model/Types/Markup.hs | 9 ++++-- src/Utils/Print.hs | 11 ++++++- test/Database/Fill.hs | 16 ++++++++++ 12 files changed, 80 insertions(+), 30 deletions(-) diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 0a7682d01..5559d44f7 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -12,6 +12,8 @@ AdminUserTelephone: Telefonnummer AdminUserMobile: Mobiltelefonmummer AdminUserFPersonalNumber: Personalnummer (nur Fraport AG) AdminUserFDepartment: Abteilung +AdminUserPostAddress: Postalische Anschrift +AdminUserPrefersPostal: Briefe anstatt Email bevorzugt AdminUserAssimilate: Benutzer assimilieren UserAdded: Benutzer erfolgreich angelegt UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 8e1a5c7bc..7d7645c15 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -12,6 +12,8 @@ AdminUserTelephone: Phone AdminUserMobile: Mobile AdminUserFPersonalNumber: Personalnumber (Fraport AG only) AdminUserFDepartment: Department +AdminUserPostAddress: Postal Address +AdminUserPrefersPostal: Prefers postal letters over email AdminUserAssimilate: Assimilate user UserAdded: Successfully added user UserCollision: Could not create user due to uniqueness constraint diff --git a/models/users.model b/models/users.model index e4fe9d226..38fb7334d 100644 --- a/models/users.model +++ b/models/users.model @@ -11,7 +11,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create surname UserSurname -- Display user names always through 'nameWidget displayName surname' displayName UserDisplayName displayEmail UserEmail - email UserEmail -- Case-insensitive eMail address + email UserEmail -- Case-insensitive eMail address -- TODO: make this nullable ident UserIdent -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date @@ -39,8 +39,10 @@ User json -- Each Uni2work user has a corresponding row in this table; create mobile Text Maybe companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available - examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default - examOfficeGetLabels Bool default=true -- whether labels should be displayed for exam results by default + postAddress StoredMarkup Maybe + prefersPostal Bool default=false -- user prefers letters by post instead of email + examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default + examOfficeGetLabels Bool default=true -- whether labels should be displayed for exam results by default UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 00d8227a0..25165ff0b 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -268,6 +268,8 @@ upsertCampusUser upsertMode ldapData = do , userDisplayEmail = userEmail , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO , userTitle = Nothing + , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO + , userPrefersPostal = False , .. } userUpdate = [ diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 6afaff9a2..87be13ffa 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -11,8 +11,8 @@ import Import import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT +-- import qualified Data.Text as T +-- import qualified Data.Text.Lazy as LT -- import qualified Data.ByteString.Lazy as LBS import qualified Text.Pandoc as P import qualified Text.Pandoc.Builder as P @@ -98,13 +98,7 @@ mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat where deOrEn = if isDe mppLang then "de" else "en" keyOpening = deOrEn <> "-opening" - keyClosing = deOrEn <> "-closing" - mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue - mbMeta = foldMap . toMeta - toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue - toMeta k = singletonMap k . P.toMetaValue - html2textlines :: StoredMarkup -> [Text] - html2textlines sm = T.lines . LT.toStrict $ markupInput sm + keyClosing = deOrEn <> "-closing" mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta mprToMetaUser entUser@Entity{entityVal = u} mpr = do diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 554f823b0..96d83ef72 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -23,6 +23,8 @@ data AdminUserForm = AdminUserForm , aufTelephone :: Maybe Text , aufFPersonalNumber :: Maybe Text , aufFDepartment :: Maybe Text + , aufPostAddress :: Maybe StoredMarkup + , aufPrefersPostal :: Bool , aufEmail :: UserEmail , aufIdent :: UserIdent , aufAuth :: AuthenticationKind @@ -56,7 +58,9 @@ adminUserForm template = renderAForm FormStandard <*> aopt (textField & cfStrip) (fslI MsgAdminUserMobile) (aufMobile <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserTelephone) (aufTelephone <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserFPersonalNumber) (aufFPersonalNumber <$> template) - <*> aopt (textField & cfStrip) (fslI MsgAdminUserFDepartment) (aufFDepartment <$> template) + <*> aopt (textField & cfStrip) (fslI MsgAdminUserFDepartment) (aufFDepartment <$> template) + <*> aopt htmlField (fslI MsgAdminUserPostAddress) (aufPostAddress <$> template) + <*> areq checkBoxField (fslI MsgAdminUserPrefersPostal) (aufPrefersPostal <$> template) <*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (aufEmail <$> template) <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template) <*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP) @@ -103,7 +107,9 @@ postAdminUserAddR = do , userMobile = aufMobile , userTelephone = aufTelephone , userCompanyPersonalNumber = aufFPersonalNumber - , userCompanyDepartment = aufFDepartment + , userCompanyDepartment = aufFDepartment + , userPostAddress = aufPostAddress + , userPrefersPostal = aufPrefersPostal , userMatrikelnummer = aufMatriculation , userAuthentication = mkAuthMode aufAuth } diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 06b3c80ac..7304904dc 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -8,6 +8,7 @@ module Handler.Utils.Users , guessUser , UserAssimilateException(..), UserAssimilateExceptionReason(..) , assimilateUser + , userPrefersEmail, userPrefersLetter ) where import Import @@ -40,6 +41,13 @@ import qualified Data.Text as Text import Jobs.Types(Job, JobChildren) +userPrefersLetter :: User -> Bool +userPrefersLetter User{..} = (userPrefersPostal || Text.null (CI.original userEmail)) && isJust userPostAddress + +userPrefersEmail :: User -> Bool +userPrefersEmail = not . userPrefersLetter + + computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 computeUserAuthenticationDigest = hashlazy . JSON.encode diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index d6837c5a2..d662a502d 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -9,6 +9,7 @@ import Import import Utils.Print import Handler.Utils +import Handler.Utils.Users import Jobs.Handler.SendNotification.Utils import qualified Data.ByteString.Lazy as LBS @@ -38,16 +39,14 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet") -checkEmailOk :: User -> Bool -checkEmailOk = const True -- TODO - - +-- NOTE: qualificationRenewal expects that LmsUser already exists for recipient dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler () dispatchNotificationQualificationRenewal nQualification jRecipient = do - (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- runDB $ (,,) + (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity _ LmsUser{..}) <- runDB $ (,,,) <$> getJust jRecipient <*> getJust nQualification - <*> getJustBy (UniqueQualificationUser nQualification jRecipient) + <*> getJustBy (UniqueQualificationUser nQualification jRecipient) + <*> getJustBy (UniqueLmsQualificationUser nQualification jRecipient) let entRecipient = Entity jRecipient recipient qname = CI.original qualificationName -- content = $(i18nWidgetFile "qualification/renewal") @@ -55,18 +54,22 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do now <- liftIO getCurrentTime letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient - let pdfMeta = applyMetas - [ ("recipient", userDisplayName) - , ("date" , letterDate) - , ("lang" , selectDeEn userLanguages) -- select German or English, see Utils.Lang - -- TODO: add more info to interpolate here! - ] mempty + + let prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address + pdfMeta = mkMeta + [ toMeta "date" letterDate + , toMeta "lang" $ selectDeEn userLanguages -- select German or English, see Utils.Lang + , toMeta "login" (lmsUserIdent & getLmsIdent) + , toMeta "pin" lmsUserPin + , toMeta "recipient" userDisplayName + , mbMeta "address" (prepAddress <$> userPostAddress) + ] pdfRenewal pdfMeta >>= \case Left err -> do let msg = "Notify " <> tshow jRecipient <> " PDF generation failed with error: " <> err $logErrorS "LMS" msg error $ unpack msg - Right pdf | checkEmailOk recipient -> userMailT jRecipient $ do + Right pdf | userPrefersEmail recipient -> userMailT jRecipient $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectQualificationRenewal qname diff --git a/src/Model.hs b/src/Model.hs index 6dc11066d..b5b6cb705 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -55,6 +55,7 @@ deriving newtype instance ToSample ExternalApiId -- required Show instances for use of getByJust deriving instance Show (Unique ExamPart) deriving instance Show (Unique QualificationUser) +deriving instance Show (Unique LmsUser) -- ToMarkup and ToMessage instances for displaying selected database primary keys diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index d4df4a060..6def79e59 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -5,7 +5,8 @@ module Model.Types.Markup , markdownToStoredMarkup , esqueletoMarkupOutput , I18nStoredMarkup - , markupIsSmallish + , markupIsSmallish + , html2textlines ) where import Import.NoModel @@ -148,4 +149,8 @@ type I18nStoredMarkup = I18n StoredMarkup -- | determine whether the StoredMarkup is small-ish markupIsSmallish :: StoredMarkup -> Bool -markupIsSmallish StoredMarkup{markupInput} = GT /= LT.compareLength markupInput 32 \ No newline at end of file +markupIsSmallish StoredMarkup{markupInput} = GT /= LT.compareLength markupInput 32 + + +html2textlines :: StoredMarkup -> [Text] +html2textlines sm = LT.toStrict <$> LT.lines (markupInput sm) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 26f45226c..faea7a2aa 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -38,7 +38,6 @@ templateDIN5008 :: Text templateDIN5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex") - ---------------------- -- Pandoc Functions -- ---------------------- @@ -68,6 +67,16 @@ _Meta = lens mget mput mget (P.Pandoc m _) = m mput (P.Pandoc _ b) m = P.Pandoc m b +toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue +toMeta k = singletonMap k . P.toMetaValue + +mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue +mbMeta = foldMap . toMeta + +-- | For convenience and to avoid importing Pandoc +mkMeta :: [Map Text P.MetaValue] -> P.Meta +mkMeta = P.Meta . mconcat + -- | Modify the Meta-Block of Pandoc appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 6797a3515..6ffc660b7 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -111,6 +111,8 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPostAddress = Nothing + , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } @@ -146,6 +148,8 @@ fillDb = do , userTelephone = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPostAddress = Nothing + , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } @@ -187,6 +191,8 @@ fillDb = do , userMobile = Just "0173 69 99 646" , userCompanyPersonalNumber = Just "57138" , userCompanyDepartment = Just "AVN-AR2" + , userPostAddress = Nothing + , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } @@ -222,6 +228,8 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPostAddress = Nothing + , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } @@ -257,6 +265,8 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPostAddress = Nothing + , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } @@ -292,6 +302,8 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPostAddress = Nothing + , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } @@ -327,6 +339,8 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPostAddress = Nothing + , userPrefersPostal = False , userExamOfficeGetSynced = False , userExamOfficeGetLabels = True } @@ -392,6 +406,8 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPostAddress = Nothing + , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } From 7f00455fbbed5f318ae3c5358f506767f446a2ab Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Aug 2022 16:54:36 +0200 Subject: [PATCH 04/21] refactor(ldap): correct invalid displaynames and improve ldap code --- src/Auth/LDAP.hs | 19 ++- src/Foundation/Yesod/Auth.hs | 112 ++++++++++-------- src/Handler/Utils/Profile.hs | 17 ++- .../Handler/SendNotification/Qualification.hs | 2 +- src/Utils.hs | 7 +- 5 files changed, 95 insertions(+), 62 deletions(-) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 75b8acfdb..e96b1a90d 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Auth.LDAP ( apLdap , ADError(..), ADInvalidCredentials(..) @@ -13,6 +15,7 @@ module Auth.LDAP , ldapAffiliation , ldapUserMobile, ldapUserTelephone , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung + , ldapUserTitle ) where import Import.NoFoundation @@ -30,6 +33,9 @@ import qualified Yesod.Auth.Message as Msg import Auth.LDAP.AD +-- allow Ldap.Attr usage as key for Data.Map +deriving newtype instance Ord Ldap.Attr + data CampusLogin = CampusLogin { campusIdent :: CI Text @@ -72,29 +78,20 @@ userSearchSettings LdapConf{..} = mconcat , Ldap.derefAliases Ldap.DerefAlways ] -ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserMobile, ldapUserTelephone, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr +ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone, ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr ldapPrimaryKey = Ldap.Attr "cn" -- should always be identical to "sAMAccountName" ldapUserPrincipalName = Ldap.Attr "userPrincipalName" ldapUserDisplayName = Ldap.Attr "displayName" ldapUserFirstName = Ldap.Attr "givenName" ldapUserSurname = Ldap.Attr "sn" ldapAffiliation = Ldap.Attr "memberOf" -- group determine user functions, see Handler.Utils.LdapSystemFunctions.determineSystemFunctions +ldapUserTitle = Ldap.Attr "title" -- not used at Fraport -- new ldapUserTelephone = Ldap.Attr "telephoneNumber" ldapUserMobile = Ldap.Attr "mobile" ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName" ldapUserFraportAbteilung = Ldap.Attr "department" -{- --outdated to be removed -ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" -ldapUserTitle = Ldap.Attr "title" -ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" -ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach" -ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" -ldapSex = Ldap.Attr "schacGender" -ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS" --} - ldapUserEmail :: NonEmpty Ldap.Attr ldapUserEmail = Ldap.Attr "mail" :| [ Ldap.Attr "userPrincipalName" diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 25165ff0b..7e1f7afc5 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -26,12 +26,13 @@ import qualified Control.Monad.Catch as C (Handler(..)) import qualified Ldap.Client as Ldap import qualified Data.Text as Text import qualified Data.Text.Encoding as Text --- import qualified Data.ByteString as ByteString +import qualified Data.ByteString as ByteString import qualified Data.Set as Set +import qualified Data.Map as Map -- import qualified Data.Conduit.Combinators as C -- import qualified Data.List as List ((\\)) - + -- import qualified Data.UUID as UUID -- import Data.ByteArray (convert) -- import Crypto.Hash (SHAKE128) @@ -112,7 +113,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend _other -> acceptExisting - + data CampusUserConversionException = CampusUserInvalidIdent | CampusUserInvalidEmail @@ -120,7 +121,7 @@ data CampusUserConversionException | CampusUserInvalidGivenName | CampusUserInvalidSurname | CampusUserInvalidTitle - | CampusUserInvalidMatriculation + | CampusUserInvalidMatriculation | CampusUserInvalidFeaturesOfStudy Text | CampusUserInvalidAssociatedSchools Text deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -155,22 +156,30 @@ upsertCampusUser upsertMode ldapData = do now <- liftIO getCurrentTime UserDefaultConf{..} <- getsYesod $ view _appUserDefaults - let - userEmail' = fold $ do - k' <- toList ldapUserEmail - (k, v) <- ldapData - guard $ k' == k - return v - -- SJ says: this highly repetitive code needs fefactoring; why not turn ldapData into a Data.Map right away instead of repetitive list iteration? - userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey ] - userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ] - userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ] - userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ] - userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ] - userTelephone' = fold [ v | (k, v) <- ldapData, k == ldapUserTelephone ] - userMobile' = fold [ v | (k, v) <- ldapData, k == ldapUserMobile ] - userFraportPersonalnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportPersonalnummer ] - userFraportAbteilung' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportAbteilung ] + let + ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] + ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) + userEmail' :: [Ldap.AttrValue] + userEmail' = lookupSome ldapMap $ toList ldapUserEmail + userLdapPrimaryKey' :: [Ldap.AttrValue] -- ~ [ByteString] + userLdapPrimaryKey' = ldapMap !!! ldapPrimaryKey + userIdent'' = ldapMap !!! ldapUserPrincipalName + userDisplayName'' = ldapMap !!! ldapUserDisplayName + -- userFirstName' = ldapMap !!! ldapUserFirstName + userSurname' = ldapMap !!! ldapUserSurname + userTitle' = ldapMap !!! ldapUserTitle + userTelephone' = ldapMap !!! ldapUserTelephone + userMobile' = ldapMap !!! ldapUserMobile + userFraportPersonalnummer' = ldapMap !!! ldapUserFraportPersonalnummer + userFraportAbteilung' = ldapMap !!! ldapUserFraportAbteilung + + -- TODO: continue here + 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 userAuthentication | is _UpsertCampusUserLoginOther upsertMode @@ -193,45 +202,55 @@ upsertCampusUser upsertMode ldapData = do -> return $ CI.mk userEmail | otherwise -> throwM CampusUserInvalidEmail - userDisplayName' <- if - | [bs] <- userDisplayName'' - , Right userDisplayName' <- Text.decodeUtf8' bs - -> return userDisplayName' - | otherwise - -> throwM CampusUserInvalidDisplayName - userFirstName <- if - | [bs] <- userFirstName' - , Right userFirstName <- Text.decodeUtf8' bs - -> return userFirstName - | otherwise - -> throwM CampusUserInvalidGivenName + userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName + --userFirstName <- if + -- | [bs] <- userFirstName' + -- , Right userFirstName <- Text.decodeUtf8' bs + -- -> return userFirstName + -- | otherwise + -- -> throwM CampusUserInvalidGivenName userSurname <- if | [bs] <- userSurname' , Right userSurname <- Text.decodeUtf8' bs -> return userSurname | otherwise -> throwM CampusUserInvalidSurname - userTelephone <- if + userTitle <- if + | [] <- userTitle' + -> return Nothing + | [bs] <- userTitle' + , Right userTitle <- Text.decodeUtf8' bs + -> return $ Just userTitle + | otherwise + -> throwM CampusUserInvalidTitle + userDisplayName' <- if + | [bs] <- userDisplayName'' + , Right userDisplayName1 <- Text.decodeUtf8' bs + , Just userDisplayName2 <- checkDisplayName userTitle userFirstName userSurname userDisplayName1 + -> return userDisplayName2 + | otherwise + -> throwM CampusUserInvalidDisplayName + userTelephone <- if | [bs] <- userTelephone' - , Right userTelephone <- Text.decodeUtf8' bs + , Right userTelephone <- Text.decodeUtf8' bs -> return $ Just userTelephone | otherwise -> return Nothing - userMobile <- if + userMobile <- if | [bs] <- userMobile' - , Right userMobile <- Text.decodeUtf8' bs + , Right userMobile <- Text.decodeUtf8' bs -> return $ Just userMobile | otherwise -> return Nothing - userCompanyPersonalNumber <- if + userCompanyPersonalNumber <- if | [bs] <- userFraportPersonalnummer' - , Right dt <- Text.decodeUtf8' bs + , Right dt <- Text.decodeUtf8' bs -> return $ Just dt | otherwise -> return Nothing - userCompanyDepartment <- if + userCompanyDepartment <- if | [bs] <- userFraportAbteilung' - , Right dt <- Text.decodeUtf8' bs + , Right dt <- Text.decodeUtf8' bs -> return $ Just dt | otherwise -> return Nothing @@ -266,17 +285,16 @@ upsertCampusUser upsertMode ldapData = do , userLastLdapSynchronisation = Just now , userDisplayName = userDisplayName' , userDisplayEmail = userEmail - , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO - , userTitle = Nothing + , 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 , userPrefersPostal = False , .. } - userUpdate = [ + userUpdate = [ -- UserDisplayName =. userDisplayName -- never updated, since users are allowed to change their DisplayName UserFirstName =. userFirstName - , UserSurname =. userSurname - , UserEmail =. userEmail + , UserSurname =. userSurname + , UserEmail =. userEmail , UserLastLdapSynchronisation =. Just now , UserLdapPrimaryKey =. userLdapPrimaryKey , UserMobile =. userMobile @@ -308,7 +326,7 @@ upsertCampusUser upsertMode ldapData = do if | preset -> void $ upsert (UserSystemFunction userId func False False) [] | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] - return user + return user associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () associateUserSchoolsByTerms uid = do @@ -322,7 +340,7 @@ associateUserSchoolsByTerms uid = do , userSchoolSchool = schoolTermsSchool , userSchoolIsOptOut = False } - + updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX , YesodAuth UniWorX , UserId ~ AuthId UniWorX diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 6c0037b6e..ed3894955 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -1,5 +1,7 @@ module Handler.Utils.Profile - ( validDisplayName + ( checkDisplayName + , validDisplayName + , fixDisplayName ) where import Import.NoFoundation @@ -8,7 +10,18 @@ import qualified Data.Text as Text import qualified Data.MultiSet as MultiSet import qualified Data.Set as Set +-- | 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 +-- | Like `validDisplayName` but may return an automatically corrected name +checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName +checkDisplayName mTitle fName sName (fixDisplayName -> dName) + | validDisplayName mTitle fName sName dName = Just dName + | otherwise = Nothing validDisplayName :: Maybe UserTitle -> UserFirstName @@ -31,7 +44,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip - fNameLetters = Set.fromList $ unpack fName sNameLetters = Set.fromList $ unpack sName dNameLetters = Set.fromList $ unpack dName - addLetters = Set.fromList [' ', ',', '.', '-'] + addLetters = Set.fromList [' ', '.', '-'] isAdd = (`Set.member` addLetters) splitAdd = Text.split isAdd diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index d662a502d..bdbc06155 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -58,7 +58,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do let prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address pdfMeta = mkMeta [ toMeta "date" letterDate - , toMeta "lang" $ selectDeEn userLanguages -- select German or English, see Utils.Lang + , toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang , toMeta "login" (lmsUserIdent & getLmsIdent) , toMeta "pin" lmsUserPin , toMeta "recipient" userDisplayName diff --git a/src/Utils.hs b/src/Utils.hs index d92f3f50f..9567d12c9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -654,6 +654,11 @@ infixl 5 !!! (!!!) :: (Ord k, Monoid v) => Map k v -> k -> v (!!!) m k = fromMaybe mempty $ Map.lookup k m +lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v +-- lookupSome :: Ord k => Map k [v] -> [k] -> [v] +-- lookupSome m ks = ks >>= (m !!!) +lookupSome = (=<<) . (!!!) + groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v) groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l] @@ -888,7 +893,7 @@ actLeft (Left x) f = f x actLeft (Right y) _ = pure $ Right y -- | like monadic bind for 'Either', but wrapped in another monad --- ok to use once, otherweise better to use 'Control.Monad.Trans.Except' instead +-- ok to use once, otherwise better to use 'Control.Monad.Trans.Except' instead actRight :: Applicative f => Either a b -> (b -> f (Either a c)) -> f (Either a c) actRight (Left x) _ = pure $ Left x actRight (Right y) f = f y From a804c985205c85bdd985a9f7e45dba73f843b77b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 26 Aug 2022 09:38:33 +0200 Subject: [PATCH 05/21] refactor(ldap): git merge problem --- src/Auth/LDAP.hs | 19 ++- src/Foundation/Yesod/Auth.hs | 112 ++++++++++-------- src/Handler/Utils/Profile.hs | 17 ++- .../Handler/SendNotification/Qualification.hs | 2 +- src/Utils.hs | 7 +- 5 files changed, 95 insertions(+), 62 deletions(-) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 75b8acfdb..e96b1a90d 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Auth.LDAP ( apLdap , ADError(..), ADInvalidCredentials(..) @@ -13,6 +15,7 @@ module Auth.LDAP , ldapAffiliation , ldapUserMobile, ldapUserTelephone , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung + , ldapUserTitle ) where import Import.NoFoundation @@ -30,6 +33,9 @@ import qualified Yesod.Auth.Message as Msg import Auth.LDAP.AD +-- allow Ldap.Attr usage as key for Data.Map +deriving newtype instance Ord Ldap.Attr + data CampusLogin = CampusLogin { campusIdent :: CI Text @@ -72,29 +78,20 @@ userSearchSettings LdapConf{..} = mconcat , Ldap.derefAliases Ldap.DerefAlways ] -ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserMobile, ldapUserTelephone, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr +ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone, ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr ldapPrimaryKey = Ldap.Attr "cn" -- should always be identical to "sAMAccountName" ldapUserPrincipalName = Ldap.Attr "userPrincipalName" ldapUserDisplayName = Ldap.Attr "displayName" ldapUserFirstName = Ldap.Attr "givenName" ldapUserSurname = Ldap.Attr "sn" ldapAffiliation = Ldap.Attr "memberOf" -- group determine user functions, see Handler.Utils.LdapSystemFunctions.determineSystemFunctions +ldapUserTitle = Ldap.Attr "title" -- not used at Fraport -- new ldapUserTelephone = Ldap.Attr "telephoneNumber" ldapUserMobile = Ldap.Attr "mobile" ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName" ldapUserFraportAbteilung = Ldap.Attr "department" -{- --outdated to be removed -ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" -ldapUserTitle = Ldap.Attr "title" -ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" -ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach" -ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" -ldapSex = Ldap.Attr "schacGender" -ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS" --} - ldapUserEmail :: NonEmpty Ldap.Attr ldapUserEmail = Ldap.Attr "mail" :| [ Ldap.Attr "userPrincipalName" diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 25165ff0b..16d309dbf 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -26,12 +26,13 @@ import qualified Control.Monad.Catch as C (Handler(..)) import qualified Ldap.Client as Ldap import qualified Data.Text as Text import qualified Data.Text.Encoding as Text --- import qualified Data.ByteString as ByteString +import qualified Data.ByteString as ByteString import qualified Data.Set as Set +import qualified Data.Map as Map -- import qualified Data.Conduit.Combinators as C -- import qualified Data.List as List ((\\)) - + -- import qualified Data.UUID as UUID -- import Data.ByteArray (convert) -- import Crypto.Hash (SHAKE128) @@ -112,7 +113,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend _other -> acceptExisting - + data CampusUserConversionException = CampusUserInvalidIdent | CampusUserInvalidEmail @@ -120,7 +121,7 @@ data CampusUserConversionException | CampusUserInvalidGivenName | CampusUserInvalidSurname | CampusUserInvalidTitle - | CampusUserInvalidMatriculation + | CampusUserInvalidMatriculation | CampusUserInvalidFeaturesOfStudy Text | CampusUserInvalidAssociatedSchools Text deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -155,22 +156,30 @@ upsertCampusUser upsertMode ldapData = do now <- liftIO getCurrentTime UserDefaultConf{..} <- getsYesod $ view _appUserDefaults - let - userEmail' = fold $ do - k' <- toList ldapUserEmail - (k, v) <- ldapData - guard $ k' == k - return v - -- SJ says: this highly repetitive code needs fefactoring; why not turn ldapData into a Data.Map right away instead of repetitive list iteration? - userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey ] - userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ] - userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ] - userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ] - userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ] - userTelephone' = fold [ v | (k, v) <- ldapData, k == ldapUserTelephone ] - userMobile' = fold [ v | (k, v) <- ldapData, k == ldapUserMobile ] - userFraportPersonalnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportPersonalnummer ] - userFraportAbteilung' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportAbteilung ] + let + ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] + ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) + userEmail' :: [Ldap.AttrValue] + userEmail' = lookupSome ldapMap $ toList ldapUserEmail + userLdapPrimaryKey' :: [Ldap.AttrValue] -- ~ [ByteString] + userLdapPrimaryKey' = ldapMap !!! ldapPrimaryKey + userIdent'' = ldapMap !!! ldapUserPrincipalName + userDisplayName'' = ldapMap !!! ldapUserDisplayName + -- userFirstName' = ldapMap !!! ldapUserFirstName + userSurname' = ldapMap !!! ldapUserSurname + userTitle' = ldapMap !!! ldapUserTitle + userTelephone' = ldapMap !!! ldapUserTelephone + userMobile' = ldapMap !!! ldapUserMobile + userFraportPersonalnummer' = ldapMap !!! ldapUserFraportPersonalnummer + userFraportAbteilung' = ldapMap !!! ldapUserFraportAbteilung + + -- TODO: continue here + decodeLdap1 :: _hole -- (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 userAuthentication | is _UpsertCampusUserLoginOther upsertMode @@ -193,45 +202,55 @@ upsertCampusUser upsertMode ldapData = do -> return $ CI.mk userEmail | otherwise -> throwM CampusUserInvalidEmail - userDisplayName' <- if - | [bs] <- userDisplayName'' - , Right userDisplayName' <- Text.decodeUtf8' bs - -> return userDisplayName' - | otherwise - -> throwM CampusUserInvalidDisplayName - userFirstName <- if - | [bs] <- userFirstName' - , Right userFirstName <- Text.decodeUtf8' bs - -> return userFirstName - | otherwise - -> throwM CampusUserInvalidGivenName + userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName + --userFirstName <- if + -- | [bs] <- userFirstName' + -- , Right userFirstName <- Text.decodeUtf8' bs + -- -> return userFirstName + -- | otherwise + -- -> throwM CampusUserInvalidGivenName userSurname <- if | [bs] <- userSurname' , Right userSurname <- Text.decodeUtf8' bs -> return userSurname | otherwise -> throwM CampusUserInvalidSurname - userTelephone <- if + userTitle <- if + | [] <- userTitle' + -> return Nothing + | [bs] <- userTitle' + , Right userTitle <- Text.decodeUtf8' bs + -> return $ Just userTitle + | otherwise + -> throwM CampusUserInvalidTitle + userDisplayName' <- if + | [bs] <- userDisplayName'' + , Right userDisplayName1 <- Text.decodeUtf8' bs + , Just userDisplayName2 <- checkDisplayName userTitle userFirstName userSurname userDisplayName1 + -> return userDisplayName2 + | otherwise + -> throwM CampusUserInvalidDisplayName + userTelephone <- if | [bs] <- userTelephone' - , Right userTelephone <- Text.decodeUtf8' bs + , Right userTelephone <- Text.decodeUtf8' bs -> return $ Just userTelephone | otherwise -> return Nothing - userMobile <- if + userMobile <- if | [bs] <- userMobile' - , Right userMobile <- Text.decodeUtf8' bs + , Right userMobile <- Text.decodeUtf8' bs -> return $ Just userMobile | otherwise -> return Nothing - userCompanyPersonalNumber <- if + userCompanyPersonalNumber <- if | [bs] <- userFraportPersonalnummer' - , Right dt <- Text.decodeUtf8' bs + , Right dt <- Text.decodeUtf8' bs -> return $ Just dt | otherwise -> return Nothing - userCompanyDepartment <- if + userCompanyDepartment <- if | [bs] <- userFraportAbteilung' - , Right dt <- Text.decodeUtf8' bs + , Right dt <- Text.decodeUtf8' bs -> return $ Just dt | otherwise -> return Nothing @@ -266,17 +285,16 @@ upsertCampusUser upsertMode ldapData = do , userLastLdapSynchronisation = Just now , userDisplayName = userDisplayName' , userDisplayEmail = userEmail - , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO - , userTitle = Nothing + , 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 , userPrefersPostal = False , .. } - userUpdate = [ + userUpdate = [ -- UserDisplayName =. userDisplayName -- never updated, since users are allowed to change their DisplayName UserFirstName =. userFirstName - , UserSurname =. userSurname - , UserEmail =. userEmail + , UserSurname =. userSurname + , UserEmail =. userEmail , UserLastLdapSynchronisation =. Just now , UserLdapPrimaryKey =. userLdapPrimaryKey , UserMobile =. userMobile @@ -308,7 +326,7 @@ upsertCampusUser upsertMode ldapData = do if | preset -> void $ upsert (UserSystemFunction userId func False False) [] | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] - return user + return user associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () associateUserSchoolsByTerms uid = do @@ -322,7 +340,7 @@ associateUserSchoolsByTerms uid = do , userSchoolSchool = schoolTermsSchool , userSchoolIsOptOut = False } - + updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX , YesodAuth UniWorX , UserId ~ AuthId UniWorX diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 6c0037b6e..ed3894955 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -1,5 +1,7 @@ module Handler.Utils.Profile - ( validDisplayName + ( checkDisplayName + , validDisplayName + , fixDisplayName ) where import Import.NoFoundation @@ -8,7 +10,18 @@ import qualified Data.Text as Text import qualified Data.MultiSet as MultiSet import qualified Data.Set as Set +-- | 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 +-- | Like `validDisplayName` but may return an automatically corrected name +checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName +checkDisplayName mTitle fName sName (fixDisplayName -> dName) + | validDisplayName mTitle fName sName dName = Just dName + | otherwise = Nothing validDisplayName :: Maybe UserTitle -> UserFirstName @@ -31,7 +44,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip - fNameLetters = Set.fromList $ unpack fName sNameLetters = Set.fromList $ unpack sName dNameLetters = Set.fromList $ unpack dName - addLetters = Set.fromList [' ', ',', '.', '-'] + addLetters = Set.fromList [' ', '.', '-'] isAdd = (`Set.member` addLetters) splitAdd = Text.split isAdd diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index d662a502d..bdbc06155 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -58,7 +58,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do let prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address pdfMeta = mkMeta [ toMeta "date" letterDate - , toMeta "lang" $ selectDeEn userLanguages -- select German or English, see Utils.Lang + , toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang , toMeta "login" (lmsUserIdent & getLmsIdent) , toMeta "pin" lmsUserPin , toMeta "recipient" userDisplayName diff --git a/src/Utils.hs b/src/Utils.hs index d92f3f50f..9567d12c9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -654,6 +654,11 @@ infixl 5 !!! (!!!) :: (Ord k, Monoid v) => Map k v -> k -> v (!!!) m k = fromMaybe mempty $ Map.lookup k m +lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v +-- lookupSome :: Ord k => Map k [v] -> [k] -> [v] +-- lookupSome m ks = ks >>= (m !!!) +lookupSome = (=<<) . (!!!) + groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v) groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l] @@ -888,7 +893,7 @@ actLeft (Left x) f = f x actLeft (Right y) _ = pure $ Right y -- | like monadic bind for 'Either', but wrapped in another monad --- ok to use once, otherweise better to use 'Control.Monad.Trans.Except' instead +-- ok to use once, otherwise better to use 'Control.Monad.Trans.Except' instead actRight :: Applicative f => Either a b -> (b -> f (Either a c)) -> f (Either a c) actRight (Left x) _ = pure $ Left x actRight (Right y) f = f y From 5f65e68b26b3c1125cb34361ece25f7ba20d3111 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 26 Aug 2022 11:54:43 +0200 Subject: [PATCH 06/21] refactor(ldap): completed refactoring, userDisplayName no longer contains a comma --- src/Foundation/Yesod/Auth.hs | 152 +++++++++++++---------------------- 1 file changed, 56 insertions(+), 96 deletions(-) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index de23399eb..675fe7cce 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -157,29 +157,34 @@ upsertCampusUser upsertMode ldapData = do UserDefaultConf{..} <- getsYesod $ view _appUserDefaults let - ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] + ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) - userEmail' :: [Ldap.AttrValue] - userEmail' = lookupSome ldapMap $ toList ldapUserEmail - userLdapPrimaryKey' :: [Ldap.AttrValue] -- ~ [ByteString] - userLdapPrimaryKey' = ldapMap !!! ldapPrimaryKey - userIdent'' = ldapMap !!! ldapUserPrincipalName - userDisplayName'' = ldapMap !!! ldapUserDisplayName - -- userFirstName' = ldapMap !!! ldapUserFirstName - userSurname' = ldapMap !!! ldapUserSurname - userTitle' = ldapMap !!! ldapUserTitle - userTelephone' = ldapMap !!! ldapUserTelephone - userMobile' = ldapMap !!! ldapUserMobile - userFraportPersonalnummer' = ldapMap !!! ldapUserFraportPersonalnummer - userFraportAbteilung' = ldapMap !!! ldapUserFraportAbteilung - -- TODO: continue here - -- decodeLdap1 :: (Exception e) => Ldap.Attr -> e -> m Text + -- 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 + | otherwise = throwM err + + -- 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 @@ -189,7 +194,7 @@ upsertCampusUser upsertMode ldapData = do isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode userIdent <- if - | [bs] <- userIdent'' + | [bs] <- ldapMap !!! ldapUserPrincipalName , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode -> return userIdent' @@ -197,66 +202,21 @@ upsertCampusUser upsertMode ldapData = do -> return userIdent' | otherwise -> throwM CampusUserInvalidIdent + userEmail <- if - | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail' + | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -> return $ CI.mk userEmail | otherwise -> throwM CampusUserInvalidEmail userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName - --userFirstName <- if - -- | [bs] <- userFirstName' - -- , Right userFirstName <- Text.decodeUtf8' bs - -- -> return userFirstName - -- | otherwise - -- -> throwM CampusUserInvalidGivenName - userSurname <- if - | [bs] <- userSurname' - , Right userSurname <- Text.decodeUtf8' bs - -> return userSurname - | otherwise - -> throwM CampusUserInvalidSurname - userTitle <- if - | [] <- userTitle' - -> return Nothing - | [bs] <- userTitle' - , Right userTitle <- Text.decodeUtf8' bs - -> return $ Just userTitle - | otherwise - -> throwM CampusUserInvalidTitle - userDisplayName' <- if - | [bs] <- userDisplayName'' - , Right userDisplayName1 <- Text.decodeUtf8' bs - , Just userDisplayName2 <- checkDisplayName userTitle userFirstName userSurname userDisplayName1 - -> return userDisplayName2 - | otherwise - -> throwM CampusUserInvalidDisplayName - userTelephone <- if - | [bs] <- userTelephone' - , Right userTelephone <- Text.decodeUtf8' bs - -> return $ Just userTelephone - | otherwise - -> return Nothing - userMobile <- if - | [bs] <- userMobile' - , Right userMobile <- Text.decodeUtf8' bs - -> return $ Just userMobile - | otherwise - -> return Nothing - userCompanyPersonalNumber <- if - | [bs] <- userFraportPersonalnummer' - , Right dt <- Text.decodeUtf8' bs - -> return $ Just dt - | otherwise - -> return Nothing - userCompanyDepartment <- if - | [bs] <- userFraportAbteilung' - , Right dt <- Text.decodeUtf8' bs - -> return $ Just dt - | otherwise - -> return Nothing + userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname + userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle + + userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= + (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname) userLdapPrimaryKey <- if - | [bs] <- userLdapPrimaryKey' + | [bs] <- ldapMap !!! ldapPrimaryKey , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey'' -> return $ Just userLdapPrimaryKey''' @@ -265,33 +225,33 @@ upsertCampusUser upsertMode ldapData = do 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 - , userPrefersPostal = False + { 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 + , userPrefersPostal = False , .. } userUpdate = [ - -- UserDisplayName =. userDisplayName -- never updated, since users are allowed to change their DisplayName + -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 UserFirstName =. userFirstName , UserSurname =. userSurname , UserEmail =. userEmail @@ -309,7 +269,7 @@ upsertCampusUser upsertMode ldapData = do user@(Entity userId userRec) <- case oldUsers of Just [oldUserId] -> updateGetEntity oldUserId userUpdate _other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate - unless (validDisplayName Nothing userFirstName userSurname $ userDisplayName userRec) $ + unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ update userId [ UserDisplayName =. userDisplayName' ] let From 8417eb57c9b8324cee81cbd16ff72f6039757a8e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 26 Aug 2022 14:29:46 +0200 Subject: [PATCH 07/21] feat(utils): throwLeftWith to facilitate ldap code --- src/Utils.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Utils.hs b/src/Utils.hs index 9567d12c9..259cfea21 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -883,6 +883,11 @@ whenIsRight (Left _) _ = pure () throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a throwLeft = either throwM return +throwLeftWith :: (MonadThrow m, Exception e) => e -> Either b a -> m a +-- throwLeftWith e = either (const $ throwM e) return +throwLeftWith _ (Right x) = return x +throwLeftWith e (Left _) = throwM e + {- Just a reminder for Steffen: mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft = over _Left From 188f101eed9f3c9f6ccf6458fdfcfba341ab44d8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 30 Aug 2022 18:25:52 +0200 Subject: [PATCH 08/21] test(user): add new field to fix build --- test/ModelSpec.hs | 4 +++- test/User.hs | 2 ++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 78c26ef54..2df4b3958 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -130,8 +130,10 @@ instance Arbitrary User where userShowSex <- arbitrary userMobile <- fmap pack . assertM' (not . null) <$> listOf (elements $ [' ', '+', '-', '/', '_'] ++ ['0'..'9']) userTelephone <- fmap pack . assertM' (not . null) <$> listOf (elements $ [' ', '+', '-', '/', '_'] ++ ['0'..'9']) - userCompanyPersonalNumber <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9']) + userCompanyPersonalNumber <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9']) userCompanyDepartment <- arbitrary + userPostAddress <- arbitrary -- TODO: not a good address + userPrefersPostal <- arbitrary userExamOfficeGetSynced <- arbitrary userExamOfficeGetLabels <- arbitrary diff --git a/test/User.hs b/test/User.hs index a35906532..597f126e7 100644 --- a/test/User.hs +++ b/test/User.hs @@ -49,3 +49,5 @@ fakeUser adjUser = adjUser User{..} userTelephone = Nothing userCompanyPersonalNumber = Nothing userCompanyDepartment = Nothing + userPostAddress = Nothing + userPrefersPostal = False From f8afca0598d03073e4200ba9c7946eec2b509d04 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 30 Aug 2022 18:27:39 +0200 Subject: [PATCH 09/21] feat(avs): add extraction functions for avs datatypes and tests --- models/users.model | 1 + .../Handler/SendNotification/Qualification.hs | 2 +- src/Model/Types.hs | 1 + src/Model/Types/Avs.hs | 281 ++++++++++++++++++ src/Utils.hs | 13 +- src/Utils/Avs.hs | 194 +----------- test/Utils/TypesSpec.hs | 26 +- 7 files changed, 317 insertions(+), 201 deletions(-) create mode 100644 src/Model/Types/Avs.hs diff --git a/models/users.model b/models/users.model index 38fb7334d..9eff01c9f 100644 --- a/models/users.model +++ b/models/users.model @@ -39,6 +39,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create mobile Text Maybe companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available + -- pinPassword Text Maybe -- used to encrypt pins within emails postAddress StoredMarkup Maybe prefersPostal Bool default=false -- user prefers letters by post instead of email examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index bdbc06155..f0b6f567d 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -78,7 +78,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do -- let msgrenewal = $(i18nHamletFile "qualification/renewal") -- :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- addHtmlMarkdownAlternatives' msgrenewal - encryptPDF "tomatenmarmelade" pdf >>= \case + encryptPDF "tomatenmarmelade" pdf >>= \case -- TODO: replace with user password! Left err -> do let msg = "Notify " <> tshow jRecipient <> " PDF encryption failed with error: " <> err $logErrorS "LMS" msg diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 3dfb4bb7d..b488193db 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -25,5 +25,6 @@ import Model.Types.Room as Types import Model.Types.Csv as Types import Model.Types.Upload as Types import Model.Types.Lms as Types +import Model.Types.Avs as Types import Model.Types.Communication as Types import Model.Types.SystemMessage as Types diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs new file mode 100644 index 000000000..569403d5b --- /dev/null +++ b/src/Model/Types/Avs.hs @@ -0,0 +1,281 @@ +{-| +Module: Model.Types.Avs +Description: Types for interface to AusweisVerwaltungsSystem (AVS) +-} + +module Model.Types.Avs + ( module Model.Types.Avs + ) where + +import Import.NoModel hiding ((.=)) +--import Utils.Lens hiding ((.=)) + +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.HashMap.Lazy as HM + +import Data.Aeson +import Data.Aeson.Types + + +-- | Like (.:) but attempts parsing with case-insensitve keys as fallback. +-- Note that the type also works for an optional field +-- Taken from Data.Aeson.Filthy, which could somehow not be added as a dependency. +(.:~) :: FromJSON a => Object -> Text -> Parser a +o .:~ key = o .: key <|> maybe empty parseJSON go + where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o] + +{- +-- Like (.:?) but attempts parsing with case-insensitve keys as fallback. +(.:?~) :: FromJSON a => Object -> Text -> Parser (Maybe a) +o .:?~ key = o .: key <|> maybe empty parseJSON go + where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o] +-} + +-- | `SloppyBool` successfully parses different variations of true/false +newtype SloppyBool = SloppyBool { sloppyBool :: Bool } + deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable) + +instance ToJSON SloppyBool where + toJSON (SloppyBool True) = "true" + toJSON _ = "false" + +instance FromJSON SloppyBool where + parseJSON (Bool b) = pure $ SloppyBool b + parseJSON (String t) + | lowb == "true" = true + | lowb == "t" = true + | lowb == "f" = false + | lowb == "false" = false + where lowb = Text.toLower $ Text.strip t + true = pure $ SloppyBool True + false = pure $ SloppyBool False + parseJSON invalid = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid + + +type AvsPersonId = Int + + +type AvsLicence = Char +licenceVorfeld :: AvsLicence +licenceVorfeld = 'F' +licenceRollfeld :: AvsLicence +licenceRollfeld = 'R' + + +data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance ToJSON AvsDataCardColor where + toJSON AvsCardColorGrün = "Grün" + toJSON AvsCardColorBlau = "Blau" + toJSON AvsCardColorRot = "Rot" + toJSON AvsCardColorGelb = "Gelb" + toJSON (AvsCardColorMisc t) = String t + +instance FromJSON AvsDataCardColor where + parseJSON (String t) = case Text.toLower t of + "grün" -> pure AvsCardColorGrün + "blau" -> pure AvsCardColorBlau + "rot" -> pure AvsCardColorRot + "gelb" -> pure AvsCardColorGelb + _ -> pure $ AvsCardColorMisc t + parseJSON invalid = prependFailure "parsing AvsDataCardColor failed, " (typeMismatch "String" invalid) + +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 + , 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 + , avsDataCardNo :: Text -- always 8 digits + , avsDataVersionNo :: Text + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +{- Automatically derived Ord instance should prioritize avsDataValid and avsDataValidTo. Checked in test/Model.TypesSpec +instance Ord AvsDataPersonCard where + compare a b = + compareBy avsDataValid + <> compareBy avsDataValidTo + <> compareBy avsDataIssueDate + <> compareBy avsDataCardAreas + ... + where + compareBy f = compare `on` f a b + -} + +{- Instead of programming entirely by hand, why not dump splices and adjust? -} +instance FromJSON AvsDataPersonCard where + parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard + <$> ((v .: "Valid") <&> sloppyBool) + <*> v .:? "ValidTo" + <*> v .:? "IssueDate" + <*> ((v .: "CardAreas") <&> charSet) + <*> v .:? "Street" + <*> v .:? "PostalCode" + <*> v .:? "City" + <*> v .:? "Firm" + <*> v .: "CardColor" + <*> v .: "CardNo" + <*> v .: "VersionNo" + +instance ToJSON AvsDataPersonCard where + toJSON AvsDataPersonCard{..} = object + [ "CardAreas" .= Set.foldl Text.snoc Text.empty avsDataCardAreas + , "CardColor" .= avsDataCardColor + , "CardNo" .= avsDataCardNo + , "VersionNo" .= avsDataVersionNo + , "Valid" .= show avsDataValid + , "ValidTo" .= avsDataValidTo + , "IssueDate" .= avsDataIssueDate + , "Firm" .= avsDataFirm + , "City" .= avsDataCity + , "Street" .= avsDataStreet + , "PostalCode" .= avsDataPostalCode + ] + +data AvsStatusPerson = AvsStatusPerson + { avsStatusPersonID :: AvsPersonId + , avsStatusPersonCardStatus :: Set AvsDataPersonCard + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + +deriveJSON defaultOptions + { fieldLabelModifier = \case { "avsStatusPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others } + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsStatusPerson + +data AvsDataPerson = AvsDataPerson + { avsPersonFirstName :: Text + , avsPersonLastName :: Text + , avsPersonInternalPersonalNo :: Maybe Text -- Fraport Personalnummer + , avsPersonPersonNo :: AvsPersonId -- AVS Personennummer + , avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle! + , avsPersonPersonCards :: Set AvsDataPersonCard + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = \case { "avsPersonPersonCards" -> "personCards"; others -> dropCamel 2 others } + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsDataPerson + + + +-------------- +-- Responses -- +--------------- + +newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = dropCamel 2 + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsResponseStatus + +newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = dropCamel 2 + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsResponsePerson + +------------- +-- Queries -- +------------- +data AvsQueryPerson = AvsQueryPerson + { avsPersonQueryCardNo :: Maybe Text + , avsPersonQueryFirstName :: Maybe Text + , avsPersonQueryLastName :: Maybe Text + , avsPersonQueryInternalPersonalNo :: Maybe Text + , avsPersonQueryVersionNo :: Maybe Text + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Default AvsQueryPerson where + def = AvsQueryPerson Nothing Nothing Nothing Nothing Nothing + +deriveJSON defaultOptions + { fieldLabelModifier = dropCamel 3 + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsQueryPerson + +newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions ''AvsQueryStatus + + +----------------------- +-- Utility Functions -- +----------------------- + +-- | retrieve AvsDataPersonCard with longest validity for a given licence, +-- first argument is a lower bound for avsDataValidTo, usually current day +-- Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case) +getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard +getValidLicence cutoff licence cards = Set.lookupMax validLicenceCards + where + validLicenceCards = Set.filter cardMatch cards + cardMatch AvsDataPersonCard{..} = + avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) + +guessLicencseAddress :: Set AvsDataPersonCard -> Maybe Text +guessLicencseAddress cards + | Just c <- Set.lookupMax cards + , AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards + , Just street <- avsDataStreet + , Just pcode <- avsDataPostalCode + , Just city <- avsDataCity + = Just $ Text.unlines [street, Text.unwords [pcode, city]] + | otherwise = Nothing + +hasAddress :: AvsDataPersonCard -> Bool +hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode + +pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard +pickLicenceAddress a b + | Just r <- pickBetter' hasAddress = r -- prefer card with complete address + | 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 + | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date + | avsDataIssueDate a < avsDataIssueDate b = b + | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date + | avsDataValidTo a < avsDataValidTo b = b + | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm + | a <= b = b -- respect natural Ord instance + | otherwise = a + where + pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard + pickBetter' = pickBetter a b + +{- Note: + +Since Ordering is a Semigroup that ignores the righthand side except for EQ, this can be conveniently be used like so + +bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering + compare a b = + compareBy avsDataValid + <> compareBy avsDataValidTo + <> compareBy avsDataIssueDate + + where + compareBy f = compare `on` f a b + +-} \ No newline at end of file diff --git a/src/Utils.hs b/src/Utils.hs index 259cfea21..7c565484b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -883,10 +883,6 @@ whenIsRight (Left _) _ = pure () throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a throwLeft = either throwM return -throwLeftWith :: (MonadThrow m, Exception e) => e -> Either b a -> m a --- throwLeftWith e = either (const $ throwM e) return -throwLeftWith _ (Right x) = return x -throwLeftWith e (Left _) = throwM e {- Just a reminder for Steffen: mapLeft :: (a -> c) -> Either a b -> Either c b @@ -1588,6 +1584,15 @@ maxOn = maxBy . comparing inBetween:: Ord a => a -> (a,a) -> Bool inBetween x (lower,upper) = lower <= x && x <= upper +-- | Given to values and a criterion, returns the unique argument that fulfills the criterion, if it exists +pickBetter :: a -> a -> (a -> Bool) -> Maybe a +pickBetter x y crit + | cx == cy = Nothing + | cx = Just x + | otherwise = Just y + where + cx = crit x + cy = crit y ------------ -- Random -- diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 0c5f93544..0b52818ea 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -3,203 +3,11 @@ module Utils.Avs where import Import.NoModel hiding ((.=)) import Utils.Lens hiding ((.=)) -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.HashMap.Lazy as HM - -import Data.Aeson -import Data.Aeson.Types - import Servant import Servant.Client import Servant.Client.Core (requestPath) - - --- | Like (.:) but attempts parsing with case-insensitve keys as fallback. --- Note that the type also works for an optional field --- Taken from Data.Aeson.Filthy, which could somehow not be added as a dependency. -(.:~) :: FromJSON a => Object -> Text -> Parser a -o .:~ key = o .: key <|> maybe empty parseJSON go - where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o] - -{- --- Like (.:?) but attempts parsing with case-insensitve keys as fallback. -(.:?~) :: FromJSON a => Object -> Text -> Parser (Maybe a) -o .:?~ key = o .: key <|> maybe empty parseJSON go - where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o] --} - -newtype SloppyBool = SloppyBool { sloppyBool :: Bool } - deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable) - -instance ToJSON SloppyBool where - toJSON (SloppyBool True) = "true" - toJSON _ = "false" - -instance FromJSON SloppyBool where - parseJSON (Bool b) = pure $ SloppyBool b - parseJSON (String t) - | lowb == "true" = true - | lowb == "t" = true - | lowb == "f" = false - | lowb == "false" = false - where lowb = Text.toLower $ Text.strip t - true = pure $ SloppyBool True - false = pure $ SloppyBool False - parseJSON invalid = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid - -type AvsPersonId = Int - -data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -instance ToJSON AvsDataCardColor where - toJSON AvsCardColorGrün = "Grün" - toJSON AvsCardColorBlau = "Blau" - toJSON AvsCardColorRot = "Rot" - toJSON AvsCardColorGelb = "Gelb" - toJSON (AvsCardColorMisc t) = String t - -instance FromJSON AvsDataCardColor where - parseJSON (String t) = case Text.toLower t of - "grün" -> pure AvsCardColorGrün - "blau" -> pure AvsCardColorBlau - "rot" -> pure AvsCardColorRot - "gelb" -> pure AvsCardColorGelb - _ -> pure $ AvsCardColorMisc t - parseJSON invalid = prependFailure "parsing AvsDataCardColor failed, " (typeMismatch "String" invalid) - -data AvsDataPersonCard = AvsDataPersonCard - { avsDataCardAreas :: Set Char -- logically a set of upper-case letters - , avsDataCardColor :: AvsDataCardColor - , avsDataCardNo :: Text -- always 8 digits - , avsDataVersionNo :: Text - , avsDataValid :: Bool -- unfortunately, AVS encodes Booleans as JSON String "true" and "false" and not as JSON Booleans - -- only the above are contained in AvsResponseStatus - , avsDataValidTo :: Maybe Day - , avsDataIssueDate :: Maybe Day - , avsDataFirm :: Maybe Text - , avsDataCity :: Maybe Text - , avsDataStreet :: Maybe Text - , avsDataPostalCode:: Maybe Text - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -{- Instead of programming entirely by hand, why not dump splices and adjust? -} -instance FromJSON AvsDataPersonCard where - parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard - <$> ((v .: "CardAreas") <&> charSet) - <*> v .: "CardColor" - <*> v .: "CardNo" - <*> v .: "VersionNo" - <*> ((v .: "Valid") <&> sloppyBool) - <*> v .:? "ValidTo" - <*> v .:? "IssueDate" - <*> v .:? "Firm" - <*> v .:? "City" - <*> v .:? "Street" - <*> v .:? "PostalCode" - - -instance ToJSON AvsDataPersonCard where - toJSON AvsDataPersonCard{..} = object - [ "CardAreas" .= Set.foldl Text.snoc Text.empty avsDataCardAreas - , "CardColor" .= avsDataCardColor - , "CardNo" .= avsDataCardNo - , "VersionNo" .= avsDataVersionNo - , "Valid" .= show avsDataValid - , "ValidTo" .= avsDataValidTo - , "IssueDate" .= avsDataIssueDate - , "Firm" .= avsDataFirm - , "City" .= avsDataCity - , "Street" .= avsDataStreet - , "PostalCode" .= avsDataPostalCode - ] - -data AvsStatusPerson = AvsStatusPerson - { avsStatusPersonID :: AvsPersonId - , avsStatusPersonCardStatus :: Set AvsDataPersonCard - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - - -deriveJSON defaultOptions - { fieldLabelModifier = \case { "avsStatusPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others } - , omitNothingFields = True - , tagSingleConstructors = False - , rejectUnknownFields = False - } ''AvsStatusPerson - -data AvsDataPerson = AvsDataPerson - { avsPersonFirstName :: Text - , avsPersonLastName :: Text - , avsPersonInternalPersonalNo :: Maybe Text -- Fraport Personalnummer - , avsPersonPersonNo :: AvsPersonId -- AVS Personennummer - , avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle! - , avsPersonPersonCards :: Set AvsDataPersonCard - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = \case { "avsPersonPersonCards" -> "personCards"; others -> dropCamel 2 others } - , omitNothingFields = True - , tagSingleConstructors = False - , rejectUnknownFields = False - } ''AvsDataPerson - - - --------------- --- Responses -- ---------------- - -newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) - deriving (Eq, Ord, Read, Show, Generic, Typeable) -deriveJSON defaultOptions - { fieldLabelModifier = dropCamel 2 - , omitNothingFields = True - , tagSingleConstructors = False - , rejectUnknownFields = False - } ''AvsResponseStatus - -newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) - deriving (Eq, Ord, Read, Show, Generic, Typeable) -deriveJSON defaultOptions - { fieldLabelModifier = dropCamel 2 - , omitNothingFields = True - , tagSingleConstructors = False - , rejectUnknownFields = False - } ''AvsResponsePerson - - - -------------- --- Queries -- -------------- -data AvsQueryPerson = AvsQueryPerson - { avsPersonQueryCardNo :: Maybe Text - , avsPersonQueryFirstName :: Maybe Text - , avsPersonQueryLastName :: Maybe Text - , avsPersonQueryInternalPersonalNo :: Maybe Text - , avsPersonQueryVersionNo :: Maybe Text - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -instance Default AvsQueryPerson where - def = AvsQueryPerson Nothing Nothing Nothing Nothing Nothing - -deriveJSON defaultOptions - { fieldLabelModifier = dropCamel 3 - , omitNothingFields = True - , tagSingleConstructors = False - , rejectUnknownFields = False - } ''AvsQueryPerson - -newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) - deriving (Eq, Ord, Read, Show, Generic, Typeable) -deriveJSON defaultOptions ''AvsQueryStatus - +import Model.Types.Avs ------------- diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index 12432f194..420169580 100644 --- a/test/Utils/TypesSpec.hs +++ b/test/Utils/TypesSpec.hs @@ -2,10 +2,8 @@ module Utils.TypesSpec where import TestImport -import Utils.Avs - -instance Arbitrary AvsDataCardColor where +instance Arbitrary AvsDataCardColor where arbitrary = genericArbitrary shrink = genericShrink @@ -41,6 +39,8 @@ instance Arbitrary AvsQueryPerson where spec :: Spec spec = do parallel $ do + lawsCheckHspec (Proxy @AvsDataPersonCard) + [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ] lawsCheckHspec (Proxy @AvsResponsePerson) [ eqLaws, showLaws, showReadLaws, jsonLaws] lawsCheckHspec (Proxy @AvsResponseStatus) @@ -49,3 +49,23 @@ spec = do [ eqLaws, showLaws, showReadLaws, jsonLaws] lawsCheckHspec (Proxy @AvsQueryStatus) [ eqLaws, showLaws, showReadLaws, jsonLaws] + + describe "Ord AvsDataCard" $ do + it "prioritises avsDataValid" . property $ + \p0 p1@AvsDataPersonCard{avsDataValid=v1} -> + let p2@AvsDataPersonCard{avsDataValid=v2} = p0 in + (v1 /= v2) ==> compare p1 p2 == compare v1 v2 + it "prioritises avsDataValidTo after avsDataValid" . property $ + \p0 p1@AvsDataPersonCard{avsDataValid=v1, avsDataValidTo=t1} -> + let p2@AvsDataPersonCard{avsDataValidTo=t2} = p0{avsDataValid=v1} in + (t1 /= t2) ==> compare p1 p2 == compare t1 t2 + it "prioritises avsDataIssueDate after avsDataValid and avsDataValidTo" . property $ + \p0 p1@AvsDataPersonCard{avsDataValid=v1, avsDataValidTo=t1, avsDataIssueDate=d1} -> + let p2@AvsDataPersonCard{avsDataIssueDate=d2} = p0{avsDataValid=v1, avsDataValidTo=t1} in + (d1 /= d2) ==> compare p1 p2 == compare d1 d2 + {- naive implementations discards too many tests in order to produce a meaningful result: + it "prioritises avsDataIssueDate after avsDataValid and avsDataValidTo" . property $ + \p1@AvsDataPersonCard{avsDataValid=v1, avsDataValidTo=t1, avsDataIssueDate=d1} + p2@AvsDataPersonCard{avsDataValid=v2, avsDataValidTo=t2, avsDataIssueDate=d2} -> + (v1 == v2 && t1 == t2 && d1 /= d2) ==> compare p1 p2 == compare d1 d2 + -} From a0d64dff3a520bf993a64e04da0c4ad1347b14e4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 31 Aug 2022 10:12:27 +0200 Subject: [PATCH 10/21] test(SemVer): fix Arbitrary SemVer.Version to account for invalid Ord instance --- 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 24f5bc4d2..ed98ad9b5 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -363,7 +363,7 @@ instance Arbitrary SemVer.Version where <*> fmap getNonNegative arbitrary <*> fmap getNonNegative arbitrary <*> arbitrary - <*> arbitrary + <*> mempty -- Ord SemVer.Version ignores Metadata, so the Ord properties don't hold instance Arbitrary SemVer.Identifier where arbitrary = -- oneof From 3e9b62a3220444fcfb322fc16dfe53fb0f95ce33 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 31 Aug 2022 17:53:03 +0200 Subject: [PATCH 11/21] debug: increase level of startup debug message --- src/Application.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Application.hs b/src/Application.hs index 0eabab1f9..72ebe38a2 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -608,7 +608,7 @@ appMain = runResourceT $ do foundation <- makeFoundation settings runAppLoggingT foundation $ do - $logDebugS "setup" "Job-Handling" + $logInfoS "setup" "Job-Handling" handleJobs foundation -- Generate a WAI Application from the foundation From e9485fe22d405964f52df296eef17052e486093f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 31 Aug 2022 17:55:01 +0200 Subject: [PATCH 12/21] lms: add fake user generation --- src/Handler/LMS.hs | 2 +- src/Handler/Utils/FakeUsers.hs | 115 ++++++++++++++++++++++++++++ src/Model/Types/Avs.hs | 24 +++--- templates/letter/fraport_renewal.md | 2 +- 4 files changed, 127 insertions(+), 16 deletions(-) create mode 100644 src/Handler/Utils/FakeUsers.hs diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 8deee987b..a96d005ee 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -449,7 +449,7 @@ postLmsR sid qsh = do where -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg - psValidator = def + psValidator = def -- TODO: hier einen Filter für Schützlinge einbauen tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator return (tbl, qent) diff --git a/src/Handler/Utils/FakeUsers.hs b/src/Handler/Utils/FakeUsers.hs new file mode 100644 index 000000000..b97527ec8 --- /dev/null +++ b/src/Handler/Utils/FakeUsers.hs @@ -0,0 +1,115 @@ +module Handler.Utils.FakeUsers + ( fakeQualificationUsers + ) where + +import Import + +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TEnc +import qualified Yesod.Auth.Util.PasswordStore as PWStore +import Control.Applicative (ZipList(..), getZipList) + + +import Handler.Utils.DateTime + + +-- | indefinitely repeat a list, from Prelude +cycle :: [a] -> [a] +cycle [] = [] +cycle xs = xs' where xs' = xs ++ xs' + + +fakeQualificationUsers :: QualificationId -> Int -> (Day,Day) -> DB Int +fakeQualificationUsers qid usersPerDay (dfrom, dto) = do + now <- liftIO getCurrentTime + UserDefaultConf{..} <- getsYesod $ view _appUserDefaults + pwSimple <- do + let pw = "123.456" + PWHashConf{..} <- getsYesod $ view _appAuthPWHash + pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength + return $ AuthPWHash $ TEnc.decodeUtf8 pwHash + let expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dfrom dto)] + + fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool) -> User + fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal) = + let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ [userSurname]) <> "@example.com" + userDisplayName = Text.unwords $ firstNames <> [userSurname] + userEmail = CI.mk "s.jost@fraport.de" -- test that email is truly recieved + userDisplayEmail = userIdent + userMatrikelnummer = Just "TESTUSER" + userAuthentication = pwSimple + userLastAuthentication = Nothing + userCreated = now + userLastLdapSynchronisation = Nothing + userLdapPrimaryKey = Nothing + userTokensIssuedAfter = Nothing + userFirstName = Text.unwords firstNames + userTitle = Nothing + userMaxFavourites = userDefaultMaxFavourites + userMaxFavouriteTerms = userDefaultMaxFavourites + userTheme = userDefaultTheme + userDownloadFiles = userDefaultDownloadFiles + userWarningDays = userDefaultWarningDays + userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + userExamOfficeGetLabels = userDefaultExamOfficeGetLabels + userNotificationSettings = def + userCsvOptions = def + userSex = Nothing + userShowSex = userDefaultShowSex + userTelephone = Nothing + userMobile = Nothing + userCompanyPersonalNumber = Nothing + userCompanyDepartment = Nothing + userPostAddress = postalAddress + in User{..} + + valid <- forM (zip expiryOffsets names) $ \(expOffset, user) -> do + muid <- insertUnique $ fakeUser user + case muid of + Nothing -> return 0 + (Just uid) -> do + let qualificationUserUser = uid + qualificationUserQualification = qid + qualificationUserValidUntil = addDays expOffset dfrom + qualificationUserFirstHeld = setYear (getYear qualificationUserValidUntil - 2) qualificationUserValidUntil + qualificationUserLastRefresh = qualificationUserFirstHeld + ok <- insertUnique QualificationUser{..} + return $ maybe 0 (const 1) ok + return $ sum valid + + where + postalAddress = Just $ plaintextToStoredMarkup $ Text.unlines ["Kapazitätsmanagement Airside (AVN-AR2) - FDTest", "Flughafen Frankfurt Main", "60547 Frankfurt am Main"] + givenNames = [ "James", "John", "Robert", "Michael" + , "William", "David", "Mary", "Richard" + , "Joseph", "Thomas", "Charles", "Daniel" + , "Matthew", "Patricia", "Jennifer", "Linda" + , "Elizabeth", "Barbara", "Anthony", "Donald" + , "Mark", "Paul", "Steven", "Andrew" + , "Kenneth", "Joshua", "George", "Kevin" + , "Brian", "Edward", "Susan", "Ronald" + ] + middlenames = [ Nothing, Nothing, Just ["Tiberius"], Nothing, Just ["Jamesson", "Maria"], Nothing, Just ["Jörg"] ] + surnames = [ "Müller", "Smith", "Johnson", "Williams", "Brown" + , "Jones", "Miller", "Davis", "Garcia" + , "Rodriguez", "Wilson", "Martinez", "Anderson" + , "Taylor", "Thomas", "Hernandez", "Moore" + , "Martin", "Jackson", "Thompson", "White" + , "Lopez", "Lee", "Gonzalez", "Harris" + , "Clark", "Lewis", "Robinson", "Walker" + , "Perez", "Hall", "Young", "Allen" + ] + someLangs = [ (Just $ Languages ["de-de"] , DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%a %d.%m.%Y", DateTimeFormat "%T") + , (Nothing , DateTimeFormat "%d.%m.%y %R" , DateTimeFormat "%d.%m.%y" , DateTimeFormat "%R") + , (Just $ Languages ["en-eu","de"], DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%b %d %y" , DateTimeFormat "%I:%M %p") + , (Just $ Languages ["fr"] , DateTimeFormat "%d-%m-%Y %R" , DateTimeFormat "%d-%m-%Y" , DateTimeFormat "%R") + , (Just $ Languages ["fr","en"] , DateTimeFormat "%B %d %Y %R" , DateTimeFormat "%B %d %y" , DateTimeFormat "%I:%M:%S %p") + ] + postal = [False, True, False] + + names = getZipList $ (\f m s l p -> (f : concat m, s, l, p)) + <$> ZipList (cycle givenNames) + <*> ZipList (cycle middlenames) + <*> ZipList (cycle surnames) + <*> ZipList (cycle someLangs) + <*> ZipList (cycle postal) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 569403d5b..237803524 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -250,15 +250,15 @@ hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard pickLicenceAddress a b - | Just r <- pickBetter' hasAddress = r -- prefer card with complete address - | 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 + | Just r <- pickBetter' hasAddress = r -- prefer card with complete address + | 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 | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date | avsDataIssueDate a < avsDataIssueDate b = b | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date | avsDataValidTo a < avsDataValidTo b = b - | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm + | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm | a <= b = b -- respect natural Ord instance | otherwise = a where @@ -266,16 +266,12 @@ pickLicenceAddress a b pickBetter' = pickBetter a b {- Note: - -Since Ordering is a Semigroup that ignores the righthand side except for EQ, this can be conveniently be used like so - +For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this can be conveniently be used like so bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering - compare a b = - compareBy avsDataValid - <> compareBy avsDataValidTo - <> compareBy avsDataIssueDate - + compare a b = compareBy avsDataValid + <> compareBy avsDataValidTo + <> compareBy avsDataIssueDate + ... where compareBy f = compare `on` f a b - -} \ No newline at end of file diff --git a/templates/letter/fraport_renewal.md b/templates/letter/fraport_renewal.md index 0d89eaafd..67467b034 100644 --- a/templates/letter/fraport_renewal.md +++ b/templates/letter/fraport_renewal.md @@ -6,7 +6,7 @@ en-subject: Renewal of apron driving License author: Fraport AG - Fahrerausbildung (AVN-AR) phone: +49 69 690-30306 email: fahrerausbildung@fraport.de -url: +url: place: Frankfurt/Main return-address: - 60547 Frankfurt From 3eedff2b9f50079175fadb50af8b24808d74e36c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 1 Sep 2022 12:57:02 +0200 Subject: [PATCH 13/21] lms: add interface for create fake users and verify it is working --- .../utils/navigation/menu/de-de-formal.msg | 3 +- .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 3 +- src/Foundation/Navigation.hs | 5 +- src/Handler/LMS.hs | 2 + .../{Utils/FakeUsers.hs => LMS/Fake.hs} | 113 +++++++++++------- test/Model/TypesSpec.hs | 2 +- 7 files changed, 81 insertions(+), 48 deletions(-) rename src/Handler/{Utils/FakeUsers.hs => LMS/Fake.hs} (59%) diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 83fa124e1..1c8948184 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 +MenuLmsDirect: Direkter Upload +MenuLmsFake: Testnutzer generieren MenuAvs: Schnittstelle AVS MenuApc: Druckerei diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 1570ce735..b0e1779d1 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -132,6 +132,7 @@ MenuLmsUserlist: Upload E-Learning Users MenuLmsResult: Upload E-Learning Results MenuLmsUpload: Upload MenuLmsDirect: Direct Upload +MenuLmsFake: Generate test users MenuAvs: AVS Interface MenuApc: Printing diff --git a/routes b/routes index 4563b0a5f..bdc345e0c 100644 --- a/routes +++ b/routes @@ -265,7 +265,7 @@ -- for users /qualification QualificationAllR GET !free /qualification/#SchoolId QualificationSchoolR GET !free -- TODO -/qualification/#SchoolId/#QualificationShorthand QualificationR GET !free -- must be logged in though +/qualification/#SchoolId/#QualificationShorthand QualificationR GET -- TODO make !free again after repurpose -- OSIS CSV Export Demo /lms LmsAllR GET POST /lms/#SchoolId LmsSchoolR GET @@ -279,6 +279,7 @@ /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST /lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST +/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST -- TODO: delete this testing URL /api ApiDocsR GET !free /swagger SwaggerR GET !free diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index f63c1093f..419c3de01 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -162,7 +162,7 @@ breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed - +breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR @@ -2484,6 +2484,9 @@ pageActions (LmsR sid qsh) = return , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh } + , NavPageActionSecondary { + navLink = defNavLink MsgMenuLmsFake $ LmsFakeR sid qsh + } ] pageActions ApiDocsR = return [ NavPageActionPrimary diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index a96d005ee..fa563ba9a 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -12,6 +12,7 @@ module Handler.LMS , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR , getLmsResultR , postLmsResultR , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR + , getLmsFakeR , postLmsFakeR ) where @@ -37,6 +38,7 @@ import Database.Esqueleto.Utils.TH import Handler.LMS.Users as Handler.LMS import Handler.LMS.Userlist as Handler.LMS import Handler.LMS.Result as Handler.LMS +import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production! -- avoids repetition of local definitions single :: (k,a) -> Map k a diff --git a/src/Handler/Utils/FakeUsers.hs b/src/Handler/LMS/Fake.hs similarity index 59% rename from src/Handler/Utils/FakeUsers.hs rename to src/Handler/LMS/Fake.hs index b97527ec8..d6d8d13ed 100644 --- a/src/Handler/Utils/FakeUsers.hs +++ b/src/Handler/LMS/Fake.hs @@ -1,9 +1,13 @@ -module Handler.Utils.FakeUsers - ( fakeQualificationUsers +module Handler.LMS.Fake + ( getLmsFakeR, postLmsFakeR ) where import Import +import Handler.Utils +import System.Random (randomRIO) + +import Data.List (cycle) import qualified Data.CaseInsensitive as CI import qualified Data.Text as Text import qualified Data.Text.Encoding as TEnc @@ -11,32 +15,55 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore import Control.Applicative (ZipList(..), getZipList) -import Handler.Utils.DateTime + +getLmsFakeR, postLmsFakeR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsFakeR = postLmsFakeR +postLmsFakeR sid qsh = do + now <- liftIO getCurrentTime + (Entity qid _) <- runDB $ getBy404 $ SchoolQualificationShort sid qsh + let qName :: Text = CI.original $ unSchoolKey sid <> "-" <> qsh + ((fakeRes, fakeView), fakeEnctype) <- runFormPost $ renderAForm FormStandard $ mkFakeForm $ utctDay now + let fakeForm = wrapForm fakeView def { formEncoding = fakeEnctype } + formResult fakeRes $ \res -> do + (uNew, uTotal) <- runDB $ fakeQualificationUsers qid res + let msgStatus = if | uNew == 0 -> Error + | uNew == uTotal -> Success + | otherwise -> Warning + addMessage msgStatus $ toHtml $ tshow uNew <> " von " <> tshow uTotal <> " neue Testnutzer mit ablaufender Qualifikation " <> qName <> " generiert" + redirect $ LmsR sid qsh + siteLayout "Testnutzer generieren" $ do + setTitle $ toHtml $ "Testnutzer generieren " <> qName + toWidget [whamlet| + Hier können neu zufällige Testbenutzer mit ablaufenden Qualifikationen generiert werden. + + ^{fakeForm} + |] + +mkFakeForm :: Day -> AForm Handler (Int, Day, Day) +mkFakeForm d = (,,) + <$> areq intField (fsl "Fällige Teilnehmer pro Tag") (Just 10) + <*> areq dayField (fsl "Erster Tag mit fälligen Teilnehmern") (Just d) + <*> areq dayField (fsl "Letzter Tag mit fälligen Teilnehmern") (Just $ addDays 7 d) --- | indefinitely repeat a list, from Prelude -cycle :: [a] -> [a] -cycle [] = [] -cycle xs = xs' where xs' = xs ++ xs' - - -fakeQualificationUsers :: QualificationId -> Int -> (Day,Day) -> DB Int -fakeQualificationUsers qid usersPerDay (dfrom, dto) = do +fakeQualificationUsers :: QualificationId -> (Int, Day, Day) -> DB (Int,Int) +fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do now <- liftIO getCurrentTime + dropNames <- liftIO $ randomRIO (0,length givenNames * length surnames) UserDefaultConf{..} <- getsYesod $ view _appUserDefaults pwSimple <- do let pw = "123.456" PWHashConf{..} <- getsYesod $ view _appAuthPWHash pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength return $ AuthPWHash $ TEnc.decodeUtf8 pwHash - let expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dfrom dto)] - + let expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)] + fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool) -> User - fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal) = - let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ [userSurname]) <> "@example.com" - userDisplayName = Text.unwords $ firstNames <> [userSurname] - userEmail = CI.mk "s.jost@fraport.de" -- test that email is truly recieved + fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal) = + let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ (Text.take 1 <$> drop 1 firstNames) ++ [userSurname]) <> "@example.com" + userEmail = userIdent userDisplayEmail = userIdent + userDisplayName = Text.unwords $ firstNames <> [userSurname] userMatrikelnummer = Just "TESTUSER" userAuthentication = pwSimple userLastAuthentication = Nothing @@ -45,7 +72,7 @@ fakeQualificationUsers qid usersPerDay (dfrom, dto) = do userLdapPrimaryKey = Nothing userTokensIssuedAfter = Nothing userFirstName = Text.unwords firstNames - userTitle = Nothing + userTitle = Nothing userMaxFavourites = userDefaultMaxFavourites userMaxFavouriteTerms = userDefaultMaxFavourites userTheme = userDefaultTheme @@ -57,28 +84,26 @@ fakeQualificationUsers qid usersPerDay (dfrom, dto) = do userCsvOptions = def userSex = Nothing userShowSex = userDefaultShowSex - userTelephone = Nothing - userMobile = Nothing - userCompanyPersonalNumber = Nothing + userTelephone = Nothing + userMobile = Nothing + userCompanyPersonalNumber = Nothing userCompanyDepartment = Nothing userPostAddress = postalAddress in User{..} - valid <- forM (zip expiryOffsets names) $ \(expOffset, user) -> do - muid <- insertUnique $ fakeUser user - case muid of - Nothing -> return 0 - (Just uid) -> do - let qualificationUserUser = uid - qualificationUserQualification = qid - qualificationUserValidUntil = addDays expOffset dfrom - qualificationUserFirstHeld = setYear (getYear qualificationUserValidUntil - 2) qualificationUserValidUntil - qualificationUserLastRefresh = qualificationUserFirstHeld - ok <- insertUnique QualificationUser{..} - return $ maybe 0 (const 1) ok - return $ sum valid + valid <- forM (zip expiryOffsets $ drop dropNames names) $ \(expOffset, user) -> do + euid <- insertBy $ fakeUser user + let uid = either entityKey id euid + qualificationUserUser = uid + qualificationUserQualification = qid + qualificationUserValidUntil = addDays expOffset dfrom + qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil + qualificationUserLastRefresh = qualificationUserFirstHeld + ok <- insertUnique QualificationUser{..} + return $ maybe 0 (const 1) ok + return (sum valid, length expiryOffsets) - where + where postalAddress = Just $ plaintextToStoredMarkup $ Text.unlines ["Kapazitätsmanagement Airside (AVN-AR2) - FDTest", "Flughafen Frankfurt Main", "60547 Frankfurt am Main"] givenNames = [ "James", "John", "Robert", "Michael" , "William", "David", "Mary", "Richard" @@ -99,17 +124,17 @@ fakeQualificationUsers qid usersPerDay (dfrom, dto) = do , "Clark", "Lewis", "Robinson", "Walker" , "Perez", "Hall", "Young", "Allen" ] - someLangs = [ (Just $ Languages ["de-de"] , DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%a %d.%m.%Y", DateTimeFormat "%T") - , (Nothing , DateTimeFormat "%d.%m.%y %R" , DateTimeFormat "%d.%m.%y" , DateTimeFormat "%R") - , (Just $ Languages ["en-eu","de"], DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%b %d %y" , DateTimeFormat "%I:%M %p") - , (Just $ Languages ["fr"] , DateTimeFormat "%d-%m-%Y %R" , DateTimeFormat "%d-%m-%Y" , DateTimeFormat "%R") - , (Just $ Languages ["fr","en"] , DateTimeFormat "%B %d %Y %R" , DateTimeFormat "%B %d %y" , DateTimeFormat "%I:%M:%S %p") - ] + someLangs = [ (Just $ Languages ["de-de"] , DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%a %d.%m.%Y", DateTimeFormat "%T") + , (Nothing , DateTimeFormat "%d.%m.%y %R" , DateTimeFormat "%d.%m.%y" , DateTimeFormat "%R") + , (Just $ Languages ["en-eu","de"], DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%b %d %y" , DateTimeFormat "%I:%M %p") + , (Just $ Languages ["fr"] , DateTimeFormat "%d-%m-%Y %R" , DateTimeFormat "%d-%m-%Y" , DateTimeFormat "%R") + , (Just $ Languages ["fr","en"] , DateTimeFormat "%B %d %Y %R" , DateTimeFormat "%B %d %y" , DateTimeFormat "%I:%M:%S %p") + ] postal = [False, True, False] - names = getZipList $ (\f m s l p -> (f : concat m, s, l, p)) - <$> ZipList (cycle givenNames) - <*> ZipList (cycle middlenames) + names = getZipList $ (\f m s l p -> (f : concat m, s, l, p)) + <$> ZipList (cycle givenNames) + <*> ZipList (cycle middlenames) <*> ZipList (cycle surnames) <*> ZipList (cycle someLangs) <*> ZipList (cycle postal) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index ed98ad9b5..53d8ab8dc 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -363,7 +363,7 @@ instance Arbitrary SemVer.Version where <*> fmap getNonNegative arbitrary <*> fmap getNonNegative arbitrary <*> arbitrary - <*> mempty -- Ord SemVer.Version ignores Metadata, so the Ord properties don't hold + <*> pure mempty -- Ord SemVer.Version ignores Metadata, so the Ord properties don't hold instance Arbitrary SemVer.Identifier where arbitrary = -- oneof From 83b8e765c61a53144435f7902ab9f23d6494db32 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 1 Sep 2022 16:16:56 +0200 Subject: [PATCH 14/21] lms: add pin passwords to user records --- messages/uniworx/categories/user/de-de-formal.msg | 1 + messages/uniworx/categories/user/en-eu.msg | 1 + models/users.model | 2 +- src/Foundation/Yesod/Auth.hs | 1 + src/Handler/LMS/Fake.hs | 10 ++++++++-- src/Handler/Users/Add.hs | 5 ++++- test/Database/Fill.hs | 8 ++++++++ test/User.hs | 1 + 8 files changed, 25 insertions(+), 4 deletions(-) diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 5559d44f7..e7a9e1669 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -14,6 +14,7 @@ AdminUserFPersonalNumber: Personalnummer (nur Fraport AG) AdminUserFDepartment: Abteilung AdminUserPostAddress: Postalische Anschrift AdminUserPrefersPostal: Briefe anstatt Email bevorzugt +AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails AdminUserAssimilate: Benutzer assimilieren UserAdded: Benutzer erfolgreich angelegt UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 7d7645c15..b918f5bde 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -14,6 +14,7 @@ AdminUserFPersonalNumber: Personalnumber (Fraport AG only) AdminUserFDepartment: Department AdminUserPostAddress: Postal Address AdminUserPrefersPostal: Prefers postal letters over email +AdminUserPinPassword: Password used for all PDF attachments to emails AdminUserAssimilate: Assimilate user UserAdded: Successfully added user UserCollision: Could not create user due to uniqueness constraint diff --git a/models/users.model b/models/users.model index 9eff01c9f..7bc14297a 100644 --- a/models/users.model +++ b/models/users.model @@ -39,7 +39,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create mobile Text Maybe companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available - -- pinPassword Text Maybe -- used to encrypt pins within emails + pinPassword Text Maybe -- used to encrypt pins within emails postAddress StoredMarkup Maybe prefersPostal Bool default=false -- user prefers letters by post instead of email examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 675fe7cce..785acc5d1 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -247,6 +247,7 @@ upsertCampusUser upsertMode ldapData = do , 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 , .. } diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index d6d8d13ed..a8c7b9203 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -34,7 +34,7 @@ postLmsFakeR sid qsh = do siteLayout "Testnutzer generieren" $ do setTitle $ toHtml $ "Testnutzer generieren " <> qName toWidget [whamlet| - Hier können neu zufällige Testbenutzer mit ablaufenden Qualifikationen generiert werden. + Hier können zufällige Testbenutzer mit ablaufenden Qualifikationen generiert werden. ^{fakeForm} |] @@ -89,6 +89,7 @@ fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do userCompanyPersonalNumber = Nothing userCompanyDepartment = Nothing userPostAddress = postalAddress + userPinPassword = Just "tomatenmarmelade" in User{..} valid <- forM (zip expiryOffsets $ drop dropNames names) $ \(expOffset, user) -> do @@ -99,7 +100,12 @@ fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do qualificationUserValidUntil = addDays expOffset dfrom qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil qualificationUserLastRefresh = qualificationUserFirstHeld - ok <- insertUnique QualificationUser{..} + -- upsert QualificationUser{..} [ QualificationUserValidUntil =. qualificationUserValidUntil + -- , QualificationUserLastRefresh =. qualificationUserLastRefresh + -- ] + -- return 1 + -- We do not overwrite any existing qualifications, just to be on the save side: + ok <- insertUnique QualificationUser{..} return $ maybe 0 (const 1) ok return (sum valid, length expiryOffsets) diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 96d83ef72..36f6983ee 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -25,6 +25,7 @@ data AdminUserForm = AdminUserForm , aufFDepartment :: Maybe Text , aufPostAddress :: Maybe StoredMarkup , aufPrefersPostal :: Bool + , aufPinPassword :: Maybe Text , aufEmail :: UserEmail , aufIdent :: UserIdent , aufAuth :: AuthenticationKind @@ -61,10 +62,11 @@ adminUserForm template = renderAForm FormStandard <*> aopt (textField & cfStrip) (fslI MsgAdminUserFDepartment) (aufFDepartment <$> template) <*> aopt htmlField (fslI MsgAdminUserPostAddress) (aufPostAddress <$> template) <*> areq checkBoxField (fslI MsgAdminUserPrefersPostal) (aufPrefersPostal <$> template) + <*> aopt (textField & cfStrip) (fslI MsgAdminUserPinPassword) (aufPinPassword <$> template) <*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (aufEmail <$> template) <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template) <*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP) - + getAdminUserAddR, postAdminUserAddR :: Handler Html getAdminUserAddR = postAdminUserAddR @@ -110,6 +112,7 @@ postAdminUserAddR = do , userCompanyDepartment = aufFDepartment , userPostAddress = aufPostAddress , userPrefersPostal = aufPrefersPostal + , userPinPassword = aufPinPassword , userMatrikelnummer = aufMatriculation , userAuthentication = mkAuthMode aufAuth } diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 6ffc660b7..8056ccd87 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -111,6 +111,7 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPinPassword = Nothing , userPostAddress = Nothing , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced @@ -148,6 +149,7 @@ fillDb = do , userTelephone = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPinPassword = Nothing , userPostAddress = Nothing , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced @@ -191,6 +193,7 @@ fillDb = do , userMobile = Just "0173 69 99 646" , userCompanyPersonalNumber = Just "57138" , userCompanyDepartment = Just "AVN-AR2" + , userPinPassword = Nothing , userPostAddress = Nothing , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced @@ -228,6 +231,7 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPinPassword = Nothing , userPostAddress = Nothing , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced @@ -265,6 +269,7 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPinPassword = Nothing , userPostAddress = Nothing , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced @@ -302,6 +307,7 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPinPassword = Nothing , userPostAddress = Nothing , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced @@ -339,6 +345,7 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPinPassword = Nothing , userPostAddress = Nothing , userPrefersPostal = False , userExamOfficeGetSynced = False @@ -406,6 +413,7 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing + , userPinPassword = Nothing , userPostAddress = Nothing , userPrefersPostal = False , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced diff --git a/test/User.hs b/test/User.hs index 597f126e7..f96c88a94 100644 --- a/test/User.hs +++ b/test/User.hs @@ -49,5 +49,6 @@ fakeUser adjUser = adjUser User{..} userTelephone = Nothing userCompanyPersonalNumber = Nothing userCompanyDepartment = Nothing + userPinPassword = Nothing userPostAddress = Nothing userPrefersPostal = False From 7c8629300529d18554aac0cd66cf6bb13814337e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Sep 2022 11:00:52 +0200 Subject: [PATCH 15/21] fix: build --- test/ModelSpec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 2df4b3958..b4ad479c1 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -132,6 +132,7 @@ instance Arbitrary User where userTelephone <- fmap pack . assertM' (not . null) <$> listOf (elements $ [' ', '+', '-', '/', '_'] ++ ['0'..'9']) userCompanyPersonalNumber <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9']) userCompanyDepartment <- arbitrary + userPinPassword <- arbitrary userPostAddress <- arbitrary -- TODO: not a good address userPrefersPostal <- arbitrary userExamOfficeGetSynced <- arbitrary From 1d3c27868277c28350dfb087802bc1f7c6732aeb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Sep 2022 11:38:03 +0200 Subject: [PATCH 16/21] fix(avs): incomplete config throws error --- db.sh | 1 + src/Application.hs | 7 ++++--- start.sh | 1 + 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/db.sh b/db.sh index a585ee1f6..7c154686d 100755 --- a/db.sh +++ b/db.sh @@ -13,4 +13,5 @@ fi stack build --fast --flag uniworx:-library-only --flag uniworx:dev export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true} +export AVSPASS=${AVSPASS:-nopasswordset} stack exec uniworxdb -- $@ diff --git a/src/Application.hs b/src/Application.hs index 72ebe38a2..475f04ec6 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -348,9 +348,10 @@ makeFoundation appSettings''@AppSettings{..} = do appAvsQuery <- case appAvsConf of Nothing -> do - $logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings." - return Nothing - -- liftIO exitFailure + -- $logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings." + -- return Nothing + error "AvsConfig is empty, i.e. invalid AVS configuration settings." + Just avsConf -> do -- TODO: consider using Servant.Client.Core.BaseUrl.Instances.parseBaseUrl' within Settings already at Startup! manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing diff --git a/start.sh b/start.sh index 9eea5843b..a663c3ef7 100755 --- a/start.sh +++ b/start.sh @@ -22,6 +22,7 @@ export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true} export ENCRYPT_ERRORS=${ENCRYPT_ERRORS:-false} export RIBBON=${RIBBON:-${__HOST:-localhost}} export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))} +export AVSPASS=${AVSPASS:-nopasswordset} unset HOST move-back() { From 7725e97280df4c644a76621791511110607b7f06 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Sep 2022 15:06:26 +0200 Subject: [PATCH 17/21] test(exam): disable lenghty exam tests while exams are not used --- test/Handler/Utils/ExamSpec.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/test/Handler/Utils/ExamSpec.hs b/test/Handler/Utils/ExamSpec.hs index c0675a2cd..acf8d8dae 100644 --- a/test/Handler/Utils/ExamSpec.hs +++ b/test/Handler/Utils/ExamSpec.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS -Wno-unused-top-binds #-} module Handler.Utils.ExamSpec (spec) where @@ -21,6 +22,10 @@ import qualified Data.RFC5051 as RFC5051 import Handler.Utils.Exam +spec :: Spec +-- spec = test_spec +spec = return () -- TODO: tests deactivated since exams are currently not used + -- direct copy&paste from an (currently) unmerged pull request for hspec-expectations -- https://github.com/hspec/hspec-expectations/blob/6b4a475e42b0d44008c150727dea25dd79f568f2/src/Test/Hspec/Expectations.hs -- | @@ -91,8 +96,8 @@ instance Show UserProperties where ++ ", userMatrikelnummer=" ++ show userMatrikelnummer ++ "}" -- function Handler.Utils.examAutoOccurrence -spec :: Spec -spec = do +test_spec :: Spec +test_spec = do describe "examAutoOccurrence" $ do describe "Surname" $ testWithRule ExamRoomSurname describe "Matriculation" $ testWithRule ExamRoomMatriculation From d204d4313da67575eb727ea3a3645828dc5f4473 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Sep 2022 15:12:32 +0200 Subject: [PATCH 18/21] avs: fradrive refuses to start with an incomplete avs configuration --- src/Application.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 475f04ec6..749937ffb 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -352,8 +352,7 @@ makeFoundation appSettings''@AppSettings{..} = do -- return Nothing error "AvsConfig is empty, i.e. invalid AVS configuration settings." - Just avsConf -> do - -- TODO: consider using Servant.Client.Core.BaseUrl.Instances.parseBaseUrl' within Settings already at Startup! + Just avsConf -> do manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing let avsServer = BaseUrl { baseUrlScheme = Https From 59fe2819e91054a8358a316aed2afdbea6d011f3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Sep 2022 15:12:42 +0200 Subject: [PATCH 19/21] lms: fake users now start over the configuered days instead of validUntil --- models/lms.model | 2 +- src/Handler/LMS/Fake.hs | 57 +++++++++++++++++++++++++---------------- 2 files changed, 36 insertions(+), 23 deletions(-) diff --git a/models/lms.model b/models/lms.model index 0045f740b..986ee5d27 100644 --- a/models/lms.model +++ b/models/lms.model @@ -6,7 +6,7 @@ Qualification description StoredMarkup Maybe -- user-defined large Html, ought to contain full description validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months auditDuration Word Maybe -- number of month to keep audit log; or indefinitely - refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry + refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip elearningStart Bool -- automatically schedule e-refresher -- elearningOnly Bool -- successful E-learing automatically increases validity. NO! -- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO! diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index a8c7b9203..05eaac851 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -18,14 +18,14 @@ import Control.Applicative (ZipList(..), getZipList) getLmsFakeR, postLmsFakeR :: SchoolId -> QualificationShorthand -> Handler Html getLmsFakeR = postLmsFakeR -postLmsFakeR sid qsh = do +postLmsFakeR sid qsh = do + qent <- runDB $ getBy404 $ SchoolQualificationShort sid qsh now <- liftIO getCurrentTime - (Entity qid _) <- runDB $ getBy404 $ SchoolQualificationShort sid qsh let qName :: Text = CI.original $ unSchoolKey sid <> "-" <> qsh ((fakeRes, fakeView), fakeEnctype) <- runFormPost $ renderAForm FormStandard $ mkFakeForm $ utctDay now let fakeForm = wrapForm fakeView def { formEncoding = fakeEnctype } formResult fakeRes $ \res -> do - (uNew, uTotal) <- runDB $ fakeQualificationUsers qid res + (uNew, uTotal) <- runDB $ fakeQualificationUsers qent res let msgStatus = if | uNew == 0 -> Error | uNew == uTotal -> Success | otherwise -> Warning @@ -34,20 +34,28 @@ postLmsFakeR sid qsh = do siteLayout "Testnutzer generieren" $ do setTitle $ toHtml $ "Testnutzer generieren " <> qName toWidget [whamlet| - Hier können zufällige Testbenutzer mit ablaufenden Qualifikationen generiert werden. + Hier können zufällige Testbenutzer mit ablaufenden Qualifikationen generiert werden, + welche dann im angegebenen Zeitraum fällig werden. ^{fakeForm} + +

Hinweise: +
    +
  • Emails der generierten Teilnehmer enden auf @example.com<\tt> + und die Matrikelnummer lautet TESTUSER<\tt>. +
  • Bereits vorhandene Teilnehmer mit gleicher Ident werden nicht neu generiert. +
  • Vorhandene Qualifikationen solcher Teilnehmer werden einfach überschrieben. |] mkFakeForm :: Day -> AForm Handler (Int, Day, Day) mkFakeForm d = (,,) <$> areq intField (fsl "Fällige Teilnehmer pro Tag") (Just 10) - <*> areq dayField (fsl "Erster Tag mit fälligen Teilnehmern") (Just d) - <*> areq dayField (fsl "Letzter Tag mit fälligen Teilnehmern") (Just $ addDays 7 d) + <*> areq dayField (fsl "Erster Tag an dem Teilnehmer fällig werden") (Just d) + <*> areq dayField (fsl "Letzter Tag an dem Teilnehmer fällig werden") (Just $ addDays 7 d) -fakeQualificationUsers :: QualificationId -> (Int, Day, Day) -> DB (Int,Int) -fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do +fakeQualificationUsers :: Entity Qualification -> (Int, Day, Day) -> DB (Int,Int) +fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (usersPerDay, dfrom, dto) = do now <- liftIO getCurrentTime dropNames <- liftIO $ randomRIO (0,length givenNames * length surnames) UserDefaultConf{..} <- getsYesod $ view _appUserDefaults @@ -57,7 +65,7 @@ fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength return $ AuthPWHash $ TEnc.decodeUtf8 pwHash let expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)] - + expiryNotifyDay = addGregorianDurationClip (fromMaybe calendarDay qualificationRefreshWithin) dfrom fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool) -> User fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal) = let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ (Text.take 1 <$> drop 1 firstNames) ++ [userSurname]) <> "@example.com" @@ -92,21 +100,26 @@ fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do userPinPassword = Just "tomatenmarmelade" in User{..} + $logWarnS "FAKEUSER" $ tshow expiryNotifyDay valid <- forM (zip expiryOffsets $ drop dropNames names) $ \(expOffset, user) -> do euid <- insertBy $ fakeUser user - let uid = either entityKey id euid - qualificationUserUser = uid - qualificationUserQualification = qid - qualificationUserValidUntil = addDays expOffset dfrom - qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil - qualificationUserLastRefresh = qualificationUserFirstHeld - -- upsert QualificationUser{..} [ QualificationUserValidUntil =. qualificationUserValidUntil - -- , QualificationUserLastRefresh =. qualificationUserLastRefresh - -- ] - -- return 1 - -- We do not overwrite any existing qualifications, just to be on the save side: - ok <- insertUnique QualificationUser{..} - return $ maybe 0 (const 1) ok + if | (Left (Entity _ User{userMatrikelnummer})) <- euid + , userMatrikelnummer /= Just "TESTUSER" + -> return 0 + | otherwise -> do + let uid = either entityKey id euid + qualificationUserUser = uid + qualificationUserQualification = qid + qualificationUserValidUntil = addDays expOffset expiryNotifyDay + qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil + qualificationUserLastRefresh = qualificationUserFirstHeld + _ <- upsert QualificationUser{..} + [ QualificationUserValidUntil =. qualificationUserValidUntil + , QualificationUserLastRefresh =. qualificationUserLastRefresh + ] + return $ either (const 0) (const 1) euid + -- ok <- insertUnique QualificationUser{..} -- We do not overwrite any existing qualifications, just to be on the save side: + -- return $ maybe 0 (const 1) ok return (sum valid, length expiryOffsets) where From bdfb38d8dcb6601b9ed829495e1d3f52d4a2869a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Sep 2022 17:05:10 +0200 Subject: [PATCH 20/21] pandoc: restrict exports of print modul to avoid rogue print jobs --- src/Handler/PrintCenter.hs | 2 +- .../Handler/SendNotification/Qualification.hs | 13 +++--- src/Utils/Print.hs | 44 +++++++++++++------ test/PandocSpec.hs | 26 ++++++++--- 4 files changed, 59 insertions(+), 26 deletions(-) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 87be13ffa..2768ff791 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -83,7 +83,7 @@ validateMetaPinRenewal = do mprToMeta :: MetaPinRenewal -> P.Meta -mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat +mprToMeta MetaPinRenewal{..} = mkMeta -- formatTimeUser SelFormatDate mppDate mppRecipient [ toMeta "recipient" mppRecipient , toMeta "address" (mppRecipient : (mppAddress & html2textlines)) diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index f0b6f567d..eb4dc92b6 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -14,6 +14,8 @@ import Jobs.Handler.SendNotification.Utils import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as Text + -- import Handler.Info (FAQItem(..)) import qualified Data.CaseInsensitive as CI import Text.Hamlet @@ -49,7 +51,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do <*> getJustBy (UniqueLmsQualificationUser nQualification jRecipient) let entRecipient = Entity jRecipient recipient qname = CI.original qualificationName - -- content = $(i18nWidgetFile "qualification/renewal") + $logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " for renewal of qualification " <> qname now <- liftIO getCurrentTime @@ -69,7 +71,9 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do let msg = "Notify " <> tshow jRecipient <> " PDF generation failed with error: " <> err $logErrorS "LMS" msg error $ unpack msg - Right pdf | userPrefersEmail recipient -> userMailT jRecipient $ do + Right pdf | userPrefersEmail recipient -> userMailT jRecipient $ do + -- userPrefersEmail is still true if both userEmail and userPostAddress are null + when (Text.null (CI.original userEmail)) $ $logErrorS "LMS" ("Notify " <> tshow jRecipient <> " failed: no email nor address for user known!") replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectQualificationRenewal qname @@ -78,7 +82,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do -- let msgrenewal = $(i18nHamletFile "qualification/renewal") -- :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- addHtmlMarkdownAlternatives' msgrenewal - encryptPDF "tomatenmarmelade" pdf >>= \case -- TODO: replace with user password! + encryptPDF (fromMaybe "tomatenmarmelade" userPinPassword) pdf >>= \case -- TODO Left err -> do let msg = "Notify " <> tshow jRecipient <> " PDF encryption failed with error: " <> err $logErrorS "LMS" msg @@ -94,8 +98,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do Right pdf | otherwise -> do let printJobName = mempty --TODO printSender = Nothing --TODO - runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case - -- lprPDF printJobName pdf >>= \case + runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case Left err -> do let msg = "Notify " <> tshow jRecipient <> " 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 faea7a2aa..35dc3b21e 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -1,4 +1,16 @@ -module Utils.Print where +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Utils.Print + ( pdfRenewal + , sendLetter + , encryptPDF + , templateDIN5008 + , templateRenewal + -- , compileTemplate, makePDF + , _Meta, addMeta + , toMeta, mbMeta -- single values + , mkMeta, appMeta, applyMetas -- multiple values + ) where -- import Import.NoModel import qualified Data.Foldable as Fold @@ -82,9 +94,18 @@ appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs -- appMeta f = _Meta %~ f -- lens version. Not sure this is better + +-- TODO: applyMetas is inconvenient since we cannot have an instance +-- ToMetaValue a => ToMetaValue (Maybe a) +-- so apply Metas + -- For tests see module PandocSpec -applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, a) -> p -> p -applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas +applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p +applyMetas metas doc = Fold.foldr act doc metas + where + act (_, Nothing) acc = acc + act (k, Just v ) acc = P.setMeta k v acc + -- | Add meta to pandoc. Existing variables will be overwritten. -- For specification, see module PandocSpec @@ -318,15 +339,15 @@ readProcess' pc = do -- > pdftk - output - user_pw tomatenmarmelade -- -encryptPDF :: MonadIO m => String -> LBS.ByteString -> m (Either Text LBS.ByteString) +encryptPDF :: MonadIO m => Text -> LBS.ByteString -> m (Either Text LBS.ByteString) encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> readProcess pc where pc = setStdin (byteStringInput bs) $ - proc "pdftk" [ "-" -- read from stdin - , "output", "-" -- write to stdout - , "user_pw", pw -- encrypt pdf content - , "dont_ask" -- no interaction - , "allow", "Printing" -- allow printing despite encryption + proc "pdftk" [ "-" -- read from stdin + , "output", "-" -- write to stdout + , "user_pw", T.unpack pw -- encrypt pdf content + , "dont_ask" -- no interaction + , "allow", "Printing" -- allow printing despite encryption ] -- Note that pdftk will issue a warning, which will be ignored: -- Warning: Using a password on the command line interface can be insecure. @@ -344,10 +365,7 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read -- The cups version of lpr is instead used like so: -- > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName - - --- TODO: consider hiding this function within the export, as it does not create an entry in the printJob table in the DB - --- | Internal, use `sendLetter` instead +-- | Internal only, use `sendLetter` instead lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text) lprPDF jb bs = do lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg diff --git a/test/PandocSpec.hs b/test/PandocSpec.hs index abccb5c38..135f702ea 100644 --- a/test/PandocSpec.hs +++ b/test/PandocSpec.hs @@ -23,13 +23,13 @@ instance Arbitrary ArbitraryMeta where (x2 :: [Inlines]) <- filter (not . Fold.null) <$> arbitrary (x3 :: Inlines) <- arbitrary (x4 :: [(Text, Text)]) <- filter (not . T.null . fst) <$> arbitrary - (x5 :: [(Text, Bool)]) <- filter (not . T.null . fst) <$> arbitrary + (x5 :: [(Text, Bool)]) <- filter (not . T.null . fst) <$> arbitrary return $ ArbitraryMeta $ setMeta "title" x1 $ setMeta "author" x2 $ setMeta "date" x3 - $ applyMetas x4 - $ applyMetas x5 + $ applyMetas (fmap (second Just) x4) + $ applyMetas (fmap (second Just) x5) nullMeta @@ -43,16 +43,28 @@ instance Arbitrary ArbitraryMeta where spec :: Spec spec = do - let mlist = Map.toList . unMeta + let mlist = Map.toAscList . unMeta describe "applyMetas" $ do it "should actually set values" $ do - (ml, pd) <- generate arbitrary - let + (ml, abMetaOriginal, blocks) <- generate arbitrary + let + metaOriginal = unArbitraryMeta abMetaOriginal + pd = Pandoc metaOriginal blocks mlKeys = Set.fromList $ fst <$> ml - (Pandoc newMeta _) = applyMetas (fmap MetaString <$> ml) pd + (Pandoc newMeta _) = applyMetas (fmap (Just . MetaString) <$> ml) pd ml' = [(k,t) | (k, MetaString t) <- mlist newMeta, Set.member k mlKeys] ml `shouldMatchList` ml' + it "should preserve untouched settings" $ do + (ml, abMetaOriginal, blocks) <- generate arbitrary + let + metaOriginal = unArbitraryMeta abMetaOriginal + pd = Pandoc metaOriginal blocks + nullKeys = Set.fromList [k | (k, Nothing) <- ml] + (Pandoc newMeta _) = applyMetas (fmap (fmap MetaString) <$> ml) pd + oldm = [(k,t) | (k, t) <- mlist metaOriginal , Set.member k nullKeys] + newm = [(k,t) | (k, t) <- mlist newMeta , Set.member k nullKeys] + oldm `shouldMatchList` newm describe "addMeta" $ do it "should possibly overwrite existing settings" $ do From 20e33bbe1332d8b9f40ade8e5d59f80b405792eb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Sep 2022 18:53:34 +0200 Subject: [PATCH 21/21] lms(notify): complete notifications and fix various bugs --- .../categories/qualification/de-de-formal.msg | 13 +-- .../categories/qualification/en-eu.msg | 15 ++-- src/Handler/LMS.hs | 10 +-- src/Handler/LMS/Fake.hs | 4 +- src/Handler/Qualification.hs | 6 +- src/Jobs/Handler/LMS.hs | 2 +- .../Handler/SendNotification/Qualification.hs | 79 ++++++++++--------- src/Utils/Print.hs | 4 +- templates/letter/fraport_renewal.md | 18 +++-- templates/mail/qualificationExpiry.hamlet | 26 +++--- templates/mail/qualificationRenewal.hamlet | 33 +++----- templates/profileData.hamlet | 16 ++++ 12 files changed, 130 insertions(+), 96 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 7fdeea11f..bf0630997 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -9,10 +9,10 @@ QualificationElearningStart: E-Lernen automatisch starten TableQualificationCountActive: Aktive TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation TableQualificationCountTotal: Gesamt -TableQualificationValidUntil: Gültig bis +LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert TableQualificationFirstHeld: Erstmalig -TableLmsUser: Ermächtigter +LmsUser: Inhaber TableLmsEmail: E-Mail TableLmsIdent: Identifikation TableLmsElearning: E-Lernen @@ -44,9 +44,12 @@ LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsDirectUpload: Direkter Upload für automatisierte Systeme LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. -MailSubjectQualificationRenewal qname@Text: Ihre Qualifikation #{qname} muss demnächst erneuert werden -MailSubjectQualificationExpiry qname@Text: Ihre Qualifikation #{qname} läuft demnächst ab -MailLmsRenewalBody: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern. +MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden +MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab +MailBodyQualificationRenewal: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern. +MailBodyQualificationExpiry: Diese Qualifikaton läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden! +LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PIN-Passwort verschlüsselt. Falls kein PIN-Passwort hinterlegt wurde, ist das Passwort ihre Fraport Ausweisnummer, inklusive Punkt und der Ziffer danach. +LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Lernen verlängert werden. LmsActNotify: Benachrichtigung E-Lernen erneut per Post oder E-Mail versenden LmsActRenewPin: Neue zufällige E-Lernen PIN zuweisen LmsActRenewNotify: Neue zufällige E-Lernen PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 546f2d9d0..9ac082788 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -9,10 +9,10 @@ QualificationElearningStart: Start e-learning automatically TableQualificationCountActive: Active TableQualificationCountActiveTooltip: Number of currently valid qualification holders TableQualificationCountTotal: Total -TableQualificationValidUntil: Valid until +LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed TableQualificationFirstHeld: First held -TableLmsUser: Licensee +LmsUser: Licensee TableLmsEmail: Email TableLmsIdent: Identifier TableLmsPin: E-learning pin @@ -29,7 +29,7 @@ TableLmsSuccess: Completed TableLmsFailed: Blocked FilterLmsValid: Currently valid FilterLmsRenewal: Renewal due -CsvColumnLmsIdent: E-learning identifier, unique for each qualfication and user +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? CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom upon next synchronisation? @@ -44,9 +44,12 @@ LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsDirectUpload: Direct upload for automated Systems LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set. -MailSubjectQualificationRenewal qname@Text: Your qualification #{qname} must be renewed shortly -MailSubjectQualificationExpiry qname@Text: Your qualification #{qname} expires soon -MailLmsRenewalBody: You will soon need to renew this qualficiation by completing an e-learning course. +MailSubjectQualificationRenewal qname@Text: Qualification #{qname} must be renewed shortly +MailSubjectQualificationExpiry qname@Text: Qualification #{qname} expires soon +MailBodyQualificationRenewal: You will soon need to renew this qualficiation by completing an e-learning course. +MailBodyQualificationExpiry: This qualificaton expires soon. You may then no longer execute any duties that require this qualification as a precondition! +LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with your chosen FRADrive PIN-Password. If you have not yet chosen a PIN-Password yet, then the password is your Fraport id card number, inkluding the punctuation mark and the Digit thereafter. +LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only. LmsActNotify: Resend e-learning notification by post or email LmsActRenewPin: Randomly replace e-learning PIN LmsActRenewNotify: Randomly replace e-learning PIN and re-send notification by post or email diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index fa563ba9a..292388fca 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -225,9 +225,9 @@ instance Csv.DefaultOrdered LmsTableCsv where instance CsvColumnsExplained LmsTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList - [ ('ltcDisplayName, MsgTableLmsUser) + [ ('ltcDisplayName, MsgLmsUser) , ('ltcEmail , MsgTableLmsEmail) - , ('ltcValidUntil , MsgTableQualificationValidUntil) + , ('ltcValidUntil , MsgLmsQualificationValidUntil) , ('ltcLastRefresh, MsgTableQualificationLastRefresh) , ('ltcFirstHeld , MsgTableQualificationFirstHeld) , ('ltcLmsIdent , MsgTableLmsIdent) @@ -358,7 +358,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do ) ] dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev + [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , 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) @@ -436,9 +436,9 @@ postLmsR sid qsh = do ] colChoices = mconcat [ dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" - , colUserNameLinkHdr MsgTableLmsUser AdminUserR + , colUserNameLinkHdr MsgLmsUser AdminUserR , colUserEmail - , sortable (Just "valid-until") (i18nCell MsgTableQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d + , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index 05eaac851..eabd8a656 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -41,8 +41,8 @@ postLmsFakeR sid qsh = do

    Hinweise:
      -
    • Emails der generierten Teilnehmer enden auf @example.com<\tt> - und die Matrikelnummer lautet TESTUSER<\tt>. +
    • Emails der generierten Teilnehmer enden auf @example.com + und die Matrikelnummer lautet TESTUSER.
    • Bereits vorhandene Teilnehmer mit gleicher Ident werden nicht neu generiert.
    • Vorhandene Qualifikationen solcher Teilnehmer werden einfach überschrieben. |] diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 61dfd5d84..472b3cc6a 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -178,9 +178,9 @@ mkLmsTable (Entity qid quali) = do dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtColonnade = dbColonnade $ mconcat - [ colUserNameLinkHdr MsgTableLmsUser AdminUserR + [ colUserNameLinkHdr MsgLmsUser AdminUserR , colUserEmail - , sortable (Just "valid-until") (i18nCell MsgTableQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d + , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid @@ -219,7 +219,7 @@ mkLmsTable (Entity qid quali) = do ) ] dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev + [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , 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) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 4d550f650..a23ca6467 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -150,7 +150,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act pure (quser, luser) let usr_job (quser, luser) = let vold = quser ^. _entityVal . _qualificationUserValidUntil - pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualfication that have infinite validity?! + pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualification that have infinite validity?! vnew = addGregorianDurationClip pmonth vold lmsstatus = luser ^. _entityVal . _lmsUserStatus in case lmsstatus of diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index eb4dc92b6..db2025152 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -26,13 +26,17 @@ import Text.Hamlet dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler () dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = userMailT jRecipient $ do - (User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- liftHandler . runDB $ (,,) + (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- liftHandler . runDB $ (,,) <$> getJust jRecipient <*> getJust nQualification <*> getJustBy (UniqueQualificationUser nQualification jRecipient) - let qname = CI.original qualificationName + let entRecipient = Entity jRecipient recipient + qname = CI.original qualificationName + expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient + $logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " about expiry of qualification " <> qname + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectQualificationExpiry qname @@ -55,49 +59,29 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do $logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " for renewal of qualification " <> qname now <- liftIO getCurrentTime - letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient + letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient + expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient let prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address pdfMeta = mkMeta - [ toMeta "date" letterDate - , toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang - , toMeta "login" (lmsUserIdent & getLmsIdent) - , toMeta "pin" lmsUserPin - , toMeta "recipient" userDisplayName - , mbMeta "address" (prepAddress <$> userPostAddress) + [ toMeta "date" letterDate + , toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang + , toMeta "login" (lmsUserIdent & getLmsIdent) + , toMeta "pin" lmsUserPin + , toMeta "recipient" userDisplayName + , mbMeta "address" (prepAddress <$> userPostAddress) + , toMeta "expiry" expiryDate + , mbMeta "validduration" (show <$> qualificationValidDuration) ] pdfRenewal pdfMeta >>= \case Left err -> do let msg = "Notify " <> tshow jRecipient <> " PDF generation failed with error: " <> err $logErrorS "LMS" msg error $ unpack msg - Right pdf | userPrefersEmail recipient -> userMailT jRecipient $ do - -- userPrefersEmail is still true if both userEmail and userPostAddress are null - when (Text.null (CI.original userEmail)) $ $logErrorS "LMS" ("Notify " <> tshow jRecipient <> " failed: no email nor address for user known!") - replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI $ MsgMailSubjectQualificationRenewal qname - - editNotifications <- mkEditNotifications jRecipient -- TODO: add to hamlet file again - -- let msgrenewal = $(i18nHamletFile "qualification/renewal") -- :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) - -- addHtmlMarkdownAlternatives' msgrenewal - - encryptPDF (fromMaybe "tomatenmarmelade" userPinPassword) pdf >>= \case -- TODO - Left err -> do - let msg = "Notify " <> tshow jRecipient <> " PDF encryption failed with error: " <> err - $logErrorS "LMS" msg - error $ unpack msg - Right pdffile -> do - addPart (File { fileTitle = "RenewalPinLetter.pdf" -- TODO: better file title! - , fileModified = now - , fileContent = Just $ yield $ LBS.toStrict pdffile - } :: PureFile) - -- TODO: this is just a dummy to continue while i18nHamletFile usage is unclear - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") - - Right pdf | otherwise -> do - let printJobName = mempty --TODO - printSender = Nothing --TODO + Right pdf | userPrefersLetter recipient -> do + let printJobName = "Renewal" + printSender = Nothing runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case Left err -> do let msg = "Notify " <> tshow jRecipient <> " PDF printing to send letter failed with error: " <> err @@ -105,4 +89,27 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do error $ unpack msg Right (msg,_) | null msg -> return () - | otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg \ No newline at end of file + | otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg + + Right pdf -> userMailT jRecipient $ do + -- userPrefersLetter is false if both userEmail and userPostAddress are null + when (Text.null (CI.original userEmail)) $ $logErrorS "LMS" ("Notify " <> tshow jRecipient <> " failed: no email nor address for user known!") + + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectQualificationRenewal qname + + encryptPDF (fromMaybe "tomatenmarmelade" userPinPassword) pdf >>= \case -- TODO + Left err -> do + let msg = "Notify " <> tshow jRecipient <> " PDF encryption failed with error: " <> err + $logErrorS "LMS" msg + + Right pdffile -> do + addPart (File { fileTitle = "RenewalPinLetter.pdf" -- TODO: better file title! + , fileModified = now + , fileContent = Just $ yield $ LBS.toStrict pdffile + } :: PureFile) + + editNotifications <- mkEditNotifications jRecipient + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") + + \ No newline at end of file diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 35dc3b21e..e118ab525 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -271,8 +271,8 @@ sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse prin nameCourse = CI.original . courseShorthand <$> course nameQuali = CI.original . qualificationShorthand <$> quali let printJobAcknowledged = Nothing - jobFullName = unpack $ T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) - printJobFilename = jobFullName <> ".pdf" + jobFullName = unpack $ T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) + printJobFilename = jobFullName <> ".pdf" -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code printJobFile = LBS.toStrict pdf lprPDF jobFullName pdf >>= \case diff --git a/templates/letter/fraport_renewal.md b/templates/letter/fraport_renewal.md index 67467b034..0c0510006 100644 --- a/templates/letter/fraport_renewal.md +++ b/templates/letter/fraport_renewal.md @@ -23,6 +23,7 @@ hyperrefoptions: hidelinks ### Metadaten, welche automatisch ersetzt werden: date: 11.11.1111 +expiry: 00.00.0000 lang: de-de is-de: true login: 123456 @@ -51,9 +52,12 @@ $endfor$ $if(is-de)$ -die Gültigkeit Ihres Vorfeldführerscheines läuft demnächst ab. -Durch die erfolgreiche Teilnahme an einem E-Lernen können Sie -die Gültigkeit um 2 Jahre verlängern. Verwenden Sie dazu die +die Gültigkeit Ihres Vorfeldführerscheines läuft demnächst ab, am $expiry$. +Durch die erfolgreiche Teilnahme an einem E-Lernen können Sie die Gültigkeit +$if(validduration)$ + um $validduration$ Monate +$endif$ +verlängern. Verwenden Sie dazu die Login-Daten aus dem geschützen Sichtfenster weiter unten. Prüfling @@ -75,8 +79,12 @@ $else$ -your apron diving licence is about to expire soon. -You may renew your apron driving licence by two years through successfully +your apron diving licence is about to expire soon, on $expiry$. +You may renew your apron driving licence +$if(validduration)$ + by $validduration$ month +$endif$ +through successfully completing an e-learning course. Please use the login data from the protected area below. Examinee diff --git a/templates/mail/qualificationExpiry.hamlet b/templates/mail/qualificationExpiry.hamlet index 6c7e6a1f9..94ab1156d 100644 --- a/templates/mail/qualificationExpiry.hamlet +++ b/templates/mail/qualificationExpiry.hamlet @@ -14,17 +14,21 @@ $newline never _{SomeMessage $ MsgMailSubjectQualificationExpiry qname}

      - _{SomeMessage MsgMailAllocationNewCourseTip} -
      - - #{qualificationName} - - #{nameHtml userDisplayName userSurname} - #{show qualificationUserValidUntil} - #{show qualificationUserFirstHeld} + _{SomeMessage MsgMailBodyQualificationExpiry}

      -

      - EXPIRY - TODO: Diese Nachricht muss noch überarbeitet werden. +
      +
      _{SomeMessage MsgQualificationName} +
      + + #{qualificationName} +
      _{SomeMessage MsgLmsUser} +
      #{nameHtml userDisplayName userSurname} +
      _{SomeMessage MsgLmsQualificationValidUntil} +
      #{expiryDate} + +

      + _{SomeMessage MsgLmsNoRenewal} + + ^{ihamletSomeMessage editNotifications} diff --git a/templates/mail/qualificationRenewal.hamlet b/templates/mail/qualificationRenewal.hamlet index 45ac91e00..0de1f400d 100644 --- a/templates/mail/qualificationRenewal.hamlet +++ b/templates/mail/qualificationRenewal.hamlet @@ -14,28 +14,21 @@ $newline never _{SomeMessage $ MsgMailSubjectQualificationRenewal qname}

      - _{SomeMessage MsgMailLmsRenewalBody} -
      -       - #{qualificationName} - -

      - Name: - #{nameHtml userDisplayName userSurname} + _{SomeMessage MsgMailBodyQualificationRenewal}

      - Qualifikation: - #{qname} - -

      - Gültig bis: - #{show qualificationUserValidUntil} -

      - Zuerst erhalten: - #{show qualificationUserFirstHeld} +

      +
      _{SomeMessage MsgQualificationName} +
      + + #{qualificationName} +
      _{SomeMessage MsgLmsUser} +
      #{nameHtml userDisplayName userSurname} +
      _{SomeMessage MsgLmsQualificationValidUntil} +
      #{expiryDate}

      -

      - RENEWAL - TODO: Diese Nachricht muss noch überarbeitet werden. + _{SomeMessage MsgLmsRenewalInstructions} + + ^{ihamletSomeMessage editNotifications} diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 8881847f8..95a25aa46 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -18,6 +18,15 @@ $newline never _{MsgTableMatrikelNr}
      #{matnr} + $maybe addr <- userPostAddress +
      + _{MsgAdminUserPostAddress} +
      + #{addr} +
      + _{MsgAdminUserPrefersPostal} +
      + #{show userPrefersPostal}
      _{MsgTableEmail}
      @@ -27,6 +36,13 @@ $newline never _{MsgUserDisplayEmail}
      #{userDisplayEmail} +
      + _{MsgAdminUserPinPassword} +
      + $maybe _pass <- userPinPassword + OK + $nothing + NO $maybe telephonenr <- userTelephone
      _{MsgUserTelephone}