Handle LH policy conflicts in group conversations (#1595)

* Import removeTeam to Galley.API.LegalHold without import cycles.

(will be needed shortly.)

* iterateConversations.

(Copied from #1507, which
has meanwhile been reverted in
#1549.)

* Make removeMember device id argument optional.

* handleGroupConvPolicyConflicts [wip]

* test stub

* mapcon

* fix bug in handleGroupConvPolicyConflicts

* add 2 test cases: who is admin? who gets removed?

* Add group conv logic [wip]

* move lh helpers to utils

* fixup add members

* fixup tests

* use Conversation from galley to include self

* implement anyLHConsentMissing

* Move check*Event funs from Teams to Utils

* update first

* adjust test to new setting & adjust case when peer is admin

* hi ci

* Add checks for leave events

* add testNoConsentCannotBeInvited

* add failing test case

* Add guards (test succeeds)

* refactor: rename guard functions

* comment wording

* anyLegalholdActivated: make true to the name

* adjust testNoConsentRemoveFromGroupConv

* inviting conflicting users: adjust and rename test

* remove futurework (wont do) and add comments

* remove test marker

* spell out the tests

* add FUTUREWORKs for test structure

* comment wording

* add test for v2 endpoint

* add additional safeguard

* Cleanup.

* Add two missing test case stubs.

* Eliminate redundant negation in function name.

* Boolean blindness.

only the first line changed, rest is ormolu noise.

* Fix call side.

* Changed my mind about whether boolean blindness is a good thing.

* Fixup.

* Cleanup (move source comment to inner block).

* Tweak detail.

* Remove dubious claim.

#1595 (comment)

* Simplify.

* Move code around.

* LH consent: guarantee that all conflicting conv members are removed.

* Taking back e16a0bc.

(I thought I had spotted a difference in database load, but I think i
was wrong, and the original code is more straight-forward.)

* Fixup.

* Change test cases & descriptions.

* fix syntax

* All -> Some (explanation in message)

Why
1) Because "Some" is the negation of "None"
2) This is consistent with testGroup "Legalhold is activated for user A in a group conversation"

* add failing test case

* Refactor: factor out new fn getLHStatusForUsers

* Update business logic

* Remove NoConsentingAdmins test case

* Add test case: mixed invitees

* Refactor: group tests regarding invite together

* assertion

(it's non-trivial, but easy enough to convince ourselves that it'll
pass fine, so no error handling needed.)

* Language.

Co-authored-by: Matthias Fischmann <mf@zerobuzz.net>

services/galley/src/Galley/API/Create.hs

@@ -29,7 +29,8 @@ import Control.Lens hiding ((??))
 import Control.Monad.Catch
 import Data.Id
 import Data.List1 (list1)
-import Data.Qualified (Qualified (..), partitionRemoteOrLocalIds')
+import Data.Misc (FutureWork (FutureWork))
+import Data.Qualified (Qualified (..), Remote, partitionRemoteOrLocalIds')
 import Data.Range
 import qualified Data.Set as Set
 import Data.Time
@@ -53,6 +54,7 @@ import qualified Servant
 import Servant.API (Union)
 import qualified Wire.API.Conversation as Public
 import Wire.API.Routes.Public.Galley (ConversationResponses)
+import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented))
 
 -- Servant helpers ------------------------------------------------------
 
@@ -93,6 +95,13 @@ internalCreateManagedConversation zusr zcon (NewConvManaged body) = do
     Nothing -> throwM internalError
     Just tinfo -> createTeamGroupConv zusr zcon tinfo body
 
+ensureNoLegalholdConflicts :: [Remote UserId] -> [UserId] -> Galley ()
+ensureNoLegalholdConflicts remotes locals = do
+  let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes
+  whenM (anyLegalholdActivated locals) $
+    unlessM (allLegalholdConsentGiven locals) $
+      throwM missingLegalholdConsent
+
 -- | A helper for creating a regular (non-team) group conversation.
 createRegularGroupConv :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse
 createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do
@@ -106,6 +115,7 @@ createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do
   let (remotes, locals) = fromConvSize checkedPartitionedUsers
   ensureConnected zusr locals
   checkRemoteUsersExist remotes
+  ensureNoLegalholdConflicts remotes locals
   -- FUTUREWORK: Implement (3) per comments for Update.addMembers. (also for createTeamGroupConv)
   c <-
     Data.createConversation
