[WPB-25521] Refactor access control rules for collaborators.

changelog.d/5-internal/WPB-25521-refactor-access-control-rules-for-collaborators

@@ -0,0 +1,3 @@
+Refactor access control rules for collaborators.
+
+TODO: if the behavior changes in this PR, we need to move this and explain how!  (but with some luck, it'll remain a behavior-preserving refactoring job.)

libs/wire-api/src/Wire/API/Conversation.hs

@@ -1016,6 +1016,7 @@ data NewOne2OneConv = NewOne2OneConv
   { users :: [UserId],
     -- | A list of qualified users, which can include some local qualified users
     -- too.
+    -- TODO: why is this a list and not a pair, given the name `NewOne2OneConv`?
     qualifiedUsers :: [Qualified UserId],
     name :: Maybe (Range 1 256 Text),
     team :: Maybe ConvTeamInfo

libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs

@@ -637,25 +637,38 @@ checkBindingTeamPermissions ::
   TeamId ->
   Sem r (Maybe TeamId)
 checkBindingTeamPermissions lusr lother tid = do
+  -- TODO(fisx): i think this can be futher refactored to use
+  -- `getImplicitReachableLocals`.  i'm also still not sure this logic
+  -- is sound, need to think about this more!
+
+  -- TODO(fisx): also check the access control logic around
+  -- adding/removing conv members to/from group convs.  can that also
+  -- be simplified?
+
+  guardTeamBinding
   mTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lusr)
-  zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid
-  case (mTeamCollaborator, zusrMembership) of
+  mTeamMember <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid
+  case (mTeamCollaborator, mTeamMember) of
     (Just collaborator, Nothing) -> guardPerm CollaboratorPermission.ImplicitConnection collaborator
     (Nothing, mbMember) -> void $ permissionCheck CreateConversation mbMember
     (Just collaborator, Just member) ->
       unless (hasPermission collaborator CollaboratorPermission.ImplicitConnection || hasPermission member CreateConversation) $
         throwS @OperationDenied
-  TeamStore.getTeamBinding tid >>= \case
-    Just Binding -> do
-      when (isJust zusrMembership) $
-        verifyMembership tid (tUnqualified lusr)
-      mOtherTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lother)
-      unless (isJust mOtherTeamCollaborator) $
-        verifyMembership tid (tUnqualified lother)
-      pure (Just tid)
-    Just _ -> throwS @'NonBindingTeam
-    Nothing -> throwS @'TeamNotFound
+  when (isJust mTeamMember) $
+    verifyMembership tid (tUnqualified lusr)
+  mOtherTeamCollaborator <- internalGetTeamCollaborator tid (tUnqualified lother)
+  unless (isJust mOtherTeamCollaborator) $
+    verifyMembership tid (tUnqualified lother)
+  pure (Just tid)
   where
+    -- it is unclear why we do this here; it can be removed once we
+    -- remove binding teams from the code.
+    guardTeamBinding = do
+      TeamStore.getTeamBinding tid >>= \case
+        Just Binding -> pure ()
+        Just _ -> throwS @'NonBindingTeam
+        Nothing -> throwS @'TeamNotFound
+
     guardPerm p m =
       if m `hasPermission` p
         then pure ()

libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs

@@ -165,28 +165,39 @@ ensureConnectedToLocalsOrSameTeam ::
   Sem r ()
 ensureConnectedToLocalsOrSameTeam _ [] = pure ()
 ensureConnectedToLocalsOrSameTeam (tUnqualified -> u) uids = do
-  uTeams <- getUserTeams u
+  implicitConnections <- getImplicitReachableLocals u uids
+  ensureConnectedToLocals u (uids \\ implicitConnections)
+
+getImplicitReachableLocals ::
+  ( Member TeamStore r,
+    Member TeamCollaboratorsSubsystem r,
+    Member TeamSubsystem r
+  ) =>
+  UserId ->
+  [UserId] ->
+  Sem r [UserId]
+getImplicitReachableLocals reacher reachees = do
+  uTeams <- getUserTeams reacher
   icTeams <- getUserCollaborationTeams
   icUsers <- getTeamCollaborators uTeams
-  -- We collect all the relevant uids from same teams as the origin user
+  -- We collect all the relevant reachees from same teams as the origin user
   sameTeamUids <- forM (uTeams `union` icTeams) $ \team ->
-    fmap (view Mem.userId) <$> TeamSubsystem.internalSelectTeamMembers team uids
-  -- Do not check connections for users that are on the same team
-  ensureConnectedToLocals u ((uids \\ join sameTeamUids) \\ icUsers)
+    fmap (view Mem.userId) <$> TeamSubsystem.internalSelectTeamMembers team reachees
+  pure (join sameTeamUids `union` icUsers)
   where
     -- Teams in which the user who wants to reach out is member with
     -- `ImplicitConnection` permission.
     getUserCollaborationTeams :: (Member TeamCollaboratorsSubsystem r') => Sem r' [TeamId]
     getUserCollaborationTeams =
       gTeam
-        <$$> (filter (flip hasPermission CollaboratorPermission.ImplicitConnection) <$> internalGetTeamCollaborations u)
+        <$$> (filter (flip hasPermission CollaboratorPermission.ImplicitConnection) <$> internalGetTeamCollaborations reacher)
 
     -- We do not check the permissions of team collaborators if a user tries to
     -- reach out to them (if they are in the same team.) The reasoning behind
     -- this is that team collaborators have implicitly agreed to be
     -- collaborated with.
     getTeamCollaborators :: (Member TeamCollaboratorsSubsystem r') => [TeamId] -> Sem r' [UserId]
-    getTeamCollaborators teams = gUser <$$> internalGetTeamCollaboratorsWithIds (Set.fromList teams) (Set.fromList uids)
+    getTeamCollaborators teams = gUser <$$> internalGetTeamCollaboratorsWithIds (Set.fromList teams) (Set.fromList reachees)
 
 -- | Check that the user is connected to everybody else.
 --