From 91b249e58ba4d839bf3c9324548c4f44caa4be7b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Sep 2019 11:41:18 +0200 Subject: [PATCH 01/11] feat(allocations): show bounds on assignments due to allocation --- messages/uniworx/de.msg | 7 +++- src/Handler/Course/Application/List.hs | 39 ++++++++++++++++++++--- templates/course/applications-list.hamlet | 19 +++++++++++ templates/i18n/changelog/de.hamlet | 6 ++++ 4 files changed, 66 insertions(+), 5 deletions(-) create mode 100644 templates/course/applications-list.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index add0b278e..427941cf4 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1645,4 +1645,9 @@ AdminUserMatriculation: Matrikelnummer AuthKindLDAP: Campus-Kennung AuthKindPWHash: Uni2work-Kennung UserAdded: Benutzer erfolgreich angelegt -UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden \ No newline at end of file +UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden + +CourseAllocationsBounds n@Int: Voraussichtliche Zuteilungen durch #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} +CourseAllocationsBoundCoincide numFirstChoice@Int: Vstl. #{numFirstChoice} Teilnehmer +CourseAllocationsBound numApps@Int numFirstChoice@Int: Vstl. zwischen #{numFirstChoice} und #{numApps} Teilnehmer +CourseAllocationsBoundCapped: Die Anzahl von Zuteilungen wird wmgl. durch die Kurskapazität eingeschränkt \ No newline at end of file diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 23ddd7d60..87184db38 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -210,8 +210,8 @@ embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCApplicationsR = postCApplicationsR postCApplicationsR tid ssh csh = do - table <- runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + (table, allocationsBounds) <- runDB $ do + Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh let allocationLink :: Allocation -> SomeRoute UniWorX @@ -532,10 +532,41 @@ postCApplicationsR tid ssh csh = do psValidator = def & defaultSorting [SortAscBy "user-name"] - dbTableWidget' psValidator DBTable{..} + allocationsBounds' <- E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do + E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation + E.&&. allocationCourse E.^. AllocationCourseCourse E.==. E.val cid + + let numApps addWhere = E.sub_select . E.from $ \courseApplication -> do + E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid + E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation) + addWhere courseApplication + return E.countRows + + numApps' = numApps . const $ return () + + numFirstChoice = numApps $ \courseApplication -> + E.where_ . E.not_ . E.exists . E.from $ \courseApplication' -> do + E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. courseApplication' E.^. CourseApplicationAllocation + E.&&. courseApplication E.^. CourseApplicationUser E.==. courseApplication' E.^. CourseApplicationUser + E.where_ . E.not_ $ E.isNothing (courseApplication E.^. CourseApplicationAllocationPriority) + E.||. E.isNothing (courseApplication' E.^. CourseApplicationAllocationPriority) + E.where_ $ courseApplication' E.^. CourseApplicationAllocationPriority E.>. courseApplication E.^. CourseApplicationAllocationPriority + + return (allocation, numApps', numFirstChoice) + + let + allocationsBounds = [ (allocation, numApps', numFirstChoice', capped) + | (Entity _ allocation, E.Value numApps, E.Value numFirstChoice) <- allocationsBounds' + , let numApps' = maybe id min courseCapacity numApps + numFirstChoice' = maybe id min courseCapacity numFirstChoice + capped = numApps' /= numApps + || numFirstChoice' /= numFirstChoice + ] + + (, allocationsBounds) <$> dbTableWidget' psValidator DBTable{..} let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle siteLayoutMsg title $ do setTitleI title - table + $(widgetFile "course/applications-list") diff --git a/templates/course/applications-list.hamlet b/templates/course/applications-list.hamlet new file mode 100644 index 000000000..9e3adb337 --- /dev/null +++ b/templates/course/applications-list.hamlet @@ -0,0 +1,19 @@ +$newline never +$if not (null allocationsBounds) +

_{MsgCourseAllocationsBounds (length allocationsBounds)} +
+ $forall (Allocation{allocationName}, numApps, numFirstChoice, capped) <- allocationsBounds +
+ #{allocationName} +
+

+ $if numApps == numFirstChoice + _{MsgCourseAllocationsBoundCoincide numFirstChoice} + $else + _{MsgCourseAllocationsBound numApps numFirstChoice} + $if capped +

+ _{MsgCourseAllocationsBoundCapped} + +

_{MsgMenuCourseApplications} +^{table} diff --git a/templates/i18n/changelog/de.hamlet b/templates/i18n/changelog/de.hamlet index 3eb49216d..cfba447d2 100644 --- a/templates/i18n/changelog/de.hamlet +++ b/templates/i18n/changelog/de.hamlet @@ -1,5 +1,11 @@ $newline never
+
+ ^{formatGregorianW 2019 09 12} +
+
    +
  • Abschätzung der durch Zentralanmeldung benötigten Kurskapazität +
    ^{formatGregorianW 2019 09 05}
    From ab4d67eb37d8bede038c67d8a9ed8ed3c1480712 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Sep 2019 14:24:16 +0200 Subject: [PATCH 02/11] Revert "Merge branch '455-datepicker-interagieren-schlecht-mit-modals' into 'master'" This reverts merge request !266 --- frontend/src/utils/form/datepicker.js | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/frontend/src/utils/form/datepicker.js b/frontend/src/utils/form/datepicker.js index 932d3b515..11d7394bc 100644 --- a/frontend/src/utils/form/datepicker.js +++ b/frontend/src/utils/form/datepicker.js @@ -3,7 +3,6 @@ import { Utility } from '../../core/utility'; import moment from 'moment'; const KEYCODE_ESCAPE = 27; -const Z_INDEX_MODAL = 9999; // INTERNAL (Uni2work specific) formats for formatting dates and/or times const FORM_DATE_FORMAT = { @@ -140,16 +139,6 @@ export class Datepicker { // initialize tail.datetime (datepicker) instance this.datepickerInstance = datetime(this._element, { ...datepickerGlobalConfig, ...datepickerConfig }); - // append the datepicker element (dt) to the form - this._element.form.appendChild(this.datepickerInstance.dt); - - // if the input element is in any open modal, increase the z-index of the datepicker and set its position to fixed to avoid repositioning on page scroll - // FIXME: instead of setting the position to fixed, use absolute and reposition (decrease left) - if (this._element.closest('.modal--open')) { - this.datepickerInstance.dt.style.zIndex = Z_INDEX_MODAL; - this.datepickerInstance.dt.style.position = 'fixed'; - } - // register this datepicker instance with the formID of the given element in the datepicker collection const formID = this._element.form.id; const elemID = this._element.id; From 83e1c9418a0461baebd6da8e0d835738d611f188 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Sep 2019 14:38:54 +0200 Subject: [PATCH 03/11] feat(allocations): allow changing course capacity during allocation Also refine display of allocation registration bounds --- messages/uniworx/de.msg | 3 ++- src/Handler/Course/Application/List.hs | 9 +++++++-- src/Handler/Course/Edit.hs | 5 +++-- templates/course/applications-list.hamlet | 7 +++++-- templates/course/applications-list.lucius | 4 ++++ 5 files changed, 21 insertions(+), 7 deletions(-) create mode 100644 templates/course/applications-list.lucius diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 427941cf4..7334bbf32 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1650,4 +1650,5 @@ UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden CourseAllocationsBounds n@Int: Voraussichtliche Zuteilungen durch #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} CourseAllocationsBoundCoincide numFirstChoice@Int: Vstl. #{numFirstChoice} Teilnehmer CourseAllocationsBound numApps@Int numFirstChoice@Int: Vstl. zwischen #{numFirstChoice} und #{numApps} Teilnehmer -CourseAllocationsBoundCapped: Die Anzahl von Zuteilungen wird wmgl. durch die Kurskapazität eingeschränkt \ No newline at end of file +CourseAllocationsBoundCapped: Die Anzahl von Zuteilungen wird wmgl. durch die Kurskapazität eingeschränkt. +CourseAllocationsBoundWarningOpen: Diese Informationen entsprechen nur dem aktuellen Stand der Bewerbungen und können sich noch ändern. \ No newline at end of file diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 87184db38..7ada9cbff 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -532,6 +532,9 @@ postCApplicationsR tid ssh csh = do psValidator = def & defaultSorting [SortAscBy "user-name"] + participants <- count [ CourseParticipantCourse ==. cid ] + let remainingCapacity = subtract participants <$> courseCapacity + allocationsBounds' <- E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation E.&&. allocationCourse E.^. AllocationCourseCourse E.==. E.val cid @@ -557,15 +560,17 @@ postCApplicationsR tid ssh csh = do let allocationsBounds = [ (allocation, numApps', numFirstChoice', capped) | (Entity _ allocation, E.Value numApps, E.Value numFirstChoice) <- allocationsBounds' - , let numApps' = maybe id min courseCapacity numApps - numFirstChoice' = maybe id min courseCapacity numFirstChoice + , let numApps' = max 0 $ maybe id min remainingCapacity numApps + numFirstChoice' = max 0 $ maybe id min remainingCapacity numFirstChoice capped = numApps' /= numApps || numFirstChoice' /= numFirstChoice ] (, allocationsBounds) <$> dbTableWidget' psValidator DBTable{..} + now <- liftIO getCurrentTime let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle + registrationOpen = maybe True (now <) siteLayoutMsg title $ do setTitleI title diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 67913bf09..6347b1d38 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -303,10 +303,11 @@ validateCourse = do prevAllocationCourse <- getBy $ UniqueAllocationCourse cid prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse - fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if + fmap join . for prevAllocation $ \Allocation{allocationStaffAllocationTo, allocationRegisterByCourse} -> if | userAdmin -> return Nothing - | NTop allocationStaffRegisterTo <= NTop (Just now) + | NTop allocationStaffAllocationTo <= NTop (Just now) + , NTop allocationRegisterByCourse > NTop (Just now) -> Just . courseCapacity <$> getJust cid | otherwise -> return Nothing diff --git a/templates/course/applications-list.hamlet b/templates/course/applications-list.hamlet index 9e3adb337..9cb6253fc 100644 --- a/templates/course/applications-list.hamlet +++ b/templates/course/applications-list.hamlet @@ -2,7 +2,7 @@ $newline never $if not (null allocationsBounds)

    _{MsgCourseAllocationsBounds (length allocationsBounds)}
    - $forall (Allocation{allocationName}, numApps, numFirstChoice, capped) <- allocationsBounds + $forall (Allocation{allocationName, allocationRegisterTo}, numApps, numFirstChoice, capped) <- allocationsBounds
    #{allocationName}
    @@ -12,8 +12,11 @@ $if not (null allocationsBounds) $else _{MsgCourseAllocationsBound numApps numFirstChoice} $if capped -

    +

    _{MsgCourseAllocationsBoundCapped} + $if registrationOpen allocationRegisterTo +

    + _{MsgCourseAllocationsBoundWarningOpen}

    _{MsgMenuCourseApplications} ^{table} diff --git a/templates/course/applications-list.lucius b/templates/course/applications-list.lucius new file mode 100644 index 000000000..55579838c --- /dev/null +++ b/templates/course/applications-list.lucius @@ -0,0 +1,4 @@ +.bound_explanation { + color: var(--color-fontsec); + font-style: italic; +} From a890e346c8f76fb2fb9467910085d4d41a40b7d8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Sep 2019 14:41:19 +0200 Subject: [PATCH 04/11] fix(allocations): better explain capped allocation bounds --- messages/uniworx/de.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7334bbf32..17991c2cf 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1650,5 +1650,5 @@ UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden CourseAllocationsBounds n@Int: Voraussichtliche Zuteilungen durch #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} CourseAllocationsBoundCoincide numFirstChoice@Int: Vstl. #{numFirstChoice} Teilnehmer CourseAllocationsBound numApps@Int numFirstChoice@Int: Vstl. zwischen #{numFirstChoice} und #{numApps} Teilnehmer -CourseAllocationsBoundCapped: Die Anzahl von Zuteilungen wird wmgl. durch die Kurskapazität eingeschränkt. +CourseAllocationsBoundCapped: Die obige Anzeige wurde durch die aktuell angegebene Kurskapazität reduziert. CourseAllocationsBoundWarningOpen: Diese Informationen entsprechen nur dem aktuellen Stand der Bewerbungen und können sich noch ändern. \ No newline at end of file From 52b0c8fd25550c7b2d2132afe39485285e245359 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Sep 2019 14:48:35 +0200 Subject: [PATCH 05/11] chore(release): 6.8.0 --- CHANGELOG.md | 15 +++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 18 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0df264d6b..f4c068221 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,21 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [6.8.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.7.0...v6.8.0) (2019-09-12) + + +### Bug Fixes + +* **allocations:** better explain capped allocation bounds ([a890e34](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a890e34)) + + +### Features + +* **allocations:** allow changing course capacity during allocation ([83e1c94](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/83e1c94)) +* **allocations:** show bounds on assignments due to allocation ([91b249e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/91b249e)) + + + ## [6.7.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.6.0...v6.7.0) (2019-09-12) diff --git a/package-lock.json b/package-lock.json index fcb1215fb..542ee4893 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "6.7.0", + "version": "6.8.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index fc9399b98..5778e3555 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "6.7.0", + "version": "6.8.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 937849fb1..5e4abe5fc 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 6.7.0 +version: 6.8.0 dependencies: # Due to a bug in GHC 8.0.1, we block its usage From a85f317bf2de8c5038b406d6c5601d0ead8e4bd2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Sep 2019 15:46:09 +0200 Subject: [PATCH 06/11] feat(users): allow customisation of userDisplayName Fixes #346 --- messages/uniworx/de.msg | 6 +++- models/users | 2 +- package.yaml | 1 + src/Foundation.hs | 20 +++++++---- src/Handler/Profile.hs | 28 +++++++++++---- src/Handler/Utils/Profile.hs | 35 +++++++++++++++++++ src/Model/Types/Common.hs | 4 ++- templates/i18n/changelog/de.hamlet | 1 + .../i18n/profile/displayNameRules/de.hamlet | 9 +++++ templates/profile/profile.hamlet | 4 +++ 10 files changed, 94 insertions(+), 16 deletions(-) create mode 100644 src/Handler/Utils/Profile.hs create mode 100644 templates/i18n/profile/displayNameRules/de.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 17991c2cf..551a21067 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -638,6 +638,7 @@ UserSchoolsTip: Sie erhalten nur institutweite Benachrichtigungen für Institute FormNotifications: Benachrichtigungen FormBehaviour: Verhalten FormCosmetics: Oberfläche +FormPersonalAppearance: Öffentliche Daten FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen ActiveAuthTags: Aktivierte Authorisierungsprädikate @@ -1589,7 +1590,10 @@ CourseApplicationNoVeto: Kein Veto CourseApplicationNoRatingPoints: Keine Bewertung CourseApplicationNoRatingComment: Kein Kommentar -UserDisplayName: Voller Name +UserDisplayName: Angezeigter Name +UserDisplayNameInvalid: Angezeigter Name erfüllt nicht die Vorgaben +UserDisplayNameRules: Vorgaben für den angezeigten Namen +UserDisplayNameRulesBelow: Vorgaben für den angezeigten Namen finden sich weiter unten auf der Seite UserMatriculation: Matrikelnummer SchoolShort: Kürzel diff --git a/models/users b/models/users index 223cd2b8a..b7e24447e 100644 --- a/models/users +++ b/models/users @@ -9,7 +9,7 @@ -- User json -- Each Uni2work user has a corresponding row in this table; created upon first login. surname UserSurname -- Display user names always through 'nameWidget displayName surname' - displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained) + displayName UserDisplayName email (CI Text) -- Case-insensitive eMail address ident (CI Text) -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) diff --git a/package.yaml b/package.yaml index 5e4abe5fc..dcfd0db92 100644 --- a/package.yaml +++ b/package.yaml @@ -137,6 +137,7 @@ dependencies: - memory - pqueue - deepseq + - multiset other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Foundation.hs b/src/Foundation.hs index 72eb97237..107f9373a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -66,6 +66,7 @@ import qualified Control.Monad.Catch as C import Handler.Utils.StudyFeatures import Handler.Utils.SchoolLdap +import Handler.Utils.Profile import Utils.Form import Utils.Sheet import Utils.SystemMessage @@ -3082,7 +3083,7 @@ upsertCampusUser ldapData Creds{..} = do let userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ] userEmail' = fold [ v | (k, v) <- ldapData, k == ldapUserEmail ] - userDisplayName' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ] + userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ] userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ] userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ] userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ] @@ -3098,10 +3099,10 @@ upsertCampusUser ldapData Creds{..} = do -> return $ mk userEmail | otherwise -> throwM CampusUserInvalidEmail - userDisplayName <- if - | [bs] <- userDisplayName' - , Right userDisplayName <- Text.decodeUtf8' bs - -> return userDisplayName + userDisplayName' <- if + | [bs] <- userDisplayName'' + , Right userDisplayName' <- Text.decodeUtf8' bs + -> return userDisplayName' | otherwise -> throwM CampusUserInvalidDisplayName userFirstName <- if @@ -3148,17 +3149,22 @@ upsertCampusUser ldapData Creds{..} = do , userTokensIssuedAfter = Nothing , userCreated = now , userLastLdapSynchronisation = Just now + , userDisplayName = userDisplayName' , .. } userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , UserDisplayName =. userDisplayName + -- , UserDisplayName =. userDisplayName + , UserFirstName =. userFirstName , UserSurname =. userSurname + , UserTitle =. userTitle , UserEmail =. userEmail , UserLastLdapSynchronisation =. Just now ] ++ [ UserLastAuthentication =. Just now | not isDummy ] - user@(Entity userId _) <- upsertBy (UniqueAuthentication $ mk credsIdent) newUser userUpdate + user@(Entity userId userRec) <- upsertBy (UniqueAuthentication $ mk credsIdent) newUser userUpdate + unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ + update userId [ UserDisplayName =. userDisplayName' ] let userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index b4a38f4f3..be6543787 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -4,6 +4,7 @@ import Import import Handler.Utils import Handler.Utils.Table.Cells +import Handler.Utils.Profile -- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade @@ -19,7 +20,8 @@ import qualified Data.CaseInsensitive as CI data SettingsForm = SettingsForm - { stgMaxFavourties :: Int + { stgDisplayName :: UserDisplayName + , stgMaxFavourties :: Int , stgTheme :: Theme , stgDateTime :: DateTimeFormat , stgDate :: DateTimeFormat @@ -29,6 +31,7 @@ data SettingsForm = SettingsForm , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings } +makeLenses_ ''SettingsForm data NotificationTriggerKind = NTKAll @@ -58,7 +61,9 @@ instance RenderMessage UniWorX NotificationTriggerKind where makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm template html = do (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm - <$ aformSection MsgFormCosmetics + <$ aformSection MsgFormPersonalAppearance + <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template) + <* aformSection MsgFormCosmetics <*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) <*> areq (selectField . return $ mkOptionList themeList) @@ -173,6 +178,14 @@ notificationForm template = wFormToAForm $ do aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False +validateSettings :: User -> FormValidator SettingsForm Handler () +validateSettings User{..} = do + userDisplayName' <- use _stgDisplayName + + guardValidation MsgUserDisplayNameInvalid $ + validDisplayName userTitle userFirstName userSurname userDisplayName' + + data ButtonResetTokens = BtnResetTokens deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonResetTokens @@ -195,7 +208,7 @@ nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1 getProfileR, postProfileR :: Handler Html getProfileR = postProfileR postProfileR = do - (uid, User{..}) <- requireAuthPair + (uid, user@User{..}) <- requireAuthPair userSchools <- fmap (setOf $ folded . _Value) . runDB . E.select . E.from $ \school -> do E.where_ . E.exists . E.from $ \userSchool -> E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut) @@ -203,7 +216,8 @@ postProfileR = do E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId return $ school E.^. SchoolId let settingsTemplate = Just SettingsForm - { stgMaxFavourties = userMaxFavourites + { stgDisplayName = userDisplayName + , stgMaxFavourties = userMaxFavourites , stgTheme = userTheme , stgDateTime = userDateTimeFormat , stgDate = userDateFormat @@ -213,11 +227,12 @@ postProfileR = do , stgNotificationSettings = userNotificationSettings , stgWarningDays = userWarningDays } - ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate + ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate formResult res $ \SettingsForm{..} -> do runDB $ do - update uid [ UserMaxFavourites =. stgMaxFavourties + update uid [ UserDisplayName =. stgDisplayName + , UserMaxFavourites =. stgMaxFavourties , UserTheme =. stgTheme , UserDateTimeFormat =. stgDateTime , UserDateFormat =. stgDate @@ -286,6 +301,7 @@ postProfileR = do , formAnchor = Just ProfileResetTokens } tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation") + displayNameRules = $(i18nWidgetFile "profile/displayNameRules") $(widgetFile "profile/profile") diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs new file mode 100644 index 000000000..ca272d6b8 --- /dev/null +++ b/src/Handler/Utils/Profile.hs @@ -0,0 +1,35 @@ +module Handler.Utils.Profile + ( validDisplayName + ) where + +import Import.NoFoundation + +import qualified Data.Text as Text +import qualified Data.MultiSet as MultiSet +import qualified Data.Set as Set + +import qualified Data.Char as Char + + +validDisplayName :: Maybe UserTitle + -> UserFirstName + -> UserSurname + -> UserDisplayName + -> Bool +validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -> sName) (Text.strip -> dName) + = and [ dNameFrags `MultiSet.isSubsetOf` MultiSet.unions [titleFrags, fNameFrags, sNameFrags] + , sName `Text.isInfixOf` dName + , all ((<= 1) . Text.length) . filter (Text.any Char.isSpace) $ Text.groupBy ((==) `on` Char.isSpace) dName + , dNameLetters `Set.isSubsetOf` Set.unions [titleLetters, fNameLetters, sNameLetters, addLetters] + ] + where + titleFrags = MultiSet.fromList $ maybe [] Text.words mTitle + fNameFrags = MultiSet.fromList $ Text.words fName + sNameFrags = MultiSet.fromList $ Text.words sName + dNameFrags = MultiSet.fromList $ Text.words dName + + titleLetters = Set.fromList $ maybe [] unpack mTitle + fNameLetters = Set.fromList $ unpack fName + sNameLetters = Set.fromList $ unpack sName + dNameLetters = Set.fromList $ unpack dName + addLetters = Set.fromList [' '] diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index a023f44d7..50048eb42 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -18,8 +18,10 @@ type Points = Centi type Email = Text -type UserDisplayName = Text +type UserTitle = Text +type UserFirstName = Text type UserSurname = Text +type UserDisplayName = Text type UserMatriculation = Text type StudyDegreeName = Text diff --git a/templates/i18n/changelog/de.hamlet b/templates/i18n/changelog/de.hamlet index cfba447d2..e9fdcff16 100644 --- a/templates/i18n/changelog/de.hamlet +++ b/templates/i18n/changelog/de.hamlet @@ -5,6 +5,7 @@ $newline never
    • Abschätzung der durch Zentralanmeldung benötigten Kurskapazität +
    • Anpassbare angezeigte Namen
      ^{formatGregorianW 2019 09 05} diff --git a/templates/i18n/profile/displayNameRules/de.hamlet b/templates/i18n/profile/displayNameRules/de.hamlet new file mode 100644 index 000000000..733c0baab --- /dev/null +++ b/templates/i18n/profile/displayNameRules/de.hamlet @@ -0,0 +1,9 @@ +$newline never +
        +
      • Der Nachname („#{userSurname}“) muss im angezeigten Namen vollständig enthalten sein. + $maybe title <- userTitle +
      • Der angezeigte Name muss vollständig aus Fragmenten des akademischen Titels („#{title}“), des Vornamens („#{userFirstName}“) und des Nachnamens („#{userSurname}“) bestehen. + $nothing +
      • Der angezeigte Name muss vollständig aus Fragmenten des Vornamens („#{userFirstName}“) und des Nachnamens („#{userSurname}“) bestehen. +
      • Der angezeigte Name darf keine mehrfachen Leerzeichen enthalten. +
      • Der angezeigter Name darf keine Sonderzeichen enthalten, die in keinem der Namensbestandteile vorkommen. diff --git a/templates/profile/profile.hamlet b/templates/profile/profile.hamlet index e2b1e4365..7d800f9a9 100644 --- a/templates/profile/profile.hamlet +++ b/templates/profile/profile.hamlet @@ -1,6 +1,10 @@ $newline never
        ^{settingsForm} +
        +

        _{MsgUserDisplayNameRules} +

        + ^{displayNameRules}

        ^{tokenExplanation}

        From 2f38278ab141ac4db7d16a4b6d990c58067b200e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Sep 2019 17:17:31 +0200 Subject: [PATCH 07/11] feat(users): allow customisation of displayed email address Fixes #459 --- messages/uniworx/de.msg | 15 +++- models/users | 5 +- routes | 1 + src/Foundation.hs | 8 ++- src/Handler/Course/Show.hs | 2 +- src/Handler/Profile.hs | 74 ++++++++++++++++---- src/Handler/Users/Add.hs | 3 + src/Jobs.hs | 1 + src/Jobs/Handler/ChangeUserDisplayEmail.hs | 29 ++++++++ src/Jobs/Types.hs | 3 + src/Model/Migration.hs | 8 +++ templates/i18n/changelog/de.hamlet | 1 + templates/i18n/set-display-email/de.hamlet | 4 ++ templates/mail/changeUserDisplayEmail.hamlet | 19 +++++ 14 files changed, 154 insertions(+), 19 deletions(-) create mode 100644 src/Jobs/Handler/ChangeUserDisplayEmail.hs create mode 100644 templates/i18n/set-display-email/de.hamlet create mode 100644 templates/mail/changeUserDisplayEmail.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 551a21067..968fb84c9 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1596,6 +1596,10 @@ UserDisplayNameRules: Vorgaben für den angezeigten Namen UserDisplayNameRulesBelow: Vorgaben für den angezeigten Namen finden sich weiter unten auf der Seite UserMatriculation: Matrikelnummer +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 Nutzern 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 + SchoolShort: Kürzel SchoolName: Name SchoolLdapOrganisations: Assoziierte LDAP-Fragmente @@ -1643,6 +1647,7 @@ AdminUserFirstName: Vorname AdminUserSurname: Nachname AdminUserDisplayName: Anzeige-Name AdminUserEmail: E-Mail Addresse +AdminUserDisplayEmail: Anzeige-E-Mail AdminUserIdent: Identifikation AdminUserAuth: Authentifizierung AdminUserMatriculation: Matrikelnummer @@ -1655,4 +1660,12 @@ CourseAllocationsBounds n@Int: Voraussichtliche Zuteilungen durch #{pluralDE n " CourseAllocationsBoundCoincide numFirstChoice@Int: Vstl. #{numFirstChoice} Teilnehmer CourseAllocationsBound numApps@Int numFirstChoice@Int: Vstl. zwischen #{numFirstChoice} und #{numApps} Teilnehmer CourseAllocationsBoundCapped: Die obige Anzeige wurde durch die aktuell angegebene Kurskapazität reduziert. -CourseAllocationsBoundWarningOpen: Diese Informationen entsprechen nur dem aktuellen Stand der Bewerbungen und können sich noch ändern. \ No newline at end of file +CourseAllocationsBoundWarningOpen: Diese Informationen entsprechen nur dem aktuellen Stand der Bewerbungen und können sich noch ändern. + +BtnSetDisplayEmail: E-Mail Adresse setzen +UserDisplayEmailChanged: Öffentliche E-Mail Adresse erfolgreich gesetzt +TitleChangeUserDisplayEmail: Öffentliche E-Mail Adresse setzen + +MailSubjectChangeUserDisplayEmail: Diese E-Mail Adresse in Uni2work veröffentlichen +MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutzer 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 Uni2work veröffentlichen \ No newline at end of file diff --git a/models/users b/models/users index b7e24447e..22c14f1dc 100644 --- a/models/users +++ b/models/users @@ -10,8 +10,9 @@ User json -- Each Uni2work user has a corresponding row in this table; created upon first login. surname UserSurname -- Display user names always through 'nameWidget displayName surname' displayName UserDisplayName - email (CI Text) -- Case-insensitive eMail address - ident (CI Text) -- Case-insensitive user-identifier + displayEmail UserEmail + email UserEmail -- Case-insensitive eMail address + ident UserIdent -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date created UTCTime default=now() diff --git a/routes b/routes index 9ff5066c9..2d6360ec9 100644 --- a/routes +++ b/routes @@ -71,6 +71,7 @@ /user ProfileR GET POST !free /user/profile ProfileDataR GET !free /user/authpreds AuthPredsR GET POST !free +/user/set-display-email SetDisplayEmailR GET POST !free /term TermShowR GET !free /term/current TermCurrentR GET !free diff --git a/src/Foundation.hs b/src/Foundation.hs index 107f9373a..e62647c90 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1779,9 +1779,10 @@ instance YesodBreadcrumbs UniWorX where breadcrumb InstanceR = return ("Identifikation", Nothing) - breadcrumb ProfileR = return ("User" , Just HomeR) - breadcrumb ProfileDataR = return ("Profile" , Just ProfileR) - breadcrumb AuthPredsR = return ("Authentifizierung", Just ProfileR) + breadcrumb ProfileR = return ("Einstellungen" , Just HomeR) + breadcrumb SetDisplayEmailR = return ("Öffentliche E-Mail Adresse", Just ProfileR) + breadcrumb ProfileDataR = return ("Persönliche Daten", Just ProfileR) + breadcrumb AuthPredsR = return ("Authorisierung" , Just ProfileR) breadcrumb TermShowR = return ("Semester" , Just HomeR) breadcrumb TermCurrentR = return ("Aktuell" , Just TermShowR) @@ -3150,6 +3151,7 @@ upsertCampusUser ldapData Creds{..} = do , userCreated = now , userLastLdapSynchronisation = Just now , userDisplayName = userDisplayName' + , userDisplayEmail = userEmail , .. } userUpdate = [ UserMatrikelnummer =. userMatrikelnummer diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 17125062d..f73e6fb94 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -47,7 +47,7 @@ getCShowR tid ssh csh = do E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] return ( lecturer E.^. LecturerType - , user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname) + , user E.^. UserDisplayEmail, user E.^. UserDisplayName, user E.^. UserSurname) let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text) partStaff (CourseLecturer ,name,surn,mail) = Right (name,surn,mail) partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index be6543787..1db807b6f 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -5,6 +5,7 @@ import Import import Handler.Utils import Handler.Utils.Table.Cells import Handler.Utils.Profile +import Handler.Utils.Tokens -- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade @@ -18,9 +19,12 @@ import qualified Database.Esqueleto.Utils as E import qualified Data.CaseInsensitive as CI +import Jobs + data SettingsForm = SettingsForm { stgDisplayName :: UserDisplayName + , stgDisplayEmail :: UserEmail , stgMaxFavourties :: Int , stgTheme :: Theme , stgDateTime :: DateTimeFormat @@ -63,6 +67,7 @@ makeSettingForm template html = do (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm <$ aformSection MsgFormPersonalAppearance <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template) + <*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template) <* aformSection MsgFormCosmetics <*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) @@ -217,6 +222,7 @@ postProfileR = do return $ school E.^. SchoolId let settingsTemplate = Just SettingsForm { stgDisplayName = userDisplayName + , stgDisplayEmail = userDisplayEmail , stgMaxFavourties = userMaxFavourites , stgTheme = userTheme , stgDateTime = userDateTimeFormat @@ -230,17 +236,21 @@ postProfileR = do ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate formResult res $ \SettingsForm{..} -> do - runDB $ do - update uid [ UserDisplayName =. stgDisplayName - , UserMaxFavourites =. stgMaxFavourties - , UserTheme =. stgTheme - , UserDateTimeFormat =. stgDateTime - , UserDateFormat =. stgDate - , UserTimeFormat =. stgTime - , UserDownloadFiles =. stgDownloadFiles - , UserWarningDays =. stgWarningDays - , UserNotificationSettings =. stgNotificationSettings - ] + runDBJobs $ do + update uid $ + [ UserDisplayName =. stgDisplayName + , UserMaxFavourites =. stgMaxFavourties + , UserTheme =. stgTheme + , UserDateTimeFormat =. stgDateTime + , UserDateFormat =. stgDate + , UserTimeFormat =. stgTime + , UserDownloadFiles =. stgDownloadFiles + , UserWarningDays =. stgWarningDays + , UserNotificationSettings =. stgNotificationSettings + ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] + when (stgDisplayEmail /= userDisplayEmail) $ do + queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail + addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail when (stgMaxFavourties < userMaxFavourites) $ do -- prune Favourites to user-defined size oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid] @@ -267,7 +277,7 @@ postProfileR = do } [ UserSchoolIsOptOut =. True ] - addMessageI Info MsgSettingsUpdate + addMessageI Success MsgSettingsUpdate redirect $ ProfileR :#: ProfileSettings ((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm @@ -742,3 +752,43 @@ postUserNotificationR cID = do siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do setTitleI $ MsgNotificationSettingsHeading userDisplayName formWidget + + +data ButtonSetDisplayEmail = BtnSetDisplayEmail + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ButtonSetDisplayEmail +instance Finite ButtonSetDisplayEmail + +nullaryPathPiece ''ButtonSetDisplayEmail $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''ButtonSetDisplayEmail id + +instance Button UniWorX ButtonSetDisplayEmail where + btnClasses _ = [BCIsButton] + + +getSetDisplayEmailR, postSetDisplayEmailR :: Handler Html +getSetDisplayEmailR = postSetDisplayEmailR +postSetDisplayEmailR = do + uid <- requireAuthId + mDisplayEmail <- requireCurrentTokenRestrictions + + case mDisplayEmail of + Nothing -> invalidArgs ["Bearer token required"] + Just displayEmail -> do + ((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedJwtPost buttonForm + let btnView' = wrapForm btnView def + { formSubmit = FormNoSubmit + , formAction = Just $ SomeRoute SetDisplayEmailR + , formEncoding = btnEnc + } + + formResult btnRes $ \case + BtnSetDisplayEmail -> do + runDB $ + update uid [UserDisplayEmail =. displayEmail] + addMessageI Success MsgUserDisplayEmailChanged + redirect ProfileR + + siteLayoutMsg MsgTitleChangeUserDisplayEmail $ do + setTitleI MsgTitleChangeUserDisplayEmail + $(i18nWidgetFile "set-display-email") diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 42834eb2e..b8e6efd35 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -16,6 +16,7 @@ data AdminUserForm = AdminUserForm , aufFirstName :: Text , aufSurname :: UserSurname , aufDisplayName :: UserDisplayName + , aufDisplayEmail :: UserEmail , aufMatriculation :: Maybe UserMatriculation , aufEmail :: UserEmail , aufIdent :: UserIdent @@ -44,6 +45,7 @@ adminUserForm template = renderAForm FormStandard <*> areq (textField & cfStrip) (fslI MsgAdminUserFirstName) (aufFirstName <$> template) <*> areq (textField & cfStrip) (fslI MsgAdminUserSurname) (aufSurname <$> template) <*> areq (textField & cfStrip) (fslI MsgAdminUserDisplayName) (aufDisplayName <$> template) + <*> areq (emailField & cfCI) (fslI MsgAdminUserDisplayEmail) (aufDisplayEmail <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserMatriculation) (aufMatriculation <$> template) <*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (aufEmail <$> template) <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template) @@ -77,6 +79,7 @@ postAdminUserAddR = do , userLastAuthentication = Nothing , userEmail = aufEmail , userDisplayName = aufDisplayName + , userDisplayEmail = aufDisplayEmail , userFirstName = aufFirstName , userSurname = aufSurname , userTitle = aufTitle diff --git a/src/Jobs.hs b/src/Jobs.hs index e5fee67d6..4a8654d90 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -68,6 +68,7 @@ import Jobs.Handler.SendPasswordReset import Jobs.Handler.TransactionLog import Jobs.Handler.SynchroniseLdap import Jobs.Handler.PruneInvitations +import Jobs.Handler.ChangeUserDisplayEmail import Jobs.HealthReport diff --git a/src/Jobs/Handler/ChangeUserDisplayEmail.hs b/src/Jobs/Handler/ChangeUserDisplayEmail.hs new file mode 100644 index 000000000..dd5e8f0d4 --- /dev/null +++ b/src/Jobs/Handler/ChangeUserDisplayEmail.hs @@ -0,0 +1,29 @@ +module Jobs.Handler.ChangeUserDisplayEmail + ( dispatchJobChangeUserDisplayEmail + ) where + +import Import + +import Handler.Utils.Mail +import qualified Data.HashSet as HashSet +import qualified Data.CaseInsensitive as CI + +import Text.Hamlet + +dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler () +dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do + token <- tokenRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken jUser (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing + jwt <- encodeToken token + let + setDisplayEmailUrl :: SomeRoute UniWorX + setDisplayEmailUrl = SomeRoute (SetDisplayEmailR, [(toPathPiece GetBearer, toPathPiece jwt)]) + setDisplayEmailUrl' <- toTextUrl setDisplayEmailUrl + + user@User{..} <- runDB $ getJust jUser + + userMailT jUser $ do + _mailTo .= pure (userAddress user & _addressEmail .~ CI.original jDisplayEmail) + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI MsgMailSubjectChangeUserDisplayEmail + addAlternatives $ + providePreferredAlternative ($(ihamletFile "templates/mail/changeUserDisplayEmail.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 871f8d38e..a5b6149d9 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -64,6 +64,9 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica } | JobSynchroniseLdapUser { jUser :: UserId } + | JobChangeUserDisplayEmail { jUser :: UserId + , jDisplayEmail :: UserEmail + } deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId } diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index c9a2b95ce..fb64f2129 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -485,6 +485,14 @@ customMigrations = Map.fromListWith (>>) DELETE FROM "invitation" WHERE "for"->'junction' = '"UserLecturer"'; |] ) + , ( AppliedMigrationKey [migrationVersion|19.0.0|] [version|20.0.0|] + , whenM (tableExists "user") $ do + [executeQQ| + ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "display_email" citext; + UPDATE "user" SET "display_email" = "email" WHERE "display_email" IS NULL; + ALTER TABLE "user" ALTER COLUMN "display_email" SET NOT NULL; + |] + ) ] diff --git a/templates/i18n/changelog/de.hamlet b/templates/i18n/changelog/de.hamlet index e9fdcff16..ec4302653 100644 --- a/templates/i18n/changelog/de.hamlet +++ b/templates/i18n/changelog/de.hamlet @@ -6,6 +6,7 @@ $newline never

        • Abschätzung der durch Zentralanmeldung benötigten Kurskapazität
        • Anpassbare angezeigte Namen +
        • Anpassbare angezeigte E-Mail Adressen
          ^{formatGregorianW 2019 09 05} diff --git a/templates/i18n/set-display-email/de.hamlet b/templates/i18n/set-display-email/de.hamlet new file mode 100644 index 000000000..72ce89746 --- /dev/null +++ b/templates/i18n/set-display-email/de.hamlet @@ -0,0 +1,4 @@ +$newline never +

          + Möchten Sie die, öffentlich im Zusammenhang mit Ihrem Namen angezeigte, E-Mail Adresse wirklich auf „#{displayEmail}“ setzen? +^{btnView'} diff --git a/templates/mail/changeUserDisplayEmail.hamlet b/templates/mail/changeUserDisplayEmail.hamlet new file mode 100644 index 000000000..6f4914d36 --- /dev/null +++ b/templates/mail/changeUserDisplayEmail.hamlet @@ -0,0 +1,19 @@ +$newline never +\ + + + +