Check claimed handles

libs/wire-subsystems/src/Wire/MiniBackend.hs

@@ -335,29 +335,39 @@ getLocalUsers = gets (.users)
 
 modifyLocalUsers ::
   Member (State MiniBackend) r =>
-  ([StoredUser] -> [StoredUser]) ->
+  ([StoredUser] -> Sem r [StoredUser]) ->
   Sem r ()
-modifyLocalUsers f = modify $ \b -> b {users = f b.users}
+modifyLocalUsers f = do
+  us <- gets (.users)
+  us' <- f us
+  modify $ \b -> b {users = us'}
 
 staticUserStoreInterpreter ::
+  forall r.
   Member (State MiniBackend) r =>
   InterpreterFor UserStore r
 staticUserStoreInterpreter = interpret $ \case
   GetUser uid -> find (\user -> user.id == uid) <$> getLocalUsers
-  UpdateUser uid update -> modifyLocalUsers (map doUpdate)
+  UpdateUserEither uid update -> runError $ modifyLocalUsers (traverse doUpdate)
     where
-      doUpdate :: StoredUser -> StoredUser
       doUpdate u
-        | u.id == uid =
-            maybe Imports.id setStoredUserAccentId update.accentId
+        | u.id == uid = do
+            -- check that handle isn't taken
+            for_ update.handle $ \hUpdate -> do
+              handles <- mapMaybe (.handle) <$> gets (.users)
+              when
+                ( hUpdate.old /= Just hUpdate.new
+                    && elem hUpdate.new handles
+                )
+                $ throw StoredUserUpdateHandleExists
+            pure
+              . maybe Imports.id setStoredUserAccentId update.accentId
               . maybe Imports.id setStoredUserAssets update.assets
               . maybe Imports.id setStoredUserPict update.pict
-              . maybe Imports.id (setStoredUserName . (.value)) update.name
+              . maybe Imports.id setStoredUserName update.name
               $ u
-      doUpdate u = u
+      doUpdate u = pure u
   -- TODO
-  ClaimHandle {} -> pure True
-  FreeHandle {} -> pure ()
   LookupHandle {} -> pure Nothing
   GlimpseHandle {} -> pure Nothing
 

libs/wire-subsystems/src/Wire/UserStore.hs

@@ -2,70 +2,38 @@
 
 module Wire.UserStore where
 
-import Data.Default
 import Data.Handle
 import Data.Id
 import Imports
 import Polysemy
+import Polysemy.Error
 import Wire.API.User
 import Wire.Arbitrary
 import Wire.StoredUser
 
-data AllowSCIMUpdates
-  = AllowSCIMUpdates
-  | ForbidSCIMUpdates
-  deriving (Show, Eq, Ord, Generic)
-  deriving (Arbitrary) via GenericUniform AllowSCIMUpdates
-
--- | Wrapper around an updated field which can potentially be managed by SCIM.
-data ScimUpdate a = MkScimUpdate
-  { -- | whether changes to SCIM-managed users should be allowed
-    allowScim :: AllowSCIMUpdates,
-    value :: a
+data StoredHandleUpdate = MkStoredHandleUpdate
+  { old :: Maybe Handle,
+    new :: Handle
   }
-  deriving stock (Eq, Ord, Show)
-  deriving (Functor, Foldable, Traversable)
-
-forbidScimUpdate :: a -> ScimUpdate a
-forbidScimUpdate = MkScimUpdate ForbidSCIMUpdates
-
-allowScimUpdate :: a -> ScimUpdate a
-allowScimUpdate = MkScimUpdate AllowSCIMUpdates
-
-instance Arbitrary a => Arbitrary (ScimUpdate a) where
-  arbitrary = MkScimUpdate <$> arbitrary <*> arbitrary
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving (Arbitrary) via GenericUniform StoredHandleUpdate
 
--- this is similar to `UserUpdate` in `Wire.API.User`, but supports updates to
--- all profile fields rather than just four.
-data UserProfileUpdate = MkUserProfileUpdate
-  { name :: Maybe (ScimUpdate Name),
+data StoredUserUpdate = MkStoredUserUpdate
+  { name :: Maybe Name,
     pict :: Maybe Pict,
     assets :: Maybe [Asset],
     accentId :: Maybe ColourId,
     locale :: Maybe Locale,
-    handle :: Maybe (ScimUpdate Handle)
+    handle :: Maybe StoredHandleUpdate
   }
   deriving stock (Eq, Ord, Show, Generic)
-  deriving (Arbitrary) via GenericUniform UserProfileUpdate
+  deriving (Arbitrary) via GenericUniform StoredUserUpdate
 
-instance Default UserProfileUpdate where
-  def =
-    MkUserProfileUpdate
-      { name = Nothing,
-        pict = Nothing,
-        assets = Nothing,
-        accentId = Nothing,
-        locale = Nothing,
-        handle = Nothing
-      }
+data StoredUserUpdateError = StoredUserUpdateHandleExists
 
 data UserStore m a where
   GetUser :: UserId -> UserStore m (Maybe StoredUser)
-  UpdateUser :: UserId -> UserProfileUpdate -> UserStore m ()
-  -- | Claim a new handle for an existing 'User'.
-  ClaimHandle :: UserId -> Maybe Handle -> Handle -> UserStore m Bool
-  -- | Free a 'Handle', making it available to be claimed again.
-  FreeHandle :: UserId -> Handle -> UserStore m ()
+  UpdateUserEither :: UserId -> StoredUserUpdate -> UserStore m (Either StoredUserUpdateError ())
   -- | this operation looks up a handle but may not give you stale data
   --   it is potentially slower and less resilient than 'GlimpseHandle'
   LookupHandle :: Handle -> UserStore m (Maybe UserId)
@@ -76,3 +44,10 @@ data UserStore m a where
   GlimpseHandle :: Handle -> UserStore m (Maybe UserId)
 
 makeSem ''UserStore
+
+updateUser ::
+  (Member UserStore r, Member (Error StoredUserUpdateError) r) =>
+  UserId ->
+  StoredUserUpdate ->
+  Sem r ()
+updateUser uid update = either throw pure =<< updateUserEither uid update

libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs

@@ -7,6 +7,7 @@ import Database.CQL.Protocol
 import Imports
 import Polysemy
 import Polysemy.Embed
+import Polysemy.Error
 import Wire.API.User
 import Wire.StoredUser
 import Wire.UserStore
@@ -17,9 +18,7 @@ interpretUserStoreCassandra casClient =
   interpret $
     runEmbedded (runClient casClient) . \case
       GetUser uid -> getUserImpl uid
-      UpdateUser uid update -> embed $ updateUserImpl uid update
-      ClaimHandle uid old new -> embed $ claimHandleImpl uid old new
-      FreeHandle uid h -> embed $ freeHandleImpl uid h
+      UpdateUserEither uid update -> embed $ updateUserImpl uid update
       LookupHandle hdl -> embed $ lookupHandleImpl LocalQuorum hdl
       GlimpseHandle hdl -> embed $ lookupHandleImpl One hdl
 
@@ -28,15 +27,20 @@ getUserImpl uid = embed $ do
   mUserTuple <- retry x1 $ query1 selectUser (params LocalQuorum (Identity uid))
   pure $ asRecord <$> mUserTuple
 
-updateUserImpl :: UserId -> UserProfileUpdate -> Client ()
-updateUserImpl uid update = retry x5 . batch $ do
-  setType BatchLogged
-  setConsistency LocalQuorum
-  for_ update.name $ \n -> addPrepQuery userDisplayNameUpdate (n.value, uid)
-  for_ update.pict $ \p -> addPrepQuery userPictUpdate (p, uid)
-  for_ update.assets $ \a -> addPrepQuery userAssetsUpdate (a, uid)
-  for_ update.accentId $ \c -> addPrepQuery userAccentIdUpdate (c, uid)
-
+updateUserImpl :: UserId -> StoredUserUpdate -> Client (Either StoredUserUpdateError ())
+updateUserImpl uid update = runM $ runError do
+  for_ update.handle $ \handleUpdate -> do
+    claimed <- embed $ claimHandleImpl uid handleUpdate.old handleUpdate.new
+    unless claimed $ throw StoredUserUpdateHandleExists
+  embed . retry x5 $ batch do
+    setType BatchLogged
+    setConsistency LocalQuorum
+    for_ update.name \n -> addPrepQuery userDisplayNameUpdate (n, uid)
+    for_ update.pict \p -> addPrepQuery userPictUpdate (p, uid)
+    for_ update.assets \a -> addPrepQuery userAssetsUpdate (a, uid)
+    for_ update.accentId \c -> addPrepQuery userAccentIdUpdate (c, uid)
+
+-- | Claim a new handle for an existing 'User'.
 claimHandleImpl :: UserId -> Maybe Handle -> Handle -> Client Bool
 claimHandleImpl uid oldHandle newHandle =
   isJust <$> do
@@ -56,6 +60,7 @@ claimHandleImpl uid oldHandle newHandle =
               freeHandleImpl uid
             pure result
 
+-- | Free a 'Handle', making it available to be claimed again.
 freeHandleImpl :: UserId -> Handle -> Client ()
 freeHandleImpl uid h = do
   mbHandleUid <- lookupHandleImpl LocalQuorum h

libs/wire-subsystems/src/Wire/UserSubsystem.hs

@@ -5,6 +5,7 @@ module Wire.UserSubsystem where
 -- FUTUREWORK(mangoiv): this should probably be renamed such that it doesn't
 -- associate with the name "brig" anymore
 
+import Data.Default
 import Data.Handle (Handle)
 import Data.Id
 import Data.Qualified
@@ -15,7 +16,7 @@ import Wire.API.Error
 import Wire.API.Error.Brig qualified as E
 import Wire.API.Federation.Error
 import Wire.API.User
-import Wire.UserStore
+import Wire.Arbitrary
 
 -- | All errors that are thrown by the user subsystem are subsumed under this sum type.
 data UserSubsystemError
@@ -41,6 +42,54 @@ userSubsystemErrorToWai =
 
 instance Exception UserSubsystemError
 
+data AllowSCIMUpdates
+  = AllowSCIMUpdates
+  | ForbidSCIMUpdates
+  deriving (Show, Eq, Ord, Generic)
+  deriving (Arbitrary) via GenericUniform AllowSCIMUpdates
+
+-- | Wrapper around an updated field which can potentially be managed by SCIM.
+data ScimUpdate a = MkScimUpdate
+  { -- | whether changes to SCIM-managed users should be allowed
+    allowScim :: AllowSCIMUpdates,
+    value :: a
+  }
+  deriving stock (Eq, Ord, Show)
+  deriving (Functor, Foldable, Traversable)
+
+instance Arbitrary a => Arbitrary (ScimUpdate a) where
+  arbitrary = MkScimUpdate <$> arbitrary <*> arbitrary
+
+forbidScimUpdate :: a -> ScimUpdate a
+forbidScimUpdate = MkScimUpdate ForbidSCIMUpdates
+
+allowScimUpdate :: a -> ScimUpdate a
+allowScimUpdate = MkScimUpdate AllowSCIMUpdates
+
+-- this is similar to `UserUpdate` in `Wire.API.User`, but supports updates to
+-- all profile fields rather than just four.
+data UserProfileUpdate = MkUserProfileUpdate
+  { name :: Maybe (ScimUpdate Name),
+    pict :: Maybe Pict,
+    assets :: Maybe [Asset],
+    accentId :: Maybe ColourId,
+    locale :: Maybe Locale,
+    handle :: Maybe (ScimUpdate Handle)
+  }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving (Arbitrary) via GenericUniform UserProfileUpdate
+
+instance Default UserProfileUpdate where
+  def =
+    MkUserProfileUpdate
+      { name = Nothing,
+        pict = Nothing,
+        assets = Nothing,
+        accentId = Nothing,
+        locale = Nothing,
+        handle = Nothing
+      }
+
 data UserSubsystem m a where
   -- | First arg is for authorization only.
   GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile]

libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs

@@ -306,7 +306,7 @@ updateUserProfileImpl (tUnqualified -> uid) mconn update = do
       throw UserSubsystemDisplayNameManagedByScim
 
   -- check if handle updates are allowed
-  for_ update.handle $ \handleUpdate -> do
+  oldHandle <- fmap join . for update.handle $ \handleUpdate -> do
     when (isBlacklistedHandle handleUpdate.value) $
       throw UserSubsystemInvalidHandle
     user <- getUser uid >>= note UserSubsystemNoIdentity
@@ -324,13 +324,23 @@ updateUserProfileImpl (tUnqualified -> uid) mconn update = do
       throw UserSubsystemHandleManagedByScim
     when (isNothing user.identity) $
       throw UserSubsystemNoIdentity
-    claimed <- claimHandle user.id user.handle handleUpdate.value
-    unless claimed $
-      throw UserSubsystemHandleExists
+    pure user.handle
 
-  updateUser uid update
+  mapError (\StoredUserUpdateHandleExists -> UserSubsystemHandleExists) $
+    updateUser uid (storedUserUpdate oldHandle update)
   generateUserEvent uid mconn (mkProfileUpdateEvent uid update)
 
+storedUserUpdate :: Maybe Handle -> UserProfileUpdate -> StoredUserUpdate
+storedUserUpdate oldHandle update =
+  MkStoredUserUpdate
+    { name = fmap (.value) update.name,
+      pict = update.pict,
+      assets = update.assets,
+      accentId = update.accentId,
+      locale = update.locale,
+      handle = fmap (MkStoredHandleUpdate oldHandle . (.value)) update.handle
+    }
+
 mkProfileUpdateEvent :: UserId -> UserProfileUpdate -> UserEvent
 mkProfileUpdateEvent uid update =
   UserUpdated $

libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs

@@ -25,7 +25,6 @@ import Wire.API.Team.Permission
 import Wire.API.User hiding (DeleteUser)
 import Wire.MiniBackend
 import Wire.StoredUser
-import Wire.UserStore
 import Wire.UserSubsystem
 import Wire.UserSubsystem.Interpreter