From a85f317bf2de8c5038b406d6c5601d0ead8e4bd2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Sep 2019 15:46:09 +0200 Subject: [PATCH] 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