Update user groups with scim [WIP]

Author: battermann

integration/test/API/Spar.hs

@@ -97,6 +97,12 @@ createScimUserGroup domain token scimUserGroup = do
   body <- make scimUserGroup
   submit "POST" $ req & addJSON body . addHeader "Authorization" ("Bearer " <> token)
 
+updateScimUserGroup :: (HasCallStack, MakesValue domain, MakesValue scimUserGroup) => domain -> String -> String -> scimUserGroup -> App Response
+updateScimUserGroup domain token groupId scimUserGroup = do
+  req <- baseRequest domain Spar Versioned $ joinHttpPath ["scim", "v2", "Groups", groupId]
+  body <- make scimUserGroup
+  submit "PUT" $ req & addJSON body . addHeader "Authorization" ("Bearer " <> token)
+
 -- | https://staging-nginz-https.zinfra.io/v12/api/swagger-ui/#/default/idp-create
 createIdp :: (HasCallStack, MakesValue user) => user -> SAML.IdPMetadata -> App Response
 createIdp user metadata = do

integration/test/Test/Spar.hs

@@ -420,6 +420,50 @@ testSparScimCreateUserGroup = do
           ]
   createScimUserGroup OwnDomain tok scimUserGroup >>= assertSuccess
 
+testSparScimUpdateUserGroup :: (HasCallStack) => App ()
+testSparScimUpdateUserGroup = do
+  (owner, _, u1 : u2 : u3 : _) <- createTeam OwnDomain 4
+  u1Id <- u1 %. "id" >>= asString
+  u2Id <- u2 %. "id" >>= asString
+  u3Id <- u3 %. "id" >>= asString
+  tok <- createScimToken owner def >>= getJSON 200 >>= (%. "token") >>= asString
+  let scimUserGroup =
+        object
+          [ "schemas" .= ["urn:ietf:params:scim:schemas:core:2.0:Group"],
+            "displayName" .= "My funky group",
+            "members"
+              .= [ object
+                     [ "value" .= u1Id,
+                       "type" .= "User",
+                       "$ref" .= ("http://example.com:8088/scim/v2/Users/" <> u1Id)
+                     ],
+                   object
+                     [ "value" .= u2Id,
+                       "type" .= "User",
+                       "$ref" .= ("http://example.com:8088/scim/v2/Users/" <> u2Id)
+                     ]
+                 ]
+          ]
+  gid <- createScimUserGroup OwnDomain tok scimUserGroup >>= getJSON 200 >>= (%. "id") >>= asString
+  let scimUserGroupUpdated =
+        object
+          [ "schemas" .= ["urn:ietf:params:scim:schemas:core:2.0:Group"],
+            "displayName" .= "My even funkier group",
+            "members"
+              .= [ object
+                     [ "value" .= u2Id,
+                       "type" .= "User",
+                       "$ref" .= ("http://example.com:8088/scim/v2/Users/" <> u2Id)
+                     ],
+                   object
+                     [ "value" .= u3Id,
+                       "type" .= "User",
+                       "$ref" .= ("http://example.com:8088/scim/v2/Users/" <> u3Id)
+                     ]
+                 ]
+          ]
+  updateScimUserGroup OwnDomain tok gid scimUserGroupUpdated >>= assertSuccess
+
 ----------------------------------------------------------------------
 -- saml stuff
 

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

@@ -9,5 +9,6 @@ import Wire.API.User.Scim (SparTag)
 
 data ScimSubsystem m a where
   ScimCreateUserGroup :: TeamId -> SCG.Group -> ScimSubsystem m (SCG.StoredGroup SparTag)
+  ScimUpdateUserGroup :: TeamId -> UserGroupId -> SCG.Group -> ScimSubsystem m (SCG.StoredGroup SparTag)
 
 makeSem ''ScimSubsystem

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

@@ -21,6 +21,7 @@ import Wire.API.UserGroup
 import Wire.BrigAPIAccess (BrigAPIAccess)
 import Wire.BrigAPIAccess qualified as BrigAPI
 import Wire.ScimSubsystem
+import Wire.UserGroupStore qualified as UGStore
 import Wire.UserSubsystem
 
 data ScimSubsystemConfig = ScimSubsystemConfig
@@ -35,6 +36,7 @@ interpretScimSubsystem ::
   InterpreterFor ScimSubsystem r
 interpretScimSubsystem = interpret $ \case
   ScimCreateUserGroup teamId scimGroup -> createScimGroupImpl teamId scimGroup
+  ScimUpdateUserGroup teamId userGroupId scimGroup -> scimUpdateUserGroupImpl teamId userGroupId scimGroup
 
 data ScimSubsystemError
   = ScimSubsystemError ScimError
@@ -57,9 +59,7 @@ createScimGroupImpl ::
 createScimGroupImpl teamId grp = do
   membersNotManagedByScim <- do
     let uidsAsText = (.value) <$> grp.members
-    uids :: [UserId] <-
-      let thrw = throw . ScimSubsystemInvalidGroupMemberId
-       in forM uidsAsText $ either (thrw . Text.pack) pure . parseIdFromText
+    uids :: [UserId] <- uidsAsText `mapM` parseMember
     users <- BrigAPI.getAccountsBy def {getByUserId = uids}
     pure $
       users
@@ -83,6 +83,53 @@ createScimGroupImpl teamId grp = do
   ScimSubsystemConfig scimBaseUri <- input
   pure $ toStoredGroup scimBaseUri ug
 
+scimUpdateUserGroupImpl ::
+  forall r.
+  ( Member UGStore.UserGroupStore r,
+    Member (Input ScimSubsystemConfig) r,
+    Member (Error ScimSubsystemError) r,
+    Member UserSubsystem r,
+    Member (Input (Local ())) r
+  ) =>
+  TeamId ->
+  UserGroupId ->
+  SCG.Group ->
+  Sem r (SCG.StoredGroup SparTag)
+scimUpdateUserGroupImpl teamId gid grp = do
+  let includeChannels = False
+  mExisting <- UGStore.getUserGroup teamId gid includeChannels
+  existing <- maybe (scimThrow $ notFound "Group" (UUID.toText $ gid.toUUID)) pure mExisting
+  when (existing.managedBy /= ManagedByScim) do
+    scimThrow $ notFound "Group" (UUID.toText $ gid.toUUID)
+
+  ugName <- either (scimThrow . badRequest InvalidValue . Just) pure $ userGroupNameFromText grp.displayName
+
+  reqMemberIds <- for grp.members parseMember
+
+  let currentSet = Set.fromList (toList (runIdentity existing.members))
+      requestedSet = Set.fromList reqMemberIds
+      toAdd = requestedSet `Set.difference` currentSet
+
+  unless (null toAdd) do
+    accounts <- inputQualifyLocal def {getByUserId = Set.toList toAdd} >>= getAccountsBy
+    let nonScim = [userId u | u <- accounts, u.userManagedBy /= ManagedByScim]
+        found = Set.fromList (userId <$> accounts)
+        missing = Set.toList (toAdd `Set.difference` found)
+    unless (null nonScim) do
+      throw (ScimSubsystemScimGroupWithNonScimMembers nonScim)
+    case missing of
+      [] -> pure ()
+      (u : _) -> scimThrow $ notFound "User" (idToText u)
+
+  when (existing.name /= ugName) do
+    _ <- UGStore.updateUserGroup teamId gid UserGroupUpdate {name = ugName}
+    pure ()
+
+  UGStore.updateUsers gid (V.fromList reqMemberIds)
+
+  ScimSubsystemConfig scimBaseUri <- input
+  maybe (scimThrow $ notFound "Group" (UUID.toText $ gid.toUUID)) (pure . toStoredGroup scimBaseUri) =<< UGStore.getUserGroup teamId gid includeChannels
+
 toStoredGroup :: Common.URI -> UserGroup -> SCG.StoredGroup SparTag
 toStoredGroup scimBaseUri ug = Meta.WithMeta meta (Common.WithId ug.id_ sg)
   where
@@ -113,3 +160,9 @@ toStoredGroup scimBaseUri ug = Meta.WithMeta meta (Common.WithId ug.id_ sg)
               | uid <- toList (runIdentity ug.members)
             ]
         }
+
+parseMember ::
+  (Member (Error ScimSubsystemError) r) =>
+  SCG.Member ->
+  Sem r UserId
+parseMember m = parseIdFromText m.value & either (throw . ScimSubsystemInvalidGroupMemberId) pure

services/spar/src/Spar/Scim/Group.hs

@@ -68,8 +68,8 @@ instance (AuthDB SparTag (Sem r), Member ScimSubsystem r) => SCG.GroupDB SparTag
     AuthInfo SparTag ->
     SCG.GroupId SparTag ->
     SCG.Group ->
-    ScimHandler m (SCG.StoredGroup SparTag)
-  putGroup = undefined
+    ScimHandler (Sem r) (SCG.StoredGroup SparTag)
+  putGroup ((.stiTeam) -> tid) gid grp = lift $ scimUpdateUserGroup tid gid grp
 
   -- \| Modify an existing group.
   --