fix(ldap): allow ldap update for mangled user entries

src/Foundation/Yesod/Auth.hs

@@ -174,7 +174,7 @@ upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapP
 -- | Upsert User DB according to given LDAP data (does not query LDAP itself)
 upsertCampusUser :: forall m.
                     ( MonadHandler m, HandlerSite m ~ UniWorX
-                    , MonadThrow m
+                    , MonadCatch m
                     )
                  => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
 upsertCampusUser upsertMode ldapData = do
@@ -193,7 +193,14 @@ upsertCampusUser upsertMode ldapData = do
                            (newUser ^. _userFirstName)
                            (newUser ^. _userSurname) 
                            (userRec ^. _userDisplayName)) $
-    update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
+    update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]
+  when (validEmail' (userRec ^. _userEmail)) $ do 
+    let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
+              ++ [ UserAuthentication =. AuthLDAP                 | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
+    unless (null emUps) $ update userId emUps
+    -- Attempt to update ident, too:
+    unless (validEmail' (userRec ^. _userIdent)) $
+      void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
 
   let
     userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
@@ -253,9 +260,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
       | otherwise
         -> throwM CampusUserInvalidIdent
 
-    userEmail <- if
+    userEmail <- if -- TODO: refactor
-      | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
+      -- | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
-        -> return $ CI.mk userEmail
+      --   -> return $ CI.mk userEmail
+      | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
+         -> return $ CI.mk userEmail
       | otherwise
         -> throwM CampusUserInvalidEmail
         
@@ -309,7 +318,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
                     , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
                     , UserCompanyDepartment       =. userCompanyDepartment
                     ] ++
-                    [ UserLastAuthentication =. Just now | isLogin ]
+                    [ UserLastAuthentication =. Just now  | isLogin ]
     return (newUser, userUpdate)
 
   where

src/Handler/Utils/Profile.hs

@@ -2,11 +2,14 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+-- TODO: why is this Handler.Utils.Profile instead of Utils.Profile? 
+-- TODO: consider merging with Handler.Utils.Users?
 module Handler.Utils.Profile
   ( checkDisplayName
   , validDisplayName
   , fixDisplayName
   , validPostAddress  
+  , validEmail, validEmail'
   ) where
 
 import Import.NoFoundation
@@ -14,10 +17,13 @@ import Import.NoFoundation
 import Data.Char
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as LT
+import qualified Data.CaseInsensitive as CI
 
 import qualified Data.MultiSet as MultiSet
 import qualified Data.Set as Set
 
+import qualified Text.Email.Validate as Email
+
 -- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
 stripFold :: Text -> Text 
 stripFold = Text.toCaseFold . Text.strip
@@ -72,3 +78,9 @@ validPostAddress (Just StoredMarkup {markupInput = addr})
   , 1 < length (LT.lines addr) 
     = True
 validPostAddress _ = False
+
+validEmail :: Email -> Bool      -- Email = Text
+validEmail = Email.isValid . encodeUtf8
+
+validEmail' :: UserEmail -> Bool -- UserEmail = CI Text
+validEmail' = Email.isValid . encodeUtf8 . CI.original

src/Handler/Utils/Users.hs

@@ -2,6 +2,7 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+-- NOTE: Also see Handler.Utils.Profile for similar utilities
 module Handler.Utils.Users
   ( computeUserAuthenticationDigest
   , Digest, SHA3_256
@@ -44,6 +45,7 @@ import qualified Data.Conduit.Combinators as C
 import qualified Data.MultiSet as MultiSet
 import qualified Data.Map as Map
 import qualified Data.Text as Text
+import Handler.Utils.Profile
 
 import Jobs.Types(Job, JobChildren)
 
@@ -73,7 +75,7 @@ getPostalPreferenceAndAddress usr@User{..} =
     (((userPrefersPostal || isNothing userPinPassword) && postPossible) || emailImpossible, pa)
   where
     orgEmail        = CI.original userEmail
-    emailImpossible = not ('@' `textElem` orgEmail  &&  '.' `textElem` orgEmail)
+    emailImpossible = validEmail orgEmail
     postPossible    = isJust pa
     pa = getPostalAddress usr
 

src/Jobs/Handler/SynchroniseLdap.hs

@@ -9,6 +9,7 @@ module Jobs.Handler.SynchroniseLdap
 
 import Import
 
+import qualified Data.CaseInsensitive as CI
 import qualified Data.Conduit.List as C
 
 import Auth.LDAP
@@ -47,13 +48,13 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
   case appLdapPool of
     Just ldapPool ->
       runDB . void . runMaybeT . handleExc $ do
-        user@User{userIdent} <- MaybeT $ get jUser
+        user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser
-
+        let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey 
         $logInfoS "SynchroniseLdap" [st|Synchronising #{userIdent}|]
 
         reTestAfter <- getsYesod $ view _appLdapReTestFailover
         ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user
-        void . lift $ upsertCampusUser (UpsertCampusUserLdapSync userIdent) ldapAttrs
+        void . lift $ upsertCampusUser (UpsertCampusUserLdapSync upsertIdent) ldapAttrs
     Nothing ->
       throwM SynchroniseLdapNoLdap
   where