From 4e4508b9193ea720dcbb68aa2295a5dd3fed41c5 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 Feb 2023 09:55:18 +0100 Subject: [PATCH 1/5] refactor(avs): reduce DB overhead in updateReceivers --- src/Handler/Utils/Avs.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 64abd304d..177dabfa2 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -491,7 +491,7 @@ lookupAvsUsers apis = do -- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool) updateReceivers uid = do - (underling :: Entity User, avsUnderling :: Maybe (Entity UserAvs), avsSupers :: [(Entity UserSupervisor, Maybe (Entity UserAvs))]) <- runDB $ (,,) + (underling :: Entity User, avsUnderling :: Maybe (Entity UserAvs), avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,,) <$> getJustEntity uid <*> getBy (UniqueUserAvsUser uid) <*> (E.select $ do @@ -501,11 +501,12 @@ updateReceivers uid = do `E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser) E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid) E.&&. (usrSuper E.^. UserSupervisorRerouteNotifications) - pure (usrSuper, usrAvs) + pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId) ) let (superVs, avsIds) = unzip avsSupers - toUpdate = Set.fromList . fmap (userAvsPersonId . entityVal) $ catMaybes (avsUnderling : avsIds) - receiverIDs :: [UserId] = userSupervisorSupervisor . entityVal <$> superVs + receiverIDs :: [UserId] = E.unValue <$> superVs + underlingAvsId = userAvsPersonId . entityVal <$> avsUnderling + toUpdate = Set.fromList $ catMaybes (underlingAvsId : (E.unValue <$> avsIds)) directResult = return (underling, pure underling, True) forM_ toUpdate (void . maybeCatchAll . upsertAvsUserById) -- attempt to update postaddress from AVS if null receiverIDs From 6f9e657dd522b519258ae280de4c3ea61201ab83 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 Feb 2023 11:55:11 +0100 Subject: [PATCH 2/5] Update models/users.model --- models/users.model | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/users.model b/models/users.model index 77a330744..38305c4f0 100644 --- a/models/users.model +++ b/models/users.model @@ -88,8 +88,8 @@ UserGroupMember UserCompany user UserId company CompanyId OnDeleteCascade OnUpdateCascade - supervisor Bool -- should this user be made supervisor for all _new_ users associated with this company? - supervisorReroute Bool default=true -- if supervisor is true, should this supervisor receive email for _new_ company users? + supervisor Bool default=false -- should this user be made supervisor for all _new_ users associated with this company? + supervisorReroute Bool default=false -- if supervisor is true, should this supervisor receive email for _new_ company users? UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once deriving Generic UserSupervisor From f0b20a1b263a072a9811ff677f25e6518d314133 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 Feb 2023 12:56:56 +0100 Subject: [PATCH 3/5] fix(print): disable default filter for print acknowledged --- src/Handler/PrintCenter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 29e7a89a2..fd64b55a7 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -280,7 +280,7 @@ mkPJTable = do let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap return (act, jobSet) psValidator = def & defaultSorting [SortAscBy "created"] - & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) + -- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: interferes with sorting! over _1 postprocess <$> dbTable psValidator DBTable{..} getPrintCenterR, postPrintCenterR :: Handler Html From 430de83366e44c681977acb0123939787544cf0c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 Feb 2023 16:46:41 +0100 Subject: [PATCH 4/5] chore(email): use userDisplayEmail primarily, userEmail as fallback only --- .../categories/jobs_handler/de-de-formal.msg | 6 ++--- .../uniworx/categories/jobs_handler/en-eu.msg | 6 ++--- .../categories/settings/de-de-formal.msg | 9 ++++---- .../uniworx/categories/settings/en-eu.msg | 7 +++--- .../uniworx/categories/user/de-de-formal.msg | 4 ++-- messages/uniworx/categories/user/en-eu.msg | 4 ++-- .../navigation/breadcrumbs/de-de-formal.msg | 2 +- .../utils/navigation/breadcrumbs/en-eu.msg | 2 +- src/Foundation/Instances.hs | 2 +- src/Handler/Course/Edit.hs | 2 +- src/Handler/Course/Show.hs | 2 +- src/Handler/Course/User.hs | 23 ++++++++----------- src/Handler/Exam/Form.hs | 2 +- src/Handler/ExamOffice/Users.hs | 2 +- src/Handler/ExternalExam/Form.hs | 2 +- src/Handler/LMS.hs | 2 +- src/Handler/Qualification.hs | 2 +- src/Handler/Sheet/Form.hs | 4 ++-- src/Handler/Submission/Assign.hs | 6 ++--- src/Handler/Submission/Helper.hs | 2 +- src/Handler/Tutorial/Form.hs | 2 +- src/Handler/Users.hs | 6 ++--- src/Handler/Utils/Mail.hs | 13 ++++++----- src/Handler/Utils/Profile.hs | 10 ++++++-- src/Handler/Utils/Table/Cells.hs | 2 +- src/Handler/Utils/Table/Columns.hs | 6 ++--- src/Handler/Utils/Widgets.hs | 3 +++ templates/correction-user.hamlet | 4 ++-- .../course/lecturerMassInput/cellKnown.hamlet | 2 +- templates/course/user/profile.hamlet | 2 +- templates/external-exam-show.hamlet | 4 ++-- .../staffMassInput/cellKnown.hamlet | 2 +- .../i18n/data-delete/de-de-formal.hamlet | 2 +- templates/i18n/data-delete/en-eu.hamlet | 2 +- templates/profileData.hamlet | 12 +++++----- templates/tutorial-participants.hamlet | 4 ++-- .../tutorial/tutorMassInput/cellKnown.hamlet | 2 +- .../massinput/examCorrectors/cellKnown.hamlet | 2 +- .../examOfficeUsers/cellKnown.hamlet | 2 +- .../submissionUsers/cellKnown.hamlet | 4 ++-- 40 files changed, 92 insertions(+), 85 deletions(-) diff --git a/messages/uniworx/categories/jobs_handler/de-de-formal.msg b/messages/uniworx/categories/jobs_handler/de-de-formal.msg index 3deea807d..2f14791ac 100644 --- a/messages/uniworx/categories/jobs_handler/de-de-formal.msg +++ b/messages/uniworx/categories/jobs_handler/de-de-formal.msg @@ -12,9 +12,9 @@ CommUndisclosedRecipients: Verborgene Empfänger:innen CommAllRecipients: alle-empfaenger CommAllRecipientsSheet: Empfänger:innen ResetPassword: FRADrive-Passwort ändern bzw. setzen -MailSubjectChangeUserDisplayEmail: Diese E-Mail-Adresse in FRADrive veröffentlichen -MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutzer/Die oben genannte Benutzerin möchte „#{displayEmail}“ als öffentliche Adresse, assoziiert mit sich selbst, angeben. Wenn Sie diese Aktion nicht selbst ausgelöst haben, ignorieren Sie diese Mitteilung bitte! -MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E-Mail-Adresse in FRADrive veröffentlichen +MailSubjectChangeUserDisplayEmail: E-Mail-Adresse in FRADrive verwenden +MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutzer/Die oben genannte Benutzerin möchte „#{displayEmail}“ als E-Mail-Adresse in FRADrive verwenden. Wenn Sie diese Aktion nicht selbst ausgelöst haben, ignorieren Sie diese Mitteilung bitte! +MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E-Mail-Adresse in FRADrive verwenden CommCourseSubject: Kursmitteilung InvitationAcceptDecline: Einladung annehmen/ablehnen InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in FRADrive ausgelöst hat. diff --git a/messages/uniworx/categories/jobs_handler/en-eu.msg b/messages/uniworx/categories/jobs_handler/en-eu.msg index 2169d8d2d..77e0a96f9 100644 --- a/messages/uniworx/categories/jobs_handler/en-eu.msg +++ b/messages/uniworx/categories/jobs_handler/en-eu.msg @@ -12,9 +12,9 @@ CommUndisclosedRecipients: Undisclosed recipients CommAllRecipients: all-recipients CommAllRecipientsSheet: Recipients ResetPassword: Reselt FRADrive password -MailSubjectChangeUserDisplayEmail: Publishing this email address in FRADrive -MailIntroChangeUserDisplayEmail displayEmail: The user mentioned above wants to publish “#{displayEmail}” as their own email address. If you have not caused this email to be sent, please ignore it! -MailTitleChangeUserDisplayEmail displayName: #{displayName} wants to publish this email address as their own in FRADrive +MailSubjectChangeUserDisplayEmail: Set email address in FRADrive +MailIntroChangeUserDisplayEmail displayEmail: The user mentioned above wants to set “#{displayEmail}” as their own email address. If you have not caused this email to be sent, please ignore it! +MailTitleChangeUserDisplayEmail displayName: #{displayName} wants to set this email address as their own in FRADrive CommCourseSubject: Course message InvitationAcceptDecline: Accept/Decline invitation InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within FRADrive. diff --git a/messages/uniworx/categories/settings/de-de-formal.msg b/messages/uniworx/categories/settings/de-de-formal.msg index f04b1cde1..189f226e5 100644 --- a/messages/uniworx/categories/settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/de-de-formal.msg @@ -8,9 +8,11 @@ FormPersonalAppearance: Öffentliche Daten UserDisplayName: Angezeigter Name UserDisplayNameInvalid: Angezeigter Name erfüllt nicht die Vorgaben UserDisplayNameRulesBelow: Vorgaben für den angezeigten Namen finden sich weiter unten auf der Seite -UserDisplayEmail: Angezeigte E-Mail-Adresse -UserDisplayEmailTip: Diese Adresse wird in öffentlich zugänglichen Teilen des Systems im Zusammenhang mit Ihrem Namen angezeigt. Benachrichtigungen und andere Kommunikation von Uni2work und Nutzer:innen mit erweiterten Rechten erhalten sie stets, unabhängig von dieser Einstellung, an die in Ihren Persönlichen Daten hinterlegte primäre Adresse. -UserDisplayEmailChangeSent displayEmail@UserEmail: Anweisungen zum Ändern der angezeigten E-Mail-Adresse wurden an „#{displayEmail}” versandt +UserSystemEmail: System E-Mail Adresse +UserDisplayEmail: E-Mail-Adresse +UserDisplayEmailTip: Diese Adresse wird in öffentlich zugänglichen Teilen des Systems im Zusammenhang mit Ihrem Namen angezeigt. Falls diese ungültig ist gehen Benachrichtigungen an ihre System E-Mail-Adresse. +UserDisplayEmailChangeSent displayEmail@UserEmail: Anweisungen zum Ändern der E-Mail-Adresse wurden an „#{displayEmail}” versandt +UserDisplayEmailChanged: Öffentliche E-Mail-Adresse erfolgreich gesetzt FormCosmetics: Oberfläche @@ -94,7 +96,6 @@ ProfileLdapPrimaryKey: LDAP-Primärschlüssel NotificationSettingsUpdate: Benachrichtigungs-Einstellungen erfolgreich gespeichert NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName} -UserDisplayEmailChanged: Öffentliche E-Mail-Adresse erfolgreich gesetzt FavouriteVisited: Kürzlich besucht FavouriteParticipant: Ihre Kurse FavouriteManual: Favoriten diff --git a/messages/uniworx/categories/settings/en-eu.msg b/messages/uniworx/categories/settings/en-eu.msg index 3c63fc06a..6dbf5dd95 100644 --- a/messages/uniworx/categories/settings/en-eu.msg +++ b/messages/uniworx/categories/settings/en-eu.msg @@ -8,9 +8,11 @@ FormPersonalAppearance: Public data UserDisplayName: Display name UserDisplayNameInvalid: Display name does not comply with specification UserDisplayNameRulesBelow: Specifications of what can be a display name can be found below -UserDisplayEmail: Display email -UserDisplayEmailTip: This email address may be displayed publicly alongside your display name. Notifications and other communication from Uni2work or users with elevated permissions are always sent to your primary email address as specified under "personal information". +UserSystemEmail: System Email address +UserDisplayEmail: Email +UserDisplayEmailTip: This email address may be displayed publicly alongside your display name. If invalid, notifications will be sent to your system email address instead. UserDisplayEmailChangeSent displayEmail: Instructions to change your display email have been sent to “#{displayEmail}”. +UserDisplayEmailChanged: Successfully set display email FormCosmetics: Interface @@ -94,7 +96,6 @@ ProfileLdapPrimaryKey: LDAP primary key NotificationSettingsUpdate: Successfully updated notification settings NotificationSettingsHeading displayName: Notification settings for #{displayName} -UserDisplayEmailChanged: Successfully set display email FavouriteVisited: Visited FavouriteParticipant: Your courses FavouriteManual: Favourites diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 459ba2255..85ef0f47b 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -6,8 +6,8 @@ AdminUserTitle: Titel AdminUserFirstName: Vorname AdminUserSurname: Nachname AdminUserDisplayName: Anzeige-Name -AdminUserEmail: E-Mail-Adresse -AdminUserDisplayEmail: Anzeige-E-Mail +AdminUserEmail: System E-Mail +AdminUserDisplayEmail: E-Mail-Adresse AdminUserIdent: Identifikation AdminUserAuth: Authentifizierung AdminUserAuthTooltip: Abhängig von der Auswahl werden neue Benutzer über ihr neues FRADrive Konto benachrichtigt. diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 9d51a29a3..8fd7c0333 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -6,8 +6,8 @@ AdminUserTitle: Title AdminUserFirstName: Given name AdminUserSurname: Surname AdminUserDisplayName: Display name -AdminUserEmail: Email address -AdminUserDisplayEmail: Display email +AdminUserEmail: System Email address +AdminUserDisplayEmail: Email address AdminUserIdent: Identification AdminUserAuth: Authentication AdminUserAuthTooltip: New users may be notified about their FRADrive account depending on this choice. diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 15be16d0d..684e91f5e 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -88,7 +88,7 @@ BreadcrumbVersion: Versionsgeschichte BreadcrumbHelp: Hilfe BreadcrumbHealth: Instanz-Zustand BreadcrumbInstance: Instanz-Identifikation -BreadcrumbUserDisplayEmail: Angezeigte E-Mail-Adresse +BreadcrumbUserDisplayEmail: E-Mail-Adresse BreadcrumbProfileData: Persönliche Daten BreadcrumbAuthPreds: Authorisierungseinstellungen BreadcrumbTermShow: Semester diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index bce374d79..705ec1d6c 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -88,7 +88,7 @@ BreadcrumbVersion: Version history BreadcrumbHelp: Support BreadcrumbHealth: Instance health BreadcrumbInstance: Instance identification -BreadcrumbUserDisplayEmail: Display email +BreadcrumbUserDisplayEmail: Email address BreadcrumbProfileData: Personal information BreadcrumbAuthPreds: Authorisation settings BreadcrumbTermShow: Semesters diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 5881af647..b7d6a555b 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -259,8 +259,8 @@ instance YesodMail UniWorX where return user let recipUserCompare = mconcat [ comparing $ Down . (== recipAddr) . userIdent . entityVal - , comparing $ Down . (== recipAddr) . userEmail . entityVal , comparing $ Down . (== recipAddr) . userDisplayEmail . entityVal + , comparing $ Down . (== recipAddr) . userEmail . entityVal ] return $ if | ( bU : us ) <- sortBy recipUserCompare recipUsers diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 1c0a6b5b6..127056489 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -117,7 +117,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) miCell _ (Right lid) defType nudge = \csrf -> do (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType) - User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ get404 lid + usr <- liftHandler . runDB $ get404 lid let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") return (Just <$> lrwRes,lrwView') miCell _ (Left lEmail) defType nudge = \csrf -> do diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index ed75bad81..618a7559c 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -168,7 +168,7 @@ getCShowR tid ssh csh = do tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid - return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname) + return (user E.^. UserDisplayEmail, user E.^. UserDisplayName, user E.^. UserSurname) return [whamlet| $newline never
    diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 1f9a7a247..b7e54719c 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -11,27 +11,24 @@ import Import import Utils.Form import Handler.Utils import Handler.Utils.SheetType -import Database.Esqueleto.Utils.TH - -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E - -import Database.Persist.Sql (deleteWhereCount) - -import Text.Blaze.Html.Renderer.Text (renderHtml) +import Handler.Utils.Profile (pickValidEmail) +import Handler.Utils.StudyFeatures +import Handler.Submission.List import Handler.Course.Register import Jobs.Queue -import Handler.Submission.List +import Database.Persist.Sql (deleteWhereCount) +import Database.Esqueleto.Utils.TH +import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Utils as E -import Handler.Utils.StudyFeatures +import Text.Blaze.Html.Renderer.Text (renderHtml) import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI - import qualified Data.Text.Lazy as LT @@ -444,9 +441,9 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do [whamlet| $newline never
      - $forall (Entity _ User{userEmail, userDisplayName, userSurname}) <- tutors + $forall (Entity _ usr) <- tutors
    • - ^{nameEmailWidget userEmail userDisplayName userSurname} + ^{userEmailWidget usr} |] , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom) , sortable Nothing (i18nCell MsgTableTutorialTime) $ occurrencesCell . view (_dbrOutput . _1 . _entityVal . _tutorialTime) diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 1a4b64bc1..34277e5cb 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -240,7 +240,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning $(widgetFile "widgets/massinput/examCorrectors/cellInvitation") miCell' (Right userId) = do - User{..} <- liftHandler . runDB $ get404 userId + usr <- liftHandler . runDB $ get404 userId $(widgetFile "widgets/massinput/examCorrectors/cellKnown") miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index a0f4c17e0..b8f422cfb 100644 --- a/src/Handler/ExamOffice/Users.hs +++ b/src/Handler/ExamOffice/Users.hs @@ -112,7 +112,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning $(widgetFile "widgets/massinput/examOfficeUsers/cellInvitation") miCell' (Right uid) = do - User{..} <- liftHandler . runDB $ getJust uid + usr <- liftHandler . runDB $ getJust uid $(widgetFile "widgets/massinput/examOfficeUsers/cellKnown") miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag diff --git a/src/Handler/ExternalExam/Form.hs b/src/Handler/ExternalExam/Form.hs index ba7409a61..58accf506 100644 --- a/src/Handler/ExternalExam/Form.hs +++ b/src/Handler/ExternalExam/Form.hs @@ -100,7 +100,7 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning $(widgetFile "external-exam/staffMassInput/cellInvitation") miCell (Right userId) = do - User{..} <- liftHandler . runDB $ getJust userId + usr <- liftHandler . runDB $ getJust userId $(widgetFile "external-exam/staffMassInput/cellKnown") miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction = Just . SomeRoute . (cRoute :#:) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 97be8be55..8276ca7b8 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -452,7 +452,7 @@ mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do doEncode' :: LmsTableData -> LmsTableCsv doEncode' = LmsTableCsv <$> view (resultUser . _entityVal . _userDisplayName) - <*> view (resultUser . _entityVal . _userEmail) + <*> view (resultUser . _entityVal . _userDisplayEmail) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 0f274f3f2..945a27ef9 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -330,7 +330,7 @@ mkQualificationTable (Entity qid quali) acts cols psValidator = do doEncode' :: QualificationTableData -> QualificationTableCsv doEncode' = QualificationTableCsv <$> view (resultUser . _entityVal . _userDisplayName) - <*> view (resultUser . _entityVal . _userEmail) + <*> view (resultUser . _entityVal . _userDisplayEmail) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 14805015b..ee01d5d4e 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -307,8 +307,8 @@ correctorForm loads' = wFormToAForm $ do identWidget <- case userIdent of Left email -> return . toWidget $ mailtoHtml email Right uid -> do - User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid - return $ nameEmailWidget userEmail userDisplayName userSurname + usr <- liftHandler . runDB $ getJust uid + return $ userEmailWidget usr invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning return (res, $(widgetFile "sheetCorrectors/cell")) diff --git a/src/Handler/Submission/Assign.hs b/src/Handler/Submission/Assign.hs index 95dc1b574..916db5e82 100644 --- a/src/Handler/Submission/Assign.hs +++ b/src/Handler/Submission/Assign.hs @@ -231,10 +231,8 @@ assignHandler tid ssh csh cid assignSids = do -- avoid nestes hamlet $maybe with duplicated $nothing getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector, Text) getCorrector (Just uid) - | Just (User{..},loadMap) <- Map.lookup uid correctorMap - = (nameEmailWidget userEmail userDisplayName userSurname, loadMap, userDisplayName) - -- | Just (User{..} ) <- Map.lookup uid lecturerNames - -- = (nameEmailWidget userEmail userDisplayName userSurname, mempty) -- lecturers may also correct in rare cases + | Just (usr,loadMap) <- Map.lookup uid correctorMap + = (userEmailWidget usr, loadMap, usr ^. _userDisplayName) getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty, mempty) -- avoid nestes hamlet $maybe with duplicated $nothing getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index 05dbc4d2c..98d868b94 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -79,7 +79,7 @@ makeSubmissionForm cid shid mASDefinition msmid uploadMode grouping mPrev isLect | otherwise -> MsgEmailInvitationWarningPrevCoSubmittors $(widgetFile "widgets/massinput/submissionUsers/cellInvitation") miCell' csrf (Right uid) = do - (User{..}, hasSubmitted) <- liftHandler . runDB $ do + (usr, hasSubmitted) <- liftHandler . runDB $ do user <- getJust uid hasSubmitted <- E.selectExists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs index 945abd68a..22ac01d81 100644 --- a/src/Handler/Tutorial/Form.hs +++ b/src/Handler/Tutorial/Form.hs @@ -63,7 +63,7 @@ tutorialForm cid template html = do invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning $(widgetFile "tutorial/tutorMassInput/cellInvitation") miCell' (Right userId) = do - User{..} <- liftHandler . runDB $ get404 userId + usr <- liftHandler . runDB $ get404 userId $(widgetFile "tutorial/tutorMassInput/cellKnown") miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 1ee201656..25570eba1 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -589,7 +589,7 @@ postAdminUserR uuid = do formResult systemFunctionsResult userSystemFunctionsAction formResult assimilateFormResult assimilateAction let heading = - [whamlet|_{MsgAdminUserHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] + [whamlet|_{MsgAdminUserHeadingFor} ^{userEmailWidget user}|] -- Delete Button needed in data-delete (deleteWgt, deleteEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete) let deleteForm = wrapForm deleteWgt def @@ -666,7 +666,7 @@ getUserPasswordR, postUserPasswordR :: CryptoUUIDUser -> Handler Html getUserPasswordR = postUserPasswordR postUserPasswordR cID = do tUid <- decrypt cID - User{..} <- runDB $ get404 tUid + usr@User{..} <- runDB $ get404 tUid PWHashConf{..} <- getsYesod $ view _appAuthPWHash isModal <- hasCustomHeader HeaderIsModal @@ -704,7 +704,7 @@ postUserPasswordR cID = do liftHandler . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ] tell . pure =<< messageI Success MsgPasswordChangedSuccess - siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] $ + siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{userEmailWidget usr}|] $ wrapForm passFormWidget def { formAction = Just . SomeRoute $ UserPasswordR cID , formEncoding = passEnctype diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index f585de16a..154d7e219 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -16,6 +16,7 @@ import Handler.Utils.Pandoc import Handler.Utils.Files import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here? import Handler.Utils.Users (getReceivers) +import Handler.Utils.Profile (pickValidEmail) import qualified Data.CaseInsensitive as CI @@ -34,8 +35,8 @@ addRecipientsDB :: ( MonadMail m -- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient where - addRecipient (Entity _ User{userEmail, userDisplayName}) = do - let addr = Address (Just userDisplayName) $ CI.original userEmail + addRecipient (Entity _ User{userEmail, userDisplayEmail, userDisplayName}) = do + let addr = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail _mailTo %= flip snoc addr userAddressFrom :: User -> Address @@ -47,9 +48,9 @@ userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisp userAddress :: User -> Address -- ^ Format an e-mail address suitable for usage as a recipient -- --- Uses `userEmail` -userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail - +-- Like userAddressFrom and no longer uses `userEmail`, since unlike Uni2work, userEmail from LDAP is untrustworthy. +userAddress User{userEmail, userDisplayEmail, userDisplayName} + = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail -- | Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True userMailT :: ( MonadHandler m @@ -60,7 +61,7 @@ userMailT :: ( MonadHandler m userMailT uid mAct = do (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid let undername = underling ^. _userDisplayName -- nameHtml' underling - undermail = CI.original $ underling ^. _userEmail + undermail = CI.original $ pickValidEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail) infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|

      _{MsgMailSupervisedNote}

      diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 703b618b5..23e355232 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -9,7 +9,7 @@ module Handler.Utils.Profile , validDisplayName , fixDisplayName , validPostAddress - , validEmail, validEmail' + , validEmail, validEmail', pickValidEmail ) where import Import.NoFoundation @@ -83,4 +83,10 @@ validEmail :: Email -> Bool -- Email = Text validEmail = Email.isValid . encodeUtf8 validEmail' :: UserEmail -> Bool -- UserEmail = CI Text -validEmail' = Email.isValid . encodeUtf8 . CI.original \ No newline at end of file +validEmail' = Email.isValid . encodeUtf8 . CI.original + +-- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function +pickValidEmail :: UserEmail -> UserEmail -> UserEmail +pickValidEmail x y + | validEmail' x = x + | otherwise = y \ No newline at end of file diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 835a69652..0a242ed1c 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -207,7 +207,7 @@ cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer cellHasEMail :: (IsDBTable m a, HasUser u) => u -> DBCell m a -cellHasEMail = emailCell . view _userEmail +cellHasEMail = emailCell . view _userDisplayEmail cellHasSemester :: (IsDBTable m c, HasStudyFeatures a) => a -> DBCell m c diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 1136fdbe1..46993b5fc 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -398,7 +398,7 @@ fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName) , mkContainsFilter $ queryUser >>> (E.^. UserSurname) - , mkContainsFilterWith CI.mk $ queryUser >>> (E.^. UserEmail) + , mkContainsFilterWith CI.mk $ queryUser >>> (E.^. UserDisplayEmail) ] ) @@ -463,14 +463,14 @@ colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) colUserEmail = sortable (Just "user-email") (i18nCell MsgTableEmail) cellHasEMail sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') -sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail)) +sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserDisplayEmail)) fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool)) , IsString d ) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t fs) -fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserEmail)) +fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserDisplayEmail)) fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserEmailUI mPrev = diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 52d205d30..6f70a5d57 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -64,6 +64,9 @@ linkUserWidget lnk (Entity uid usr) = do uuid <- encrypt uid simpleLink (userWidget usr) (lnk uuid) +userEmailWidget :: HasUser c => c -> Widget +userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname) + -- | toWidget-Version of @nameEmailHtml@, for convenience nameEmailWidget :: UserEmail -- ^ userEmail -> Text -- ^ userDisplayName diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet index c7ca6dc6e..cefd0b5e9 100644 --- a/templates/correction-user.hamlet +++ b/templates/correction-user.hamlet @@ -9,10 +9,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgTableSubmission} #{cid} - $maybe Entity _ User{userDisplayName, userSurname, userEmail} <- corrector + $maybe Entity _ usr <- corrector _{MsgRatingBy} - ^{nameEmailWidget userEmail userDisplayName userSurname} + ^{userEmailWidget usr} $maybe time <- submissionRatingTime _{MsgTableRatingTime} diff --git a/templates/course/lecturerMassInput/cellKnown.hamlet b/templates/course/lecturerMassInput/cellKnown.hamlet index 5a54a5a66..1373eb9a1 100644 --- a/templates/course/lecturerMassInput/cellKnown.hamlet +++ b/templates/course/lecturerMassInput/cellKnown.hamlet @@ -6,6 +6,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{csrf} - ^{nameEmailWidget userEmail userDisplayName userSurname} # + ^{userEmailWidget usr} # ^{fvWidget lrwView} diff --git a/templates/course/user/profile.hamlet b/templates/course/user/profile.hamlet index 26593b9b4..b43e61c70 100644 --- a/templates/course/user/profile.hamlet +++ b/templates/course/user/profile.hamlet @@ -24,7 +24,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

      _{MsgTableSex}
      _{sex}
      _{MsgTableEmail} -
      #{mailtoHtml userEmail} +
      #{mailtoHtml (pickValidEmail userDisplayEmail userEmail)} $maybe date <- mRegAt
      _{MsgRegisteredSince}
      #{date} diff --git a/templates/external-exam-show.hamlet b/templates/external-exam-show.hamlet index 9759a739f..7c9463ffb 100644 --- a/templates/external-exam-show.hamlet +++ b/templates/external-exam-show.hamlet @@ -52,9 +52,9 @@ $maybe ExternalExamResult{externalExamResultResult} <- mResult
        $forall s <- staff $case s - $of Right (Entity _ User{userDisplayName, userDisplayEmail, userSurname}) + $of Right (Entity _ usr)
      • - ^{nameEmailWidget userDisplayEmail userDisplayName userSurname} + ^{userEmailWidget usr} $of Left email
      • #{email} diff --git a/templates/external-exam/staffMassInput/cellKnown.hamlet b/templates/external-exam/staffMassInput/cellKnown.hamlet index 412c4065a..a5e351d33 100644 --- a/templates/external-exam/staffMassInput/cellKnown.hamlet +++ b/templates/external-exam/staffMassInput/cellKnown.hamlet @@ -5,4 +5,4 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later - ^{nameEmailWidget userEmail userDisplayName userSurname} + ^{userEmailWidget usr} diff --git a/templates/i18n/data-delete/de-de-formal.hamlet b/templates/i18n/data-delete/de-de-formal.hamlet index bc1eea113..81fdcaaab 100644 --- a/templates/i18n/data-delete/de-de-formal.hamlet +++ b/templates/i18n/data-delete/de-de-formal.hamlet @@ -6,7 +6,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

        Sind Sie sich absolut sicher - Benutzer:in ^{nameEmailWidget userEmail userDisplayName userSurname} zu löschen? + Benutzer:in ^{userEmailWidget user} zu löschen?

        Während der Testphase von Uni2work werden Benutzer:innen hiermit vollständig aus der Live-Datenbank mit diff --git a/templates/i18n/data-delete/en-eu.hamlet b/templates/i18n/data-delete/en-eu.hamlet index cbed3f47a..5b7a5fdb4 100644 --- a/templates/i18n/data-delete/en-eu.hamlet +++ b/templates/i18n/data-delete/en-eu.hamlet @@ -5,7 +5,7 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later

        - Are you sure that you want to permanently delete ^{nameEmailWidget userEmail userDisplayName userSurname}? + Are you sure that you want to permanently delete ^{userEmailWidget user}?

        During the testing phase users are deleted wholly from the live database via DELETE CASCADE uid diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 90d221b3e..39f593166 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -54,14 +54,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

        ^{formatTimeW SelFormatDateTime postUpdate}
        - _{MsgTableEmail} -
        - #{mailtoHtml userEmail} + _{MsgUserDisplayEmail} +
        + #{userDisplayEmail} $if userEmail /= userDisplayEmail
        - _{MsgUserDisplayEmail} -
        - #{userDisplayEmail} + _{MsgUserSystemEmail} +
        + #{mailtoHtml userEmail}
        _{MsgAdminUserPinPassword}
        diff --git a/templates/tutorial-participants.hamlet b/templates/tutorial-participants.hamlet index 243887682..c01779c73 100644 --- a/templates/tutorial-participants.hamlet +++ b/templates/tutorial-participants.hamlet @@ -12,7 +12,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
        _{MsgTableTutorialTutors}
          - $forall (Entity _ User{userDisplayName, userDisplayEmail, userSurname}) <- tutors + $forall (Entity _ usr) <- tutors
        • - ^{nameEmailWidget userDisplayEmail userDisplayName userSurname} + ^{userEmailWidget usr} ^{participantTable} diff --git a/templates/tutorial/tutorMassInput/cellKnown.hamlet b/templates/tutorial/tutorMassInput/cellKnown.hamlet index 3769671c1..30b5b6e46 100644 --- a/templates/tutorial/tutorMassInput/cellKnown.hamlet +++ b/templates/tutorial/tutorMassInput/cellKnown.hamlet @@ -5,4 +5,4 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later - ^{nameEmailWidget userEmail userDisplayName userSurname} + ^{userEmailWidget usr} diff --git a/templates/widgets/massinput/examCorrectors/cellKnown.hamlet b/templates/widgets/massinput/examCorrectors/cellKnown.hamlet index 3769671c1..30b5b6e46 100644 --- a/templates/widgets/massinput/examCorrectors/cellKnown.hamlet +++ b/templates/widgets/massinput/examCorrectors/cellKnown.hamlet @@ -5,4 +5,4 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later - ^{nameEmailWidget userEmail userDisplayName userSurname} + ^{userEmailWidget usr} diff --git a/templates/widgets/massinput/examOfficeUsers/cellKnown.hamlet b/templates/widgets/massinput/examOfficeUsers/cellKnown.hamlet index 412c4065a..a5e351d33 100644 --- a/templates/widgets/massinput/examOfficeUsers/cellKnown.hamlet +++ b/templates/widgets/massinput/examOfficeUsers/cellKnown.hamlet @@ -5,4 +5,4 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later - ^{nameEmailWidget userEmail userDisplayName userSurname} + ^{userEmailWidget usr} diff --git a/templates/widgets/massinput/submissionUsers/cellKnown.hamlet b/templates/widgets/massinput/submissionUsers/cellKnown.hamlet index c69ef391e..2397c3c49 100644 --- a/templates/widgets/massinput/submissionUsers/cellKnown.hamlet +++ b/templates/widgets/massinput/submissionUsers/cellKnown.hamlet @@ -7,10 +7,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $maybe wrn <- knownWarning #{csrf} - ^{nameEmailWidget userEmail userDisplayName userSurname} + ^{userEmailWidget usr} ^{messageTooltip wrn} $nothing #{csrf} - ^{nameEmailWidget userEmail userDisplayName userSurname} + ^{userEmailWidget usr} From c3b6d186c4ed3cd22a746956bbaf09935a699fa3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 Feb 2023 17:39:59 +0100 Subject: [PATCH 5/5] chore(avs): allow companies without postal address --- models/avs.model | 1 + src/Handler/Utils/Avs.hs | 49 +++++++++++++++++------------------- src/Handler/Utils/Company.hs | 17 +++++++------ src/Utils/Avs.hs | 19 +++++--------- 4 files changed, 39 insertions(+), 47 deletions(-) diff --git a/models/avs.model b/models/avs.model index 371a3dae0..45f2321d7 100644 --- a/models/avs.model +++ b/models/avs.model @@ -23,6 +23,7 @@ UserAvs -- Multiple UserAvsCards per UserAvs is possible and not too uncommon. -- Purpose of saving cards is to detect external changes in qualifications and postal addresses +-- TODO: This table will be deleted if AVS CR3 SCF-165 is implemented UserAvsCard personId AvsPersonId cardNo AvsFullCardNo diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 177dabfa2..db27e663b 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -393,29 +393,28 @@ upsertAvsUserById api = do case (mbuid, mbapd) of ( _ , Nothing ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet (Nothing, Just AvsDataPerson{avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname, ..}) -> do -- No LDAP User, but found in AVS; create new user - let firmAddress = guessLicenceAddress avsPersonPersonCards - mbCompany = firmAddress ^? _Just . _1 . _Just - userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress + let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards + userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr pinCard = Set.lookupMax avsPersonPersonCards userPin = personCard2pin <$> pinCard fakeIdent = CI.mk $ "AVSID:" <> tshow api fakeNo = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo newUsr = AddUserData - { audTitle = Nothing - , audFirstName = avsFirstName - , audSurname = avsSurname - , audDisplayName = avsFirstName <> Text.cons ' ' avsSurname - , audDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) - , audMatriculation = Nothing - , audSex = Nothing - , audBirthday = Nothing - , audMobile = Nothing - , audTelephone = Nothing - , audFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo - , audFDepartment = Nothing - , audPostAddress = userFirmAddr - , audPrefersPostal = True - , audPinPassword = userPin + { audTitle = Nothing + , audFirstName = avsFirstName + , audSurname = avsSurname + , audDisplayName = avsFirstName <> Text.cons ' ' avsSurname + , audDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) + , audMatriculation = Nothing + , audSex = Nothing + , audBirthday = Nothing + , audMobile = Nothing + , audTelephone = Nothing + , audFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo + , audFDepartment = Nothing + , audPostAddress = userFirmAddr + , audPrefersPostal = True + , audPinPassword = userPin , audEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) , audIdent = fakeIdent -- use AvsPersonId instead , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known @@ -424,24 +423,22 @@ upsertAvsUserById api = do whenIsJust mbUid $ \uid -> runDB $ do now <- liftIO getCurrentTime insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo - forM_ avsPersonPersonCards $ -- save all cards for later + forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard] -- forM_ cs $ -- only save used cards for the postal address update detection \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (getFullCardNo avsCard) avsCard now - upsertUserCompany uid mbCompany + upsertUserCompany uid mbCompany userFirmAddr return mbUid (Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword - let firmAddress = guessLicenceAddress avsPersonPersonCards - mbCompany = firmAddress ^? _Just . _1 . _Just - mbCoFirmAddr= mergeCompanyAddress <$> firmAddress + let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr pinCard = Set.lookupMax avsPersonPersonCards - userPin = personCard2pin <$> pinCard + userPin = personCard2pin <$> pinCard runDB $ do now <- liftIO getCurrentTime oldCards <- selectList [UserAvsCardPersonId ==. api] [] - let oldAddrs = Set.fromList $ mapMaybe (maybeCompanyAddress . userAvsCardCard . entityVal) oldCards + let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before encRecipient :: CryptoUUIDUser <- encrypt uid $logInfoS "AVS" $ "Postal address updated for" <> tshow encRecipient @@ -452,7 +449,7 @@ upsertAvsUserById api = do updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins] [UserPinPassword =. userPin] insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now - upsertUserCompany uid mbCompany + upsertUserCompany uid mbCompany userFirmAddr forM_ avsPersonPersonCards $ \aCard -> void $ upsert UserAvsCard { userAvsCardPersonId = api , userAvsCardCardNo = getFullCardNo aCard diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 74990a803..1b8b9dafa 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -15,9 +15,9 @@ import qualified Data.Text as Text import Database.Persist.Postgresql -- | Ensure that the given user is linked to the given company -upsertUserCompany :: UserId -> Maybe Text -> DB () -upsertUserCompany uid (Just cName) | notNull cName = do - cid <- upsertCompany cName +upsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () +upsertUserCompany uid (Just cName) cAddr | notNull cName = do + cid <- upsertCompany cName cAddr void $ upsertBy (UniqueUserCompany uid cid) (UserCompany uid cid False False) [] @@ -25,12 +25,13 @@ upsertUserCompany uid (Just cName) | notNull cName = do upsertManyWhere [ UserSupervisor super uid reroute | Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs ] [] [] [] -upsertUserCompany uid _ = +upsertUserCompany uid _ _ = deleteWhere [ UserCompanyUser ==. uid ] -- maybe also delete company supervisors? - -upsertCompany :: Text -> DB CompanyId -upsertCompany cName = +-- | Does not update company address for now +-- TODO: update company address, maybe?! +upsertCompany :: Text -> Maybe StoredMarkup -> DB CompanyId +upsertCompany cName cAddr = let cName' = CI.mk cName in getBy (UniqueCompanyName cName') >>= \case Just ent -> return $ entityKey ent @@ -39,7 +40,7 @@ upsertCompany cName = Nothing -> do let cShort = companyShorthandFromName cName cShort' <- findShort cName' $ CI.mk cShort - let compy = Company cName' cShort' 0 False Nothing -- TODO + let compy = Company cName' cShort' 0 False cAddr -- TODO: Fix this once AVS CR3 SCF-165 is implemented either entityKey id <$> insertBy compy where findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 78a1183b8..560aa49ad 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -101,30 +101,23 @@ getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) -getCompanyAddress :: AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard) +getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) getCompanyAddress card@AvsDataPersonCard{..} | Just street <- avsDataStreet , Just pcode <- avsDataPostalCode , Just city <- avsDataCity - = Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]], card) - | otherwise = Nothing + = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card) + | isJust avsDataFirm = (avsDataFirm, Nothing, Just card) + | otherwise = (Nothing, Nothing, Nothing) -- | From a set of card, choose the one with the most complete postal address. -- Returns company, postal address and the associated card where the address was taken from -guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard) +guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) guessLicenceAddress cards | Just c <- Set.lookupMax cards , card <- Set.foldr pickLicenceAddress c cards = getCompanyAddress card - | otherwise = Nothing - --- | Helper for guessLicenceAddress or getCompanyAddress -mergeCompanyAddress :: (Maybe Text, Text, a) -> Text -mergeCompanyAddress (Nothing , addr, _) = addr -mergeCompanyAddress (Just firm, addr, _) = firm <> Text.cons '\n' addr - -maybeCompanyAddress :: AvsDataPersonCard -> Maybe Text -maybeCompanyAddress = fmap mergeCompanyAddress . getCompanyAddress + | otherwise = (Nothing, Nothing, Nothing) hasAddress :: AvsDataPersonCard -> Bool hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode