chore(users): allow profile edits with invalid display_email address, if unchanged

messages/uniworx/utils/utils/de-de-formal.msg

@@ -96,6 +96,7 @@ RoomReferenceLinkLink !ident-ok: Link
 RoomReferenceLinkLinkPlaceholder !ident-ok: URL
 RoomReferenceLinkInstructions: Anweisungen
 RoomReferenceLinkInstructionsPlaceholder: Anweisungen
+UtilNoneSet: Keine angegeben
 UtilEmptyChoice: Auswahl war leer
 UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert.
 MultiNoSelection: Keine Auswahl

messages/uniworx/utils/utils/en-eu.msg

@@ -96,6 +96,7 @@ RoomReferenceLinkLink: Link
 RoomReferenceLinkLinkPlaceholder: URL
 RoomReferenceLinkInstructions: Instructions
 RoomReferenceLinkInstructionsPlaceholder: Instructions
+UtilNoneSet: None set
 UtilEmptyChoice: Empty selection
 UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty.
 MultiNoSelection: No selection

src/Handler/Profile.hs

@@ -113,10 +113,11 @@ instance RenderMessage UniWorX NotificationTriggerKind where
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
 makeSettingForm template html = do
     MsgRenderer mr <- getMsgRenderer
+    -- isAdmin <- checkAdmin
     (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
         <$  aformSection MsgFormPersonalAppearance
-        <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
+        <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow)   (stgDisplayName  <$> template)
-        <*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
+        <*> areq (textField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
         <*  aformSection MsgFormCosmetics
         <*> areq (natFieldI MsgFavouritesNotNatural)
             (fslpI MsgFavourites (mr MsgFavouritesPlaceholder) & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template)
@@ -370,7 +371,9 @@ validateSettings User{..} = do
 
   userDisplayEmail' <- use _stgDisplayEmail
   guardValidation (MsgInvalidEmailAddressWith $ CI.original userDisplayEmail') $
-    validEmail' userDisplayEmail'
+    validEmail' userDisplayEmail'         || -- valid
+    userDisplayEmail' == userDisplayEmail || -- unchanged
+    userDisplayEmail' == userEmail           -- euqal to default, which is then ignored
 
   userPostAddress'  <- use _stgPostAddress
   let postalNotSet  = isNothing userPostAddress' -- TODO $ canonical userPostAddress'
@@ -435,7 +438,7 @@ serveProfileR (uid, user@User{..}) = do
     return (userSchools, userExamOfficeLabels)
   let settingsTemplate = Just SettingsForm
         { stgDisplayName          = userDisplayName
-        , stgDisplayEmail         = userDisplayEmail
+        , stgDisplayEmail         = if userDisplayEmail == "" then userEmail else userDisplayEmail
         , stgMaxFavourites        = userMaxFavourites
         , stgMaxFavouriteTerms    = userMaxFavouriteTerms
         , stgTheme                = userTheme
@@ -464,11 +467,12 @@ serveProfileR (uid, user@User{..}) = do
     now <- liftIO getCurrentTime
     isAdmin <- checkAdmin
     thisUser <- fromMaybe uid <$> maybeAuthId
-    let changeEmailByUser = userDisplayEmail /= stgDisplayEmail && (not isAdmin || thisUser == uid)
+    let changeEmailByUser = (not isAdmin || thisUser == uid)
+        changeEmailProper = userDisplayEmail /= stgDisplayEmail && userEmail /= stgDisplayEmail
     runDBJobs $ do
       update uid $
-        [ UserDisplayEmail         =. stgDisplayEmail   | not changeEmailByUser                 ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below
+        [ UserDisplayEmail         =. stgDisplayEmail   | not changeEmailByUser, changeEmailProper ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below
-        [ UserPostLastUpdate       =. Just now          | userPostAddress   /= stgPostAddress   ] ++
+        [ UserPostLastUpdate       =. Just now          | userPostAddress /= stgPostAddress ] ++
         [ UserDisplayName          =. stgDisplayName
         , UserMaxFavourites        =. stgMaxFavourites
         , UserMaxFavouriteTerms    =. stgMaxFavouriteTerms
@@ -489,7 +493,7 @@ serveProfileR (uid, user@User{..}) = do
         , UserExamOfficeGetLabels  =. (stgExamOfficeSettings & eosettingsGetLabels)
         ]
       updateFavourites Nothing
-      when changeEmailByUser $ do
+      when (changeEmailByUser && changeEmailProper) $ do
         queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
         addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
       let

src/Handler/Users.hs

@@ -56,11 +56,10 @@ hijackUserForm = \csrf -> do
   (btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing
   return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView])
 
--- In case of refactoring, use this:
+instance HasEntity (DBRow (Entity User)) User where
--- instance HasEntity (DBRow (Entity User)) User where
+   hasEntity = _dbrOutput
---    hasEntity = _dbrOutput
+instance HasUser   (DBRow (Entity User)) where
--- instance HasUser   (DBRow (Entity USer)) where
+   hasUser = _dbrOutput . _entityVal
---    hasUser = _entityVal
 
 data UserAction = UserAvsSync | UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor | UserRemoveSubordinates
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@@ -112,9 +111,9 @@ postUsersR = do
       , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr
       , sortable (Just "user-company") (i18nCell MsgTableCompanies)   $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
           maybeMonoid <$> wgtCompanies uid
-      , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
+      -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- redundant
-          (AdminUserR <$> encrypt uid)
+      --     (AdminUserR <$> encrypt uid)
-          (toWgt userCompanyPersonalNumber)
+      --     (toWgt userCompanyPersonalNumber)
       , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyPersonalNumber
       , sortable (Just "company-department") (i18nCell MsgCompanyDepartment)  $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment
 --       , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
@@ -132,6 +131,7 @@ postUsersR = do
             pure $ mconcat supervisors
       , sortable (Just "last-login") (i18nCell MsgLastLogin)  $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
       , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
+      , colUserEmail
       , sortable (Just "ldap-sync")  (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
       , flip foldMap universeF $ \function ->
           sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
@@ -215,11 +215,12 @@ postUsersR = do
                 return (uf E.^. UserFunctionSchool)
             ) | function <- universeF
           ] ++
-          [ ( "name"
+          [ sortUserEmail id
-            , SortColumn $ \user -> user E.^. UserSurname
+          , ( "name"
+            , SortColumn (E.^. UserSurname)
             )
           , ( "display-name"
-            , SortColumn $ \user -> user E.^. UserDisplayName
+            , SortColumn (E.^. UserDisplayName)
             )
            , ( "matriculation"
             , SortColumn $ \user -> user E.^. UserMatrikelnummer

templates/profileData.hamlet

@@ -15,7 +15,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       <dd .deflist__dd>
         _{userAuthentication}
       $maybe avs <- avsId
-        $with avsNoPers <- tshow (view _userAvsNoPerson avs)        
+        $with avsNoPers <- tshow (view _userAvsNoPerson avs)
           <dt .deflist__dt>
             _{MsgAvsPersonNo}
             ^{messageTooltip tooltipAvsPersNo}
@@ -57,12 +57,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         <dt .deflist__dt>
           _{MsgTableBirthday} ^{usrAutomatic CU_UA_UserBirthday}
         <dd .deflist__dd>
-          ^{formatTimeW SelFormatDate bday}      
+          ^{formatTimeW SelFormatDate bday
       <dt .deflist__dt>
         _{MsgPrefersPostalExp}
       <dd .deflist__dd>
         $if userPrefersPostal /= actualPrefersPostal
-          ^{messageTooltip tooltipInvalidEmail} #
+          ^{messageTooltip tooltipInvalidEmail
         #{iconLetterOrEmail userPrefersPostal}
       $maybe addr <- actualPostAddress
         <dt .deflist__dt>
@@ -80,18 +80,21 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         _{MsgUserDisplayEmail} #
         ^{updateAutomatic emailAutomatic}
       <dd .deflist__dd .email>
-        $maybe primaryEmail <- actualDisplayEmail          
+        $maybe primaryEmail <- actualDisplayEmail
-          #{mailtoHtml primaryEmail}          
+          #{mailtoHtml primaryEmail}
         $nothing
-          ^{messageTooltip tooltipInvalidEmail} #
+          ^{messageTooltip tooltipInvalidEmail}
-          #{mailtoHtml userDisplayEmail}          
+          $if userDisplayEmail == ""
+            _{MsgUtilNoneSet}
+          $else 
+            #{mailtoHtml userDisplayEmail}
       $if Just userEmail /= actualDisplayEmail
         <dt .deflist__dt>
           _{MsgUserSystemEmail}
-        <dd .deflist__dd>          
+        <dd .deflist__dd>
           $if not (validEmail' userEmail)
-            ^{messageTooltip tooltipInvalidEmail} #
+            ^{messageTooltip tooltipInvalidEmail}
-          #{userEmail}
+          #{mailtoHtml userEmail}
       <dt .deflist__dt>
         _{MsgAdminUserPinPassword}
         ^{usrAutomatic CU_UA_UserPinPassword}
@@ -146,7 +149,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
             _{MsgNeverSet}
         $maybe pKey <- userLdapPrimaryKey
           <dt .deflist__dt>
-            _{MsgProfileLdapPrimaryKey}            
+            _{MsgProfileLdapPrimaryKey}
           <dd .deflist__dd .ldap-primary-key>
             #{pKey}
         <dt .deflist__dt>

test/Database/Fill.hs

@@ -126,8 +126,8 @@ fillDb = do
     , userLastAuthentication = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
-    , userEmail  = "noEmailKnown"
+    , userEmail  = "AVSNO:123456"
-    , userDisplayEmail = "felix.hamann@campus.lmu.de"
+    , userDisplayEmail = ""
     , userDisplayName = "Felix Hamann"
     , userSurname = "Hamann"
     , userFirstName = "Felix"