feat(users): allow customisation of displayed email address

Fixes #459

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.
+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

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
+    displayEmail   UserEmail
-    ident          (CI Text)                -- Case-insensitive user-identifier
+    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()

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

src/Foundation.hs

@@ -1779,9 +1779,10 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb InstanceR        = return ("Identifikation", Nothing)
 
 
-  breadcrumb ProfileR         = return ("User"             , Just HomeR)
+  breadcrumb ProfileR         = return ("Einstellungen"    , Just HomeR)
-  breadcrumb ProfileDataR     = return ("Profile"          , Just ProfileR)
+  breadcrumb SetDisplayEmailR = return ("Öffentliche E-Mail Adresse", Just ProfileR)
-  breadcrumb AuthPredsR       = return ("Authentifizierung", 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

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)

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
+    runDBJobs $ do
-      update uid  [ UserDisplayName    =. stgDisplayName
+      update uid $
-                  , UserMaxFavourites  =. stgMaxFavourties
+        [ UserDisplayName    =. stgDisplayName
-                  , UserTheme          =. stgTheme
+        , UserMaxFavourites  =. stgMaxFavourties
-                  , UserDateTimeFormat =. stgDateTime
+        , UserTheme          =. stgTheme
-                  , UserDateFormat     =. stgDate
+        , UserDateTimeFormat =. stgDateTime
-                  , UserTimeFormat     =. stgTime
+        , UserDateFormat     =. stgDate
-                  , UserDownloadFiles  =. stgDownloadFiles
+        , UserTimeFormat     =. stgTime
-                  , UserWarningDays    =. stgWarningDays
+        , UserDownloadFiles  =. stgDownloadFiles
-                  , UserNotificationSettings =. stgNotificationSettings
+        , 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")

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

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
 

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))

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 }

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;
+        |]
+    )
   ]
 
 

templates/i18n/changelog/de.hamlet

@@ -6,6 +6,7 @@ $newline never
     <ul>
       <li>Abschätzung der durch Zentralanmeldung benötigten Kurskapazität
       <li>Anpassbare angezeigte Namen
+      <li>Anpassbare angezeigte E-Mail Adressen
       
   <dt .deflist__dt>
     ^{formatGregorianW 2019 09 05}

templates/i18n/set-display-email/de.hamlet

@@ -0,0 +1,4 @@
+$newline never
+<p>
+  Möchten Sie die, öffentlich im Zusammenhang mit Ihrem Namen angezeigte, E-Mail Adresse wirklich auf „#{displayEmail}“ setzen?
+^{btnView'}

templates/mail/changeUserDisplayEmail.hamlet

@@ -0,0 +1,19 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{MsgMailTitleChangeUserDisplayEmail userDisplayName}
+    <p>
+      _{MsgMailIntroChangeUserDisplayEmail jDisplayEmail}
+    <p>
+      <a href=#{setDisplayEmailUrl'}>
+        _{MsgBtnSetDisplayEmail}