fix(users): assimilate merges possibly incomplete user fields

messages/uniworx/categories/user/de-de-formal.msg

@@ -22,7 +22,7 @@ AdminUserPostAddress: Postalische Anschrift
 AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
 AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails
 AdminUserNoPassword: Kein Passwort gesetzt
-AdminUserAssimilate: Benutzer assimilieren
+AdminUserAssimilate: Diesen Benutzer assimilieren von
 UserAdded: Benutzer erfolgreich angelegt
 UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
 HeadingUserAdd: Benutzer:in anlegen

messages/uniworx/categories/user/en-eu.msg

@@ -22,7 +22,7 @@ AdminUserPostAddress: Postal Address
 AdminUserPrefersPostal: Prefers postal letters over email
 AdminUserPinPassword: Password used for PDF attachments to emails
 AdminUserNoPassword: No password set
-AdminUserAssimilate: Assimilate user
+AdminUserAssimilate: Assimilate user by another user
 UserAdded: Successfully added user
 UserCollision: Could not create user due to uniqueness constraint
 HeadingUserAdd: Add user

src/Handler/Users.hs

@@ -564,7 +564,7 @@ postAdminUserR uuid = do
     let assimilateForm' = renderAForm FormStandard $
           areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing
         assimilateAction oldUserId = do
-          res <- try . runDB . setSerializable $ assimilateUser uid oldUserId
+          res <- try . runDB . setSerializable $ assimilateUser oldUserId uid
           case res of
             Left (err :: UserAssimilateException) ->
               addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right

src/Handler/Utils/Users.hs

@@ -34,7 +34,7 @@ import qualified Data.Aeson as JSON
 import qualified Data.Aeson.Types as JSON
 
 import qualified Data.Set as Set
-import qualified Data.List as List
+-- import qualified Data.List as List
 import qualified Data.CaseInsensitive as CI
 
 import qualified Database.Esqueleto.Legacy as E
@@ -287,6 +287,16 @@ assimilateUser :: UserId -- ^ @newUserId@
 --
 -- Fatal errors are thrown, non-fatal warnings are returned
 assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
+  -- retrieve user entities first, to ensure they both exist
+  (oldUserEnt, newUserEnt) <- do 
+      oldUser <- getEntity oldUserId
+      newUser <- getEntity newUserId
+      case (oldUser, newUser) of 
+        (Just old, Just new) -> return (old,new)
+        _ -> tellError UserAssimilateCouldNotDetermineUserIdents
+  let oldUser = oldUserEnt ^. _entityVal
+      newUser = newUserEnt ^. _entityVal
+
   E.insertSelectWithConflict
     UniqueCourseFavourite
     (E.from $ \courseFavourite -> do
@@ -859,18 +869,38 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
     (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )
   deleteWhere [ UserCompanyUser ==. oldUserId]
 
-  userIdents <- E.select . E.from $ \user -> do
+  -- merge some optional / incomplete user fields
-    E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId]
+  update newUserId [upd | (True, upd) <-    -- NOTE: persist does shortcircuit null updates as expected
-    return ( user E.^. UserId
+      [ ( isNothing (newUser ^. _userLdapPrimaryKey) && isJust (oldUser ^. _userLdapPrimaryKey)
-           , user E.^. UserIdent
+        , UserLdapPrimaryKey =. oldUser ^. _userLdapPrimaryKey )
-           )
+      , ( newUser ^. _userAuthentication > oldUser ^. _userAuthentication
-  case (,) <$> List.lookup (E.Value oldUserId) userIdents <*> List.lookup (E.Value newUserId) userIdents of
+        , UserAuthentication =. oldUser ^. _userAuthentication )
-    Just (E.Value oldIdent, E.Value newIdent')
+      , ( newUser ^. _userLastAuthentication < oldUser ^. _userLastAuthentication
-      | oldIdent /= newIdent' -> audit $ TransactionUserIdentChanged oldIdent newIdent'
+        , UserLastAuthentication =. oldUser ^. _userLastAuthentication )
-      | otherwise -> return ()
+      , ( newUser ^. _userCreated > oldUser ^. _userCreated
-    _other -> tellError UserAssimilateCouldNotDetermineUserIdents
+        , UserCreated =. oldUser ^. _userCreated )
+      , ( not (validEmail' (newUser ^. _userEmail       )) && validEmail' (oldUser ^. _userEmail)
+        , UserEmail =. oldUser ^. _userEmail)
+      , ( not (validEmail' (newUser ^. _userDisplayEmail)) && validEmail' (oldUser ^. _userDisplayEmail)
+        , UserDisplayEmail =. oldUser ^. _userDisplayEmail)
+      , ( isNothing (newUser ^. _userMatrikelnummer) && isJust (oldUser ^. _userMatrikelnummer)
+        , UserMatrikelnummer =. oldUser ^. _userMatrikelnummer )
+      , ( isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress)
+        , UserPostAddress =. oldUser ^. _userPostAddress )
+      , ( isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress)
+        , UserPostLastUpdate =. oldUser ^. _userPostLastUpdate )
+      , ( (isJust (newUser ^. _userPostAddress) || isJust (oldUser ^. _userPostAddress))
+          && (newUser ^. _userPrefersPostal || oldUser ^. _userPrefersPostal)
+        , UserPrefersPostal =. True )
+      , ( isNothing (newUser ^. _userPinPassword) && isJust (oldUser ^. _userPinPassword)
+        , UserPinPassword =. oldUser ^. _userPinPassword )      
+      ]
+    ]
 
   delete oldUserId
+  let oldUsrIdent = oldUser ^. _userIdent
+      newUsrIdent = newUser ^. _userIdent
+  when (oldUsrIdent /= newUsrIdent) $ audit $ TransactionUserIdentChanged oldUsrIdent newUsrIdent
   audit $ TransactionUserAssimilated newUserId oldUserId
   where
     tellWarning :: UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) ()