Refactor: team conversation access control.

Author: fisx

libs/wire-api/src/Wire/API/Team/Member.hs

@@ -71,6 +71,10 @@ module Wire.API.Team.Member
     IsPerm (..),
     HiddenPerm (..),
     mkSingleTeamMembersPage,
+
+    -- * TeamPrincipal
+    TeamPrincipal,
+    isFullTeamMember,
   )
 where
 
@@ -657,6 +661,22 @@ collaboratorToTeamPermissions =
         Collaborator.ImplicitConnection -> mempty
     )
 
+-- | A user associated with a team, either as a collaborator (@Left@) or as a
+-- full team member (@Right@).  The 'IsPerm' instance is derived automatically
+-- via the 'Either' instance, using 'collaboratorToTeamPermissions' for the
+-- @Left@ case.
+type TeamPrincipal = Either TeamCollaborator TeamMember
+
+-- | True only for full team members, not for collaborators.
+-- Used in conversation access-role checks that enforce team-member-only
+-- conversations, preserving the invariant that collaborators are not
+-- considered equivalent to full members for access control.
+--
+-- (We probably do not want to discriminate against collaborators in
+-- this way, but that's a semantic change for another PR.)
+isFullTeamMember :: TeamPrincipal -> Bool
+isFullTeamMember = isRight
+
 ----------------------------------------------------------------------
 
 makeLenses ''TeamMember'

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

@@ -794,8 +794,8 @@ performConversationJoin qusr lconv (ConversationJoin invited role joinType) = do
       tms <-
         Map.fromList . map (view Wire.API.Team.Member.userId &&& Imports.id)
           <$> TeamSubsystem.internalSelectTeamMembers tid newUsers
-      let userMembershipMap = map (Imports.id &&& flip Map.lookup tms) newUsers
-      ensureAccessRole (convAccessRoles conv) userMembershipMap
+      let userMembershipMap = map (Imports.id &&& (fmap Right . flip Map.lookup tms)) newUsers
+       in ensureAccessRole (convAccessRoles conv) userMembershipMap
       ensureConnectedToLocalsOrSameTeam lusr newUsers
     checkLocals lusr Nothing newUsers = do
       ensureAccessRole (convAccessRoles conv) (map (,Nothing) newUsers)

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

@@ -330,11 +330,8 @@ checkCreateConvPermissions lusr newConv Nothing allUsers = do
   ensureConnected lusr allUsers
 checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do
   let convTeam = cnvTeamId tinfo
-  mTeamMember <- getTeamMember (tUnqualified lusr) (Just convTeam)
-  teamAssociation <- case mTeamMember of
-    Just tm -> pure (Just (Right tm))
-    Nothing -> do
-      Left <$$> internalGetTeamCollaborator convTeam (tUnqualified lusr)
+  teamAssociation <- TeamSubsystem.lookupTeamPrincipal convTeam (tUnqualified lusr)
+  let mTeamMember = teamAssociation >>= either (const Nothing) Just
 
   let checkGroup = do
         void $ permissionCheck CreateConversation teamAssociation
@@ -347,7 +344,7 @@ checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do
     MeetingConversation -> checkGroup
 
   convLocalMemberships <- mapM (flip TeamSubsystem.internalGetTeamMember convTeam) (ulLocals allUsers)
-  ensureAccessRole (accessRoles newConv) (zip (ulLocals allUsers) convLocalMemberships)
+  ensureAccessRole (accessRoles newConv) (zip (ulLocals allUsers) (fmap (fmap Right) convLocalMemberships))
   ensureConnectedToLocals (tUnqualified lusr) (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships))
   ensureConnectedToRemotes lusr (ulRemotes allUsers)
   where

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

@@ -115,12 +115,12 @@ ensureAccessRole ::
     Member (ErrorS 'ConvAccessDenied) r
   ) =>
   Set Public.AccessRole ->
-  [(UserId, Maybe TeamMember {- isJust iff user and conv are in the same team -})] ->
+  [(UserId, Maybe TeamPrincipal {- Just (Right tm) iff full team member, Just (Left c) iff collaborator, Nothing otherwise -})] ->
   Sem r ()
 ensureAccessRole roles users = do
   when (Set.null roles) $ throwS @'ConvAccessDenied
   unless (NonTeamMemberAccessRole `Set.member` roles) $
-    when (any (isNothing . snd) users) $
+    when (any (maybe True (not . isFullTeamMember) . snd) users) $
       throwS @'NotATeamMember
   unless (Set.fromList [GuestAccessRole, ServiceAccessRole] `Set.isSubsetOf` roles) $ do
     activated <- lookupActivatedUsers (fst <$> users)
@@ -685,7 +685,7 @@ ensureConversationAccess ::
 ensureConversationAccess zusr conv access = do
   ensureAccess conv access
   zusrMembership <- maybe (pure Nothing) (TeamSubsystem.internalGetTeamMember zusr) (Data.convTeam conv)
-  ensureAccessRole (Data.convAccessRoles conv) [(zusr, zusrMembership)]
+  ensureAccessRole (Data.convAccessRoles conv) [(zusr, fmap Right zusrMembership)]
 
 ensureAccess ::
   (Member (ErrorS 'ConvAccessDenied) r) =>

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

@@ -33,6 +33,7 @@ import Wire.API.Team.LegalHold (UserLegalHoldStatusResponse)
 import Wire.API.Team.Member
 import Wire.API.Team.Member.Error
 import Wire.API.Team.Member.Info (TeamMemberInfoList)
+import Wire.TeamCollaboratorsSubsystem
 
 data PermissionCheckArgs teamAssociation where
   PermissionCheckArgs ::
@@ -144,3 +145,18 @@ checkConsent ::
   Sem r ConsentGiven
 checkConsent teamsOfUsers other = do
   consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other
+
+-- | Look up a user as a 'TeamPrincipal': a full member (@Right@) takes
+-- precedence over a collaborator (@Left@).  Returns 'Nothing' if the user has
+-- no association with the team.
+lookupTeamPrincipal ::
+  ( Member TeamSubsystem r,
+    Member TeamCollaboratorsSubsystem r
+  ) =>
+  TeamId ->
+  UserId ->
+  Sem r (Maybe TeamPrincipal)
+lookupTeamPrincipal tid uid =
+  internalGetTeamMember uid tid >>= \case
+    Just m -> pure (Just (Right m))
+    Nothing -> fmap Left <$> internalGetTeamCollaborator tid uid