diff --git a/libs/wire-subsystems/src/Wire/MiniBackend.hs b/libs/wire-subsystems/src/Wire/MiniBackend.hs index 7ab981b1047..3462bc58293 100644 --- a/libs/wire-subsystems/src/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/src/Wire/MiniBackend.hs @@ -352,7 +352,7 @@ staticUserStoreInterpreter = interpret $ \case maybe Imports.id setStoredUserAccentId update.accentId . maybe Imports.id setStoredUserAssets update.assets . maybe Imports.id setStoredUserPict update.pict - . maybe Imports.id setStoredUserName update.name + . maybe Imports.id (setStoredUserName . (.value)) update.name $ u doUpdate u = u diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 408bc0db922..4b808a17e1d 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -10,10 +10,33 @@ import Wire.API.User import Wire.Arbitrary import Wire.StoredUser +data AllowSCIMUpdates + = AllowSCIMUpdates + | ForbidSCIMUpdates + deriving (Show, Eq, Ord, Generic) + deriving (Arbitrary) via GenericUniform AllowSCIMUpdates + +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) + +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 + -- 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 Name, + { name :: Maybe (ScimUpdate Name), pict :: Maybe Pict, assets :: Maybe [Asset], accentId :: Maybe ColourId, diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index 3de45896a81..98b350d4f91 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -26,7 +26,7 @@ updateUserImpl :: Member (Embed Client) r => UserId -> UserProfileUpdate -> Sem updateUserImpl uid update = embed . retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - for_ update.name $ \n -> addPrepQuery userDisplayNameUpdate (n, uid) + 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) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 88c9941d0d9..ca42dcec052 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -13,7 +13,6 @@ import Wire.API.Error import Wire.API.Error.Brig (BrigError (..)) import Wire.API.Federation.Error import Wire.API.User -import Wire.Arbitrary import Wire.UserStore -- | All errors that are thrown by the user subsystem are subsumed under this sum type. @@ -32,12 +31,6 @@ userSubsystemErrorToWai = instance Exception UserSubsystemError -data AllowSCIMUpdates - = AllowSCIMUpdates - | ForbidSCIMUpdates - deriving (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericUniform AllowSCIMUpdates - data UserSubsystem m a where -- | First arg is for authorization only. GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile] @@ -46,7 +39,7 @@ data UserSubsystem m a where -- | These give us partial success and hide concurrency in the interpreter. -- FUTUREWORK: it would be better to return errors as `Map Domain FederationError`, but would clients like that? GetUserProfilesWithErrors :: Local UserId -> [Qualified UserId] -> UserSubsystem m ([(Qualified UserId, FederationError)], [UserProfile]) - UpdateUserProfile :: Local UserId -> Maybe ConnId -> UserProfileUpdate -> AllowSCIMUpdates -> UserSubsystem m () + UpdateUserProfile :: Local UserId -> Maybe ConnId -> UserProfileUpdate -> UserSubsystem m () makeSem ''UserSubsystem diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 3635aab8c2a..348123047e1 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -34,7 +34,7 @@ import Wire.Sem.Now qualified as Now import Wire.StoredUser import Wire.UserEvents import Wire.UserStore -import Wire.UserSubsystem (AllowSCIMUpdates (..), UserSubsystem (..), UserSubsystemError (..)) +import Wire.UserSubsystem data UserSubsystemConfig = UserSubsystemConfig { emailVisibilityConfig :: EmailVisibilityConfig, @@ -83,7 +83,7 @@ interpretUserSubsystem = interpret $ \case GetUserProfiles self others -> getUserProfilesImpl self others GetLocalUserProfiles others -> getLocalUserProfilesImpl others GetUserProfilesWithErrors self others -> getUserProfilesWithErrorsImpl self others - UpdateUserProfile self mconn update allowScim -> updateUserProfileImpl self mconn update allowScim + UpdateUserProfile self mconn update -> updateUserProfileImpl self mconn update -- | Obtain user profiles for a list of users as they can be seen by -- a given user 'self'. If 'self' is an unknown 'UserId', return '[]'. @@ -179,7 +179,7 @@ getUserProfilesLocalPart requestingUser luids = do <$> traverse getRequestingUserInfo requestingUser -- FUTUREWORK: (in the interpreters where it makes sense) pull paginated lists from the DB, -- not just single rows. - catMaybes <$> traverse (getLocalUserProfile emailVisibilityConfigWithViewer) (sequence luids) + catMaybes <$> traverse (getLocalUserProfileImpl emailVisibilityConfigWithViewer) (sequence luids) where getRequestingUserInfo :: Local UserId -> Sem r (Maybe (TeamId, TeamMember)) getRequestingUserInfo self = do @@ -195,7 +195,7 @@ getUserProfilesLocalPart requestingUser luids = do Nothing -> pure Nothing Just tid -> (tid,) <$$> getTeamMember (tUnqualified self) tid -getLocalUserProfile :: +getLocalUserProfileImpl :: forall r. ( Member UserStore r, Member GalleyAPIAccess r, @@ -206,7 +206,7 @@ getLocalUserProfile :: EmailVisibilityConfigWithViewer -> Local UserId -> Sem r (Maybe UserProfile) -getLocalUserProfile emailVisibilityConfigWithViewer luid = do +getLocalUserProfileImpl emailVisibilityConfigWithViewer luid = do let domain = tDomain luid locale <- inputs defaultLocale runMaybeT $ do @@ -278,24 +278,23 @@ updateUserProfileImpl :: Local UserId -> Maybe ConnId -> UserProfileUpdate -> - AllowSCIMUpdates -> Sem r () -updateUserProfileImpl (tUnqualified -> uid) mconn update allowScim = do +updateUserProfileImpl (tUnqualified -> uid) mconn update = do -- check if name updates are allowed - for_ update.name $ \newName -> do + for_ update.name $ \nameUpdate -> do mbUser <- getUser uid user <- maybe (throw UserSubsystemProfileNotFound) pure mbUser unless ( user.managedBy /= Just ManagedByScim - || user.name == newName - || allowScim == AllowSCIMUpdates + || user.name == nameUpdate.value + || AllowSCIMUpdates == nameUpdate.allowScim ) $ throw UserSubsystemDisplayNameManagedByScim hasE2EId <- wsStatus . afcMlsE2EId <$> getAllFeatureConfigsForUser (Just uid) <&> \case FeatureStatusEnabled -> True FeatureStatusDisabled -> False - when (hasE2EId && newName /= user.name) $ + when (hasE2EId && nameUpdate.value /= user.name) $ throw UserSubsystemDisplayNameManagedByScim updateUser uid update @@ -305,7 +304,7 @@ mkProfileUpdateEvent :: UserId -> UserProfileUpdate -> UserEvent mkProfileUpdateEvent uid update = UserUpdated $ (emptyUserUpdatedData uid) - { eupName = update.name, + { eupName = fmap (.value) update.name, eupPict = update.pict, eupAccentId = update.accentId, eupAssets = update.assets diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 0662237f4ee..57ea146cd36 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -200,7 +200,7 @@ spec = describe "UserSubsystem.Interpreter" do .&&. length (snd retrievedProfilesWithErrors) === length remoteAUsers prop "Update user" $ - \(NotPendingStoredUser alice) localDomain update config allowScim -> do + \(NotPendingStoredUser alice) localDomain update config -> do let lusr = toLocalUnsafe localDomain alice.id localBackend = def {users = [alice {managedBy = Just ManagedByWire}]} profile = fromJust $ runNoFederationStack localBackend Nothing config do @@ -208,26 +208,21 @@ spec = describe "UserSubsystem.Interpreter" do lusr Nothing update - allowScim getUserProfile lusr (tUntagged lusr) in profile.profileQualifiedId === tUntagged lusr -- if the name/ pict/ assets/ accent id are not set, the original -- value should be preserved - .&&. profile.profileName === fromMaybe profile.profileName update.name + .&&. profile.profileName === maybe profile.profileName (.value) update.name .&&. profile.profilePict === fromMaybe profile.profilePict update.pict .&&. profile.profileAssets === fromMaybe profile.profileAssets update.assets .&&. profile.profileAccentId === fromMaybe profile.profileAccentId update.accentId prop "Update user events" $ - \(NotPendingStoredUser alice) localDomain update config allowScim -> do + \(NotPendingStoredUser alice) localDomain update config -> do let lusr = toLocalUnsafe localDomain alice.id localBackend = def {users = [alice {managedBy = Just ManagedByWire}]} events = runNoFederationStack localBackend Nothing config do - updateUserProfile - lusr - Nothing - update - allowScim + updateUserProfile lusr Nothing update get @[MiniEvent] in events === [MkMiniEvent alice.id (mkProfileUpdateEvent alice.id update)] @@ -242,7 +237,7 @@ spec = describe "UserSubsystem.Interpreter" do . runErrorUnsafe . runError $ interpretNoFederationStack localBackend Nothing def config do - updateUserProfile lusr Nothing update {name = Just name} ForbidSCIMUpdates + updateUserProfile lusr Nothing update {name = Just (forbidScimUpdate name)} getUserProfile lusr (tUntagged lusr) in Left UserSubsystemDisplayNameManagedByScim === profileErr @@ -257,6 +252,6 @@ spec = describe "UserSubsystem.Interpreter" do . runErrorUnsafe . runError $ interpretNoFederationStack localBackend Nothing def {afcMlsE2EId = setStatus FeatureStatusEnabled defFeatureStatus} config do - updateUserProfile lusr Nothing update {name = Just name} AllowSCIMUpdates + updateUserProfile lusr Nothing update {name = Just (allowScimUpdate name)} getUserProfile lusr (tUntagged lusr) in Left UserSubsystemDisplayNameManagedByScim === profileErr diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 5b3684edc9c..a27760f5802 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -264,8 +264,8 @@ library , cql , cryptobox-haskell >=0.1.1 , currency-codes >=2.0 - , data-timeout >=0.3 , data-default + , data-timeout >=0.3 , dns , dns-util , enclosed-exceptions >=1.0 diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 65f092bfbdc..7b517ab0f2a 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -105,7 +105,7 @@ import Wire.NotificationSubsystem import Wire.Rpc import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) -import Wire.UserStore (UserProfileUpdate (..)) +import Wire.UserStore (UserProfileUpdate (..), allowScimUpdate) import Wire.UserSubsystem servantSitemap :: @@ -869,9 +869,9 @@ updateUserNameH uid (NameUpdate nameUpd) = NoContent <$ do luid <- qualifyLocal uid name <- either (const $ throwStd (errorToWai @'E.InvalidUser)) pure $ mkName nameUpd - let uu = (def :: UserProfileUpdate) {name = Just name} + let uu = (def :: UserProfileUpdate) {name = Just (allowScimUpdate name)} lift (wrapClient $ Data.lookupUser WithPendingInvitations uid) >>= \case - Just _ -> lift . liftSem $ updateUserProfile luid Nothing uu API.AllowSCIMUpdates + Just _ -> lift . liftSem $ updateUserProfile luid Nothing uu Nothing -> throwStd (errorToWai @'E.InvalidUser) checkHandleInternalH :: Handle -> (Handler r) CheckHandleResponse diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index b21d49af20a..3ad74c88582 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -165,7 +165,7 @@ import Wire.Sem.Concurrency import Wire.Sem.Jwk (Jwk) import Wire.Sem.Now (Now) import Wire.Sem.Paging.Cassandra (InternalPaging) -import Wire.UserStore (UserProfileUpdate (..)) +import Wire.UserStore (UserProfileUpdate (..), forbidScimUpdate) import Wire.UserSubsystem -- User API ----------------------------------------------------------- @@ -927,13 +927,13 @@ updateUser :: updateUser uid conn uu = do let update = def - { name = uu.uupName, + { name = fmap forbidScimUpdate uu.uupName, pict = uu.uupPict, assets = uu.uupAssets, accentId = uu.uupAccentId } lift . liftSem $ - updateUserProfile uid (Just conn) update ForbidSCIMUpdates + updateUserProfile uid (Just conn) update changePhone :: ( Member BlacklistStore r, @@ -995,7 +995,6 @@ changeLocale lusr conn l = lusr (Just conn) def {locale = Just l.luLocale} - ForbidSCIMUpdates changeSupportedProtocols :: ( Member (Embed HttpClientIO) r, diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 2eb609aa59d..99d2e21fc81 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -181,6 +181,7 @@ import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserSubsystem +import Wire.UserStore (AllowSCIMUpdates(..)) ------------------------------------------------------------------------------- -- Create User