@@ -167,6 +177,7 @@ createTeamGroupConv zusr zcon tinfo body = do
         ensureConnectedToLocals zusr (notTeamMember localUserIds (catMaybes convLocalMemberships))
         pure checkedPartitionedUsers
   checkRemoteUsersExist remotes
+  ensureNoLegalholdConflicts remotes localUserIds
   -- FUTUREWORK: Implement (3) per comments for Update.addMembers.
   conv <-
     Data.createConversation

services/galley/src/Galley/API/LegalHold.hs

@@ -37,15 +37,19 @@ import Brig.Types.Connection (UpdateConnectionsInternal (..))
 import Brig.Types.Intra (ConnectionStatus (..))
 import Brig.Types.Provider
 import Brig.Types.Team.LegalHold hiding (userId)
+import Control.Exception (assert)
 import Control.Lens (view, (^.))
 import Control.Monad.Catch
 import Data.ByteString.Conversion (toByteString, toByteString')
 import Data.Id
 import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus)
 import Data.List.Split (chunksOf)
-import qualified Data.Map.Strict as Map
 import Data.Misc
+import Data.Proxy (Proxy (Proxy))
+import Data.Range (toRange)
 import Galley.API.Error
+import Galley.API.Query (iterateConversations)
+import Galley.API.Update (removeMember)
 import Galley.API.Util
 import Galley.App
 import qualified Galley.Data as Data
@@ -56,6 +60,7 @@ import qualified Galley.External.LegalHoldService as LHService
 import qualified Galley.Intra.Client as Client
 import Galley.Intra.User (getConnections, putConnectionInternal)
 import qualified Galley.Options as Opts
+import Galley.Types (LocalMember, memConvRoleName, memId)
 import Galley.Types.Teams as Team
 import Imports
 import Network.HTTP.Types (status200, status404)
@@ -65,7 +70,10 @@ import Network.Wai.Predicate hiding (or, result, setStatus, _3)
 import Network.Wai.Utilities as Wai
 import qualified System.Logger.Class as Log
 import UnliftIO.Async (pooledMapConcurrentlyN_)
+import Wire.API.Conversation (ConvType (..))
+import Wire.API.Conversation.Role (roleNameWireAdmin)
 import qualified Wire.API.Team.Feature as Public
+import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented))
 import qualified Wire.API.Team.LegalHold as Public
 
 assertLegalHoldEnabledForTeam :: TeamId -> Galley ()
@@ -365,14 +373,6 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) =
       -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386)
       changeLegalholdStatus tid uid userLHStatus UserLegalHoldDisabled
 
--- | If not enabled nor pending, then it's disabled
-userLHEnabled :: UserLegalHoldStatus -> Bool
-userLHEnabled = \case
-  UserLegalHoldEnabled -> True
-  UserLegalHoldPending -> True
-  UserLegalHoldDisabled -> False
-  UserLegalHoldNoConsent -> False
-
 -- | Allow no-consent => consent without further changes.  If LH device is requested, enabled,
 -- or disabled, make sure the affected connections are screened for policy conflict (anybody
 -- with no-consent), and put those connections in the appropriate blocked state.
@@ -405,13 +405,15 @@ changeLegalholdStatus tid uid old new = do
   where
     update = LegalHoldData.setUserLegalHoldStatus tid uid new
     removeblocks = void $ putConnectionInternal (RemoveLHBlocksInvolving uid)
-    addblocks = blockConnectionsFrom1on1s uid
+    addblocks = do
+      blockNonConsentingConnections uid
+      handleGroupConvPolicyConflicts uid new
     noop = pure ()
     illegal = throwM userLegalHoldIllegalOperation
 
 -- FUTUREWORK: make this async?
-blockConnectionsFrom1on1s :: UserId -> Galley ()
-blockConnectionsFrom1on1s uid = do
+blockNonConsentingConnections :: UserId -> Galley ()
+blockNonConsentingConnections uid = do
   conns <- getConnections [uid] Nothing Nothing
   errmsgs <- do
     conflicts <- mconcat <$> findConflicts conns
@@ -428,23 +430,14 @@ blockConnectionsFrom1on1s uid = do
       -- FUTUREWORK: Handle remoteUsers here when federation is implemented
       for (chunksOf 32 localUids) $ \others -> do
         teamsOfUsers <- Data.usersTeams others
-        filterM (shouldBlock teamsOfUsers) others
+        filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others
 
     blockConflicts :: UserId -> [UserId] -> Galley [String]
     blockConflicts _ [] = pure []
     blockConflicts userLegalhold othersToBlock@(_ : _) = do
       status <- putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock)
       pure $ ["blocking users failed: " <> show (status, othersToBlock) | status /= status200]
 
-    shouldBlock :: Map UserId TeamId -> UserId -> Galley Bool
-    shouldBlock teamsOfUsers other =
-      (== UserLegalHoldNoConsent)
-        <$> case Map.lookup other teamsOfUsers of
-          Nothing -> pure defUserLegalHoldStatus
-          Just team -> do
-            mMember <- Data.teamMember team other
-            pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember
-
 setTeamLegalholdWhitelisted :: TeamId -> Galley ()
 setTeamLegalholdWhitelisted tid = do
   LegalHoldData.setTeamLegalholdWhitelisted tid
@@ -473,3 +466,48 @@ getTeamLegalholdWhitelistedH tid = do
     if lhEnabled
       then setStatus status200 empty
       else setStatus status404 empty
+
+-- | Make sure that enough people are removed from all conversations that contain user `uid`
+-- that no policy conflict arises.
+--
+-- It is guaranteed that no group will ever end up without a group admin because of a policy
+-- conflict: If at least one group admin has 'ConsentGiven', non-consenting users are removed.
+-- Otherwise, we assume that the group is dominated by people not interested in giving
+-- consent, and users carrying LH devices are removed instead.
+--
+-- The first argument to this function needs explaining: in order to guarantee that this
+-- function terminates before we set the LH of user `uid` on pending, we need to call it
+-- first.  This means that user `uid` has outdated LH status while this function is running,
+-- which may cause wrong behavior.  In order to guarantee correct behavior, the first argument
+-- contains the hypothetical new LH status of `uid`'s so it can be consulted instead of the
+-- one from the database.
+handleGroupConvPolicyConflicts :: UserId -> UserLegalHoldStatus -> Galley ()
+handleGroupConvPolicyConflicts uid hypotheticalLHStatus =
+  void $
+    iterateConversations uid (toRange (Proxy @500)) $ \convs -> do
+      for_ (filter ((== RegularConv) . Data.convType) convs) $ \conv -> do
+        let FutureWork _convRemoteMembers' = FutureWork @'LegalholdPlusFederationNotImplemented Data.convRemoteMembers
+
+        membersAndLHStatus :: [(LocalMember, UserLegalHoldStatus)] <- do
+          let mems = Data.convLocalMembers conv
+          uidsLHStatus <- getLHStatusForUsers (memId <$> mems)
+          pure $
+            zipWith
+              ( \mem (mid, status) ->
+                  assert (memId mem == mid) $
+                    if memId mem == uid
+                      then (mem, hypotheticalLHStatus)
+                      else (mem, status)
+              )
+              mems
+              uidsLHStatus
+
+        if any
+          ((== ConsentGiven) . consentGiven . snd)
+          (filter ((== roleNameWireAdmin) . memConvRoleName . fst) membersAndLHStatus)
+          then do
+            for_ (filter ((== ConsentNotGiven) . consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do
+              removeMember (memId memberNoConsent) Nothing (Data.convId conv) (memId memberNoConsent)
+          else do
+            for_ (filter (userLHEnabled . snd) membersAndLHStatus) $ \(legalholder, _) -> do
+              removeMember (memId legalholder) Nothing (Data.convId conv) (memId legalholder)

services/galley/src/Galley/API/Query.hs

@@ -22,6 +22,7 @@ module Galley.API.Query
     getConversationRoles,
     getConversationIds,
     getConversations,
+    iterateConversations,
     getSelfH,
     internalGetMemberH,
     getConversationMetaH,
@@ -120,14 +121,19 @@ getConversationIds zusr start msize = do
 
 getConversations :: UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley (Public.ConversationList Public.Conversation)
 getConversations user mids mstart msize = do
+  ConversationList cs more <- getConversationsInternal user mids mstart msize
+  flip ConversationList more <$> mapM (Mapping.conversationView user) cs
+
+getConversationsInternal :: UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley (Public.ConversationList Data.Conversation)
+getConversationsInternal user mids mstart msize = do
   (more, ids) <- getIds mids
   let localConvIds = ids
   -- FUTUREWORK(federation, #1273): fetch remote conversations from other backend
   cs <-
     Data.conversations localConvIds
       >>= filterM removeDeleted
       >>= filterM (pure . isMember user . Data.convLocalMembers)
-  flip Public.ConversationList more <$> mapM (Mapping.conversationView user) cs
+  pure $ Public.ConversationList cs more
   where
     size = fromMaybe (toRange (Proxy @32)) msize
 
@@ -146,6 +152,21 @@ getConversations user mids mstart msize = do
       | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False
       | otherwise = pure True
 
+iterateConversations :: forall a. UserId -> Range 1 500 Int32 -> ([Data.Conversation] -> Galley a) -> Galley [a]
+iterateConversations uid pageSize handleConvs = go Nothing
+  where
+    go :: Maybe ConvId -> Galley [a]
+    go mbConv = do
+      convResult <- getConversationsInternal uid Nothing mbConv (Just pageSize)
+      resultHead <- handleConvs (convList convResult)
+      resultTail <- case convList convResult of
+        (conv : rest) ->
+          if convHasMore convResult
+            then go (Just (maximum (Data.convId <$> (conv : rest))))
+            else pure []
+        _ -> pure []
+      pure $ resultHead : resultTail
+
 getSelfH :: UserId ::: ConvId -> Galley Response
 getSelfH (zusr ::: cnv) = do
   json <$> getSelf zusr cnv

services/galley/src/Galley/API/Teams.hs

@@ -48,7 +48,6 @@ module Galley.API.Teams
     uncheckedGetTeamMemberH,
     uncheckedGetTeamMembersH,
     uncheckedDeleteTeamMember,
-    withBindingTeam,
     userIsTeamOwnerH,
     canUserJoinTeamH,
     internalDeleteBindingTeamWithOneMemberH,

services/galley/src/Galley/API/Update.hs

@@ -38,6 +38,7 @@ module Galley.API.Update
     updateSelfMemberH,
     updateOtherMemberH,
     removeMemberH,
+    removeMember,
 
     -- * Servant
     UpdateResponses,
@@ -72,19 +73,18 @@ import Data.Code
 import Data.Domain (Domain)
 import Data.Id
 import Data.Json.Util (toUTCTimeMillis)
-import Data.LegalHold (UserLegalHoldStatus (UserLegalHoldNoConsent), defUserLegalHoldStatus)
+import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus)
 import Data.List.Extra (nubOrd)
 import Data.List1
 import qualified Data.Map.Strict as Map
-import Data.Misc (FutureWork (..))
+import Data.Misc (FutureWork (FutureWork))
 import Data.Qualified
 import Data.Range
 import qualified Data.Set as Set
 import qualified Data.Text.Encoding as Text
 import Data.Time
 import Galley.API.Error
 import Galley.API.Mapping
-import qualified Galley.API.Teams as Teams
 import Galley.API.Util
 import Galley.App
 import Galley.Data (teamMember)
@@ -116,6 +116,7 @@ import qualified System.Logger.Class as Log
 import Wire.API.Conversation (InviteQualified (invQRoleName))
 import qualified Wire.API.Conversation as Public
 import qualified Wire.API.Conversation.Code as Public
+import Wire.API.Conversation.Role (roleNameWireAdmin)
 import qualified Wire.API.ErrorDescription as Public
 import qualified Wire.API.Event.Conversation as Public
 import Wire.API.Federation.Error (federationNotImplemented)
@@ -515,6 +516,8 @@ addMembers zusr zcon convId invite = do
   ensureConvRoleNotElevated self (invQRoleName invite)
   checkLocals conv (Data.convTeam conv) newLocals
   checkRemoteUsersExist newRemotes
+  checkLHPolicyConflictsLocal conv newLocals
+  checkLHPolicyConflictsRemote (FutureWork newRemotes)
   addToConversation mems rMems (zusr, memConvRoleName self) zcon ((,invQRoleName invite) <$> newLocals) ((,invQRoleName invite) <$> newRemotes) conv
   where
     userIsMember u = (^. userId . to (== u))
@@ -532,6 +535,40 @@ addMembers zusr zcon convId invite = do
       ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing)
       ensureConnectedOrSameTeam zusr newUsers
 
+    checkLHPolicyConflictsLocal :: Data.Conversation -> [UserId] -> Galley ()
+    checkLHPolicyConflictsLocal conv newUsers = do
+      let convUsers = Data.convLocalMembers conv
+
+      allNewUsersGaveConsent <- allLegalholdConsentGiven newUsers
+
+      whenM (anyLegalholdActivated (memId <$> convUsers)) $
+        unless allNewUsersGaveConsent $
+          throwM missingLegalholdConsent
+
+      whenM (anyLegalholdActivated newUsers) $ do
+        unless allNewUsersGaveConsent $
+          throwM missingLegalholdConsent
+
+        convUsersLHStatus <- do
+          uidsStatus <- getLHStatusForUsers (memId <$> convUsers)
+          pure $ zipWith (\mem (_, status) -> (mem, status)) convUsers uidsStatus
+
+        if any
+          ( \(mem, status) ->
+              memConvRoleName mem == roleNameWireAdmin
+                && consentGiven status == ConsentGiven
+          )
+          convUsersLHStatus
+          then do
+            for_ convUsersLHStatus $ \(mem, status) -> do
+              when (consentGiven status == ConsentNotGiven) $
+                void $ removeMember (memId mem) Nothing (Data.convId conv) (memId mem)
+          else do
+            throwM missingLegalholdConsent
+
+    checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley ()
+    checkLHPolicyConflictsRemote _remotes = pure ()
+
 updateSelfMemberH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.MemberUpdate -> Galley Response
 updateSelfMemberH (zusr ::: zcon ::: cid ::: req) = do
   update <- fromJsonBody req
@@ -565,9 +602,9 @@ updateOtherMember zusr zcon cid victim update = do
 
 removeMemberH :: UserId ::: ConnId ::: ConvId ::: UserId -> Galley Response
 removeMemberH (zusr ::: zcon ::: cid ::: victim) = do
-  handleUpdateResult <$> removeMember zusr zcon cid victim
+  handleUpdateResult <$> removeMember zusr (Just zcon) cid victim
 
-removeMember :: UserId -> ConnId -> ConvId -> UserId -> Galley UpdateResult
+removeMember :: UserId -> Maybe ConnId -> ConvId -> UserId -> Galley UpdateResult
 removeMember zusr zcon convId victim = do
   localDomain <- viewFederationDomain
   -- FUTUREWORK(federation, #1274): forward request to conversation's backend.
@@ -583,7 +620,7 @@ removeMember zusr zcon convId victim = do
       event <- Data.removeLocalMembers localDomain conv zusr (singleton victim)
       -- FUTUREWORK(federation, #1274): users can be on other backend, how to notify it?
       for_ (newPush ListComplete zusr (ConvEvent event) (recipient <$> users)) $ \p ->
-        push1 $ p & pushConn ?~ zcon
+        push1 $ p & pushConn .~ zcon
       void . forkIO $ void $ External.deliver (bots `zip` repeat event)
       pure $ Updated event
     else pure Unchanged
@@ -1039,7 +1076,7 @@ withValidOtrBroadcastRecipients ::
   UTCTime ->
   ([(LocalMember, ClientId, Text)] -> Galley ()) ->
   Galley OtrResult
-withValidOtrBroadcastRecipients usr clt rcps val now go = Teams.withBindingTeam usr $ \tid -> do
+withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ \tid -> do
   limit <- fromIntegral . fromRange <$> fanoutLimit
   -- If we are going to fan this out to more than limit, we want to fail early
   unless (Map.size (userClientMap (otrRecipientsMap rcps)) <= limit) $
@@ -1299,3 +1336,12 @@ guardLegalholdPolicyConflictsUid self otherClients = do
           -- We add this check here as an extra failsafe.
           Log.debug $ Log.msg ("guardLegalholdPolicyConflicts[3]: consent missing" :: Text)
           throwM missingLegalholdConsent
+
+-- Copied from 'Galley.API.Team' to break import cycles
+withBindingTeam :: UserId -> (TeamId -> Galley b) -> Galley b
+withBindingTeam zusr callback = do
+  tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound
+  binding <- Data.teamBinding tid >>= ifNothing teamNotFound
+  case binding of
+    Binding -> callback tid
+    NonBinding -> throwM nonBindingTeam