feat(users): allow customisation of userDisplayName

Fixes #346

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

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)

package.yaml

@@ -137,6 +137,7 @@ dependencies:
   - memory
   - pqueue
   - deepseq
+  - multiset
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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
+  userDisplayName' <- if
-    | [bs] <- userDisplayName'
+    | [bs] <- userDisplayName''
-    , Right userDisplayName <- Text.decodeUtf8' bs
+    , Right userDisplayName' <- Text.decodeUtf8' bs
-      -> return userDisplayName
+      -> 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

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

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 [' ']

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

templates/i18n/changelog/de.hamlet

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

templates/i18n/profile/displayNameRules/de.hamlet

@@ -0,0 +1,9 @@
+$newline never
+<ul>
+  <li>Der Nachname („#{userSurname}“) muss im angezeigten Namen vollständig enthalten sein.
+  $maybe title <- userTitle
+    <li>Der angezeigte Name muss vollständig aus Fragmenten des akademischen Titels („#{title}“), des Vornamens („#{userFirstName}“) und des Nachnamens („#{userSurname}“) bestehen.
+  $nothing
+    <li>Der angezeigte Name muss vollständig aus Fragmenten des Vornamens („#{userFirstName}“) und des Nachnamens („#{userSurname}“) bestehen.
+  <li>Der angezeigte Name darf keine mehrfachen Leerzeichen enthalten.
+  <li>Der angezeigter Name darf keine Sonderzeichen enthalten, die in keinem der Namensbestandteile vorkommen.

templates/profile/profile.hamlet

@@ -1,6 +1,10 @@
 $newline never
 <section>
   ^{settingsForm}
+<section>
+  <h3>_{MsgUserDisplayNameRules}
+  <p>
+    ^{displayNameRules}
 <section>
   ^{tokenExplanation}
   <p>