diff --git a/libs/wire-subsystems/src/Wire/MiniBackend.hs b/libs/wire-subsystems/src/Wire/MiniBackend.hs index c5bdc0ff238..5a51895058a 100644 --- a/libs/wire-subsystems/src/Wire/MiniBackend.hs +++ b/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 diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index b5561142dd7..16e128f1284 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/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 diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index d8203b95a9d..506ce4f9318 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/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 diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 08fb2a25d8c..f0e84fe51b2 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/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] diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index a8b5c30ccd0..5d39b5eb6db 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/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 $ diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 93b8238c39f..1d0a1cf577b 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/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