diff --git a/changelog.d/3-bug-fixes/wpb-6144-messaging-blocked-user b/changelog.d/3-bug-fixes/wpb-6144-messaging-blocked-user new file mode 100644 index 00000000000..44b986f57ed --- /dev/null +++ b/changelog.d/3-bug-fixes/wpb-6144-messaging-blocked-user @@ -0,0 +1 @@ +Do not deliver MLS one-to-one conversation messages to a user that blocked the sender diff --git a/integration/test/Test/MLS/One2One.hs b/integration/test/Test/MLS/One2One.hs index ccd8365477e..271f5ee9807 100644 --- a/integration/test/Test/MLS/One2One.hs +++ b/integration/test/Test/MLS/One2One.hs @@ -17,6 +17,7 @@ module Test.MLS.One2One where +import API.Brig import API.Galley import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as B8 @@ -54,6 +55,52 @@ testGetMLSOne2OneUnconnected otherDomain = do bindResponse (getMLSOne2OneConversation alice bob) $ \resp -> resp.status `shouldMatchInt` 403 +testMLSOne2OneBlocked :: HasCallStack => Domain -> App () +testMLSOne2OneBlocked otherDomain = do + [alice, bob] <- for [OwnDomain, otherDomain] $ flip randomUser def + void $ postConnection bob alice >>= getBody 201 + void $ putConnection alice bob "blocked" >>= getBody 200 + void $ getMLSOne2OneConversation alice bob >>= getJSON 403 + void $ getMLSOne2OneConversation bob alice >>= getJSON 403 + +-- | Alice and Bob are initially connected, but then Alice blocks Bob. +testMLSOne2OneBlockedAfterConnected :: HasCallStack => One2OneScenario -> App () +testMLSOne2OneBlockedAfterConnected scenario = do + alice <- randomUser OwnDomain def + let otherDomain = one2OneScenarioDomain scenario + convDomain = one2OneScenarioConvDomain scenario + bob <- createMLSOne2OnePartner otherDomain alice convDomain + conv <- getMLSOne2OneConversation alice bob >>= getJSON 200 + convId <- conv %. "qualified_id" + do + bobConv <- getMLSOne2OneConversation bob alice >>= getJSON 200 + convId `shouldMatch` (bobConv %. "qualified_id") + + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] + traverse_ uploadNewKeyPackage [bob1] + resetGroup alice1 conv + commit <- createAddCommit alice1 [bob] + withWebSocket bob1 $ \ws -> do + void $ sendAndConsumeCommitBundle commit + let isMessage n = nPayload n %. "type" `isEqual` "conversation.mls-welcome" + n <- awaitMatch isMessage ws + nPayload n %. "data" `shouldMatch` B8.unpack (Base64.encode (fold commit.welcome)) + + withWebSocket bob1 $ \ws -> do + -- Alice blocks Bob + void $ putConnection alice bob "blocked" >>= getBody 200 + -- There is also a proteus 1-to-1 conversation. Neither it nor the MLS + -- 1-to-1 conversation should get any events. + awaitAnyEvent 2 ws `shouldMatch` (Nothing :: Maybe Value) + -- Alice is not in the MLS 1-to-1 conversation given that she has blocked + -- Bob. + void $ getMLSOne2OneConversation alice bob >>= getJSON 403 + + mp <- createApplicationMessage bob1 "hello, world, again" + withWebSocket alice1 $ \ws -> do + void $ postMLSMessage mp.sender mp.message >>= getJSON 201 + awaitAnyEvent 2 ws `shouldMatch` (Nothing :: Maybe Value) + testGetMLSOne2OneSameTeam :: App () testGetMLSOne2OneSameTeam = do (alice, _, _) <- createTeam OwnDomain 1 diff --git a/integration/test/Testlib/Cannon.hs b/integration/test/Testlib/Cannon.hs index 2eb1be2be7f..8ab338df38a 100644 --- a/integration/test/Testlib/Cannon.hs +++ b/integration/test/Testlib/Cannon.hs @@ -28,6 +28,7 @@ module Testlib.Cannon awaitNMatchesResult, awaitNMatches, awaitMatch, + awaitAnyEvent, awaitAtLeastNMatchesResult, awaitAtLeastNMatches, awaitNToMMatchesResult, @@ -282,7 +283,7 @@ printAwaitResult = prettyAwaitResult >=> liftIO . putStrLn printAwaitAtLeastResult :: AwaitAtLeastResult -> App () printAwaitAtLeastResult = prettyAwaitAtLeastResult >=> liftIO . putStrLn -awaitAnyEvent :: MonadIO m => Int -> WebSocket -> m (Maybe Value) +awaitAnyEvent :: Int -> WebSocket -> App (Maybe Value) awaitAnyEvent tSecs = liftIO . timeout (tSecs * 1000 * 1000) . atomically . readTChan . wsChan -- | 'await' an expected number of notification events on the websocket that diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index d2f435e4a97..b6be1bade6a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -42,6 +42,7 @@ import Wire.API.Routes.Named import Wire.API.Routes.Public import Wire.API.Routes.Public.Galley.Conversation import Wire.API.Routes.Public.Galley.Feature +import Wire.API.Routes.QualifiedCapture import Wire.API.Team import Wire.API.Team.Feature import Wire.API.Team.Member @@ -256,7 +257,7 @@ type InternalAPIBase = :> "one2one" :> "upsert" :> ReqBody '[Servant.JSON] UpsertOne2OneConversationRequest - :> Post '[Servant.JSON] UpsertOne2OneConversationResponse + :> MultiVerb1 'POST '[Servant.JSON] (RespondEmpty 200 "Upsert One2One Policy") ) :<|> IFeatureAPI :<|> IFederationAPI @@ -492,7 +493,7 @@ type IConversationAPI = :> Put '[Servant.JSON] Conversation ) :<|> Named - "conversation-block" + "conversation-block-unqualified" ( CanThrow 'InvalidOperation :> CanThrow 'ConvNotFound :> ZUser @@ -501,6 +502,16 @@ type IConversationAPI = :> "block" :> Put '[Servant.JSON] () ) + :<|> Named + "conversation-block" + ( CanThrow 'InvalidOperation + :> CanThrow 'ConvNotFound + :> ZLocalUser + :> "conversations" + :> QualifiedCapture "cnv" ConvId + :> "block" + :> Put '[Servant.JSON] () + ) -- This endpoint can lead to the following events being sent: -- - MemberJoin event to you, if the conversation existed and had < 2 members before -- - MemberJoin event to other, if the conversation existed and only the other was member @@ -524,6 +535,16 @@ type IConversationAPI = :> "meta" :> Get '[Servant.JSON] ConversationMetadata ) + :<|> Named + "conversation-mls-one-to-one" + ( CanThrow 'NotConnected + :> CanThrow 'MLSNotEnabled + :> "conversations" + :> "mls-one2one" + :> ZLocalUser + :> QualifiedCapture "user" UserId + :> Get '[Servant.JSON] Conversation + ) swaggerDoc :: OpenApi swaggerDoc = diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley/ConversationsIntra.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley/ConversationsIntra.hs index b644906cd95..a25baa28b23 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley/ConversationsIntra.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley/ConversationsIntra.hs @@ -15,16 +15,9 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Routes.Internal.Galley.ConversationsIntra - ( DesiredMembership (..), - Actor (..), - UpsertOne2OneConversationRequest (..), - UpsertOne2OneConversationResponse (..), - ) -where +module Wire.API.Routes.Internal.Galley.ConversationsIntra where -import Data.Aeson qualified as A -import Data.Aeson.Types (FromJSON, ToJSON) +import Data.Aeson (FromJSON, ToJSON) import Data.Id (ConvId, UserId) import Data.OpenApi qualified as Swagger import Data.Qualified @@ -60,7 +53,7 @@ data UpsertOne2OneConversationRequest = UpsertOne2OneConversationRequest uooRemoteUser :: Remote UserId, uooActor :: Actor, uooActorDesiredMembership :: DesiredMembership, - uooConvId :: Maybe (Qualified ConvId) + uooConvId :: Qualified ConvId } deriving (Show, Generic) deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema UpsertOne2OneConversationRequest @@ -73,16 +66,4 @@ instance ToSchema UpsertOne2OneConversationRequest where <*> (tUntagged . uooRemoteUser) .= field "remote_user" (qTagUnsafe <$> schema) <*> uooActor .= field "actor" schema <*> uooActorDesiredMembership .= field "actor_desired_membership" schema - <*> uooConvId .= optField "conversation_id" (maybeWithDefault A.Null schema) - -newtype UpsertOne2OneConversationResponse = UpsertOne2OneConversationResponse - { uuorConvId :: Qualified ConvId - } - deriving (Show, Generic) - deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema UpsertOne2OneConversationResponse - -instance ToSchema UpsertOne2OneConversationResponse where - schema = - object "UpsertOne2OneConversationResponse" $ - UpsertOne2OneConversationResponse - <$> uuorConvId .= field "conversation_id" schema + <*> uooConvId .= field "conversation_id" schema diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 7debfb2ed6e..1144931940f 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -42,12 +42,14 @@ import Brig.Data.Connection qualified as Data import Brig.Data.Types (resultHasMore, resultList) import Brig.Data.User qualified as Data import Brig.Effects.FederationConfigStore -import Brig.Effects.GalleyProvider (GalleyProvider) +import Brig.Effects.GalleyProvider import Brig.Effects.GalleyProvider qualified as GalleyProvider import Brig.IO.Intra qualified as Intra +import Brig.Options import Brig.Types.Connection import Brig.Types.User.Event import Control.Error +import Control.Lens (view) import Control.Monad.Catch (throwM) import Data.Id as Id import Data.LegalHold qualified as LH @@ -55,6 +57,7 @@ import Data.Proxy (Proxy (Proxy)) import Data.Qualified import Data.Range import Data.UUID.V4 qualified as UUID +import Galley.Types.Conversations.One2One import Imports import Polysemy import Polysemy.TinyLog @@ -65,6 +68,7 @@ import Wire.API.Conversation hiding (Member) import Wire.API.Error import Wire.API.Error.Brig qualified as E import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) +import Wire.API.User import Wire.NotificationSubsystem ensureNotSameTeam :: Member GalleyProvider r => Local UserId -> Local UserId -> (ConnectionM r) () @@ -218,7 +222,8 @@ updateConnection :: ( Member FederationConfigStore r, Member NotificationSubsystem r, Member TinyLog r, - Member (Embed HttpClientIO) r + Member (Embed HttpClientIO) r, + Member GalleyProvider r ) => Local UserId -> Qualified UserId -> @@ -240,9 +245,10 @@ updateConnection self other newStatus conn = -- {#RefConnectionTeam} updateConnectionToLocalUser :: forall r. - ( Member NotificationSubsystem r, - Member TinyLog r, - Member (Embed HttpClientIO) r + ( Member (Embed HttpClientIO) r, + Member GalleyProvider r, + Member NotificationSubsystem r, + Member TinyLog r ) => -- | From Local UserId -> @@ -331,7 +337,12 @@ updateConnectionToLocalUser self other newStatus conn = do Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Blocking connection") - traverse_ (Intra.blockConv self conn) (ucConvId s2o) + traverse_ (liftSem . Intra.blockConv self) (ucConvId s2o) + mlsEnabled <- view (settings . enableMLS) + liftSem $ when (fromMaybe False mlsEnabled) $ do + let mlsConvId = one2OneConvId BaseProtocolMLSTag (tUntagged self) (tUntagged other) + mlsConvEstablished <- isMLSOne2OneEstablished self (tUntagged other) + when mlsConvEstablished $ Intra.blockConv self mlsConvId wrapClient $ Just <$> Data.updateConnection s2o BlockedWithHistory unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) @@ -363,7 +374,7 @@ updateConnectionToLocalUser self other newStatus conn = do logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Cancelling connection") lfrom <- qualifyLocal (ucFrom s2o) - lift $ traverse_ (Intra.blockConv lfrom conn) (ucConvId s2o) + lift $ traverse_ (liftSem . Intra.blockConv lfrom) (ucConvId s2o) o2s' <- lift . wrapClient $ Data.updateConnection o2s CancelledWithHistory let e2o = ConnectionUpdated o2s' (Just $ ucStatus o2s) Nothing lift $ liftSem $ Intra.onConnectionEvent (tUnqualified self) conn e2o @@ -434,7 +445,7 @@ updateConnectionInternal = \case o2s <- localConnection other self for_ [s2o, o2s] $ \(uconn :: UserConnection) -> lift $ do lfrom <- qualifyLocal (ucFrom uconn) - traverse_ (Intra.blockConv lfrom Nothing) (ucConvId uconn) + traverse_ (liftSem . Intra.blockConv lfrom) (ucConvId uconn) uconn' <- wrapClient $ Data.updateConnection uconn (mkRelationWithHistory (ucStatus uconn) MissingLegalholdConsent) let ev = ConnectionUpdated uconn' (Just $ ucStatus uconn) Nothing liftSem $ Intra.onConnectionEvent (tUnqualified self) Nothing ev diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 96c446d603a..5f41c261e5c 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -29,14 +29,18 @@ import Brig.App import Brig.Data.Connection qualified as Data import Brig.Data.User qualified as Data import Brig.Effects.FederationConfigStore -import Brig.Federation.Client +import Brig.Effects.GalleyProvider +import Brig.Federation.Client as Federation import Brig.IO.Intra qualified as Intra +import Brig.Options import Brig.Types.User.Event import Control.Comonad import Control.Error.Util ((??)) +import Control.Lens (view) import Control.Monad.Trans.Except import Data.Id as Id import Data.Qualified +import Galley.Types.Conversations.One2One (one2OneConvId) import Imports import Network.Wai.Utilities.Error import Polysemy @@ -45,7 +49,7 @@ import Wire.API.Federation.API.Brig ( NewConnectionResponse (..), RemoteConnectionAction (..), ) -import Wire.API.Routes.Internal.Galley.ConversationsIntra (Actor (..), DesiredMembership (..), UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (uuorConvId)) +import Wire.API.Routes.Internal.Galley.ConversationsIntra import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) import Wire.API.User import Wire.NotificationSubsystem @@ -104,39 +108,41 @@ transition (RCA RemoteRescind) Pending = Just Cancelled transition (RCA RemoteRescind) Accepted = Just Sent transition (RCA RemoteRescind) _ = Nothing --- When user A has made a request -> Only user A's membership in conv is affected -> User A wants to be in one2one conv with B, or User A doesn't want to be in one2one conv with B +-- When user A has made a request -> Only user A's membership in conv is +-- affected -> User A wants to be in one2one conv with B, or User A doesn't want +-- to be in one2one conv with B updateOne2OneConv :: Local UserId -> Maybe ConnId -> Remote UserId -> - Maybe (Qualified ConvId) -> - Relation -> + Qualified ConvId -> + DesiredMembership -> Actor -> - (AppT r) (Qualified ConvId) -updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do + (AppT r) () +updateOne2OneConv lUsr _mbConn remoteUser convId desiredMem actor = do let request = UpsertOne2OneConversationRequest { uooLocalUser = lUsr, uooRemoteUser = remoteUser, uooActor = actor, - uooActorDesiredMembership = desiredMembership actor rel, - uooConvId = mbConvId + uooActorDesiredMembership = desiredMem, + uooConvId = convId } - uuorConvId <$> wrapHttp (Intra.upsertOne2OneConversation request) - where - desiredMembership :: Actor -> Relation -> DesiredMembership - desiredMembership a r = - let isIncluded = - a - `elem` case r of - Accepted -> [LocalActor, RemoteActor] - Blocked -> [] - Pending -> [RemoteActor] - Ignored -> [RemoteActor] - Sent -> [LocalActor] - Cancelled -> [] - MissingLegalholdConsent -> [] - in if isIncluded then Included else Excluded + void $ wrapHttp (Intra.upsertOne2OneConversation request) + +desiredMembership :: Actor -> Relation -> DesiredMembership +desiredMembership a r = + let isIncluded = + a + `elem` case r of + Accepted -> [LocalActor, RemoteActor] + Blocked -> [] + Pending -> [RemoteActor] + Ignored -> [RemoteActor] + Sent -> [LocalActor] + Cancelled -> [] + MissingLegalholdConsent -> [] + in if isIncluded then Included else Excluded -- | Perform a state transition on a connection, handle conversation updates and -- push events. @@ -146,7 +152,7 @@ updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do -- -- Returns the connection, and whether it was updated or not. transitionTo :: - (Member NotificationSubsystem r) => + (Member NotificationSubsystem r, Member GalleyProvider r) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -159,8 +165,13 @@ transitionTo self _ _ Nothing Nothing _ = -- connection. This shouldn't be possible. throwE (InvalidTransition (tUnqualified self)) transitionTo self mzcon other Nothing (Just rel) actor = lift $ do - -- update 1-1 connection - qcnv <- updateOne2OneConv self mzcon other Nothing rel actor + -- Create 1-1 proteus conversation. + -- + -- We do nothing here for MLS as haveing no pre-existing connection implies + -- there was no conversation. Creating an MLS converstaion is special due to + -- key packages, etc. so the clients have to make another call for this. + let proteusConv = one2OneConvId BaseProtocolProteusTag (tUntagged self) (tUntagged other) + updateOne2OneConv self mzcon other proteusConv (desiredMembership actor rel) actor -- create connection connection <- @@ -169,21 +180,32 @@ transitionTo self mzcon other Nothing (Just rel) actor = lift $ do self (tUntagged other) (relationWithHistory rel) - qcnv + proteusConv -- send event pushEvent self mzcon connection pure (Created connection, True) transitionTo _self _zcon _other (Just connection) Nothing _actor = pure (Existed connection, False) -transitionTo self mzcon other (Just connection) (Just rel) actor = lift $ do +transitionTo self mzcon other (Just connection) (Just rel) actor = do -- update 1-1 conversation - void $ updateOne2OneConv self Nothing other (ucConvId connection) rel actor + let proteusConvId = + fromMaybe + (one2OneConvId BaseProtocolProteusTag (tUntagged self) (tUntagged other)) + $ ucConvId connection + lift $ updateOne2OneConv self Nothing other proteusConvId (desiredMembership actor rel) actor + mlsEnabled <- view (settings . enableMLS) + when (fromMaybe False mlsEnabled) $ do + let mlsConvId = one2OneConvId BaseProtocolMLSTag (tUntagged self) (tUntagged other) + mlsConvEstablished <- lift . liftSem $ isMLSOne2OneEstablished self (tUntagged other) + let desiredMem = desiredMembership actor rel + lift . when (mlsConvEstablished && desiredMem == Excluded) $ + updateOne2OneConv self Nothing other mlsConvId desiredMem actor -- update connection - connection' <- wrapClient $ Data.updateConnection connection (relationWithHistory rel) + connection' <- lift $ wrapClient $ Data.updateConnection connection (relationWithHistory rel) -- send event - pushEvent self mzcon connection' + lift $ pushEvent self mzcon connection' pure (Existed connection', True) -- | Send an event to the local user when the state of a connection changes. @@ -198,7 +220,7 @@ pushEvent self mzcon connection = do liftSem $ Intra.onConnectionEvent (tUnqualified self) mzcon event performLocalAction :: - (Member NotificationSubsystem r) => + (Member NotificationSubsystem r, Member GalleyProvider r) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -254,7 +276,7 @@ performLocalAction self mzcon other mconnection action = do -- B connects & A reacts: Accepted Accepted -- @ performRemoteAction :: - (Member NotificationSubsystem r) => + (Member NotificationSubsystem r, Member GalleyProvider r) => Local UserId -> Remote UserId -> Maybe UserConnection -> @@ -273,7 +295,8 @@ performRemoteAction self other mconnection action = do createConnectionToRemoteUser :: ( Member FederationConfigStore r, - Member NotificationSubsystem r + Member NotificationSubsystem r, + Member GalleyProvider r ) => Local UserId -> ConnId -> @@ -287,7 +310,8 @@ createConnectionToRemoteUser self zcon other = do updateConnectionToRemoteUser :: ( Member NotificationSubsystem r, - Member FederationConfigStore r + Member FederationConfigStore r, + Member GalleyProvider r ) => Local UserId -> Remote UserId -> diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 7515577d073..cc44dd3b250 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -111,7 +111,8 @@ getFederationStatus _ request = do sendConnectionAction :: ( Member FederationConfigStore r, - Member NotificationSubsystem r + Member NotificationSubsystem r, + Member GalleyProvider r ) => Domain -> NewConnectionRequest -> diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index a2ab94c1c61..0630ee43602 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -1112,7 +1112,8 @@ createConnection self conn target = do API.createConnection lself conn target !>> connError updateLocalConnection :: - ( Member NotificationSubsystem r, + ( Member GalleyProvider r, + Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -1131,7 +1132,8 @@ updateConnection :: ( Member FederationConfigStore r, Member NotificationSubsystem r, Member TinyLog r, - Member (Embed HttpClientIO) r + Member (Embed HttpClientIO) r, + Member GalleyProvider r ) => UserId -> ConnId -> diff --git a/services/brig/src/Brig/Effects/GalleyProvider.hs b/services/brig/src/Brig/Effects/GalleyProvider.hs index b73fd919ed2..c45d58a81b2 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider.hs @@ -106,5 +106,9 @@ data GalleyProvider m a where GetExposeInvitationURLsToTeamAdmin :: TeamId -> GalleyProvider m ShowOrHideInvitationUrl + IsMLSOne2OneEstablished :: + Local UserId -> + Qualified UserId -> + GalleyProvider m Bool makeSem ''GalleyProvider diff --git a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs index 481b4d28c09..84d6ba98cf9 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs @@ -35,6 +35,8 @@ import Data.Qualified import Data.Range import Galley.Types.Teams qualified as Team import Imports +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Types qualified as HTTP import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error qualified as Wai @@ -46,6 +48,7 @@ import Servant.API (toHeader) import System.Logger (field, msg, val) import Util.Options import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation.Protocol import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Routes.Version import Wire.API.Team @@ -89,6 +92,7 @@ interpretGalleyProviderToRpc disabledVersions galleyEndpoint = GetAllFeatureConfigsForUser m_id' -> getAllFeatureConfigsForUser m_id' GetVerificationCodeEnabled id' -> getVerificationCodeEnabled id' GetExposeInvitationURLsToTeamAdmin id' -> getTeamExposeInvitationURLsToTeamAdmin id' + IsMLSOne2OneEstablished lusr qother -> checkMLSOne2OneEstablished lusr qother galleyRequest :: (Member Rpc r, Member (Input Endpoint) r) => (Request -> Request) -> Sem r (Response (Maybe LByteString)) galleyRequest req = do @@ -524,3 +528,39 @@ getTeamExposeInvitationURLsToTeamAdmin tid = do method GET . paths ["i", "teams", toByteString' tid, "features", featureNameBS @ExposeInvitationURLsToTeamAdminConfig] . expect2xx + +checkMLSOne2OneEstablished :: + ( Member (Error ParseException) r, + Member (Input Endpoint) r, + Member Rpc r, + Member TinyLog r + ) => + Local UserId -> + Qualified UserId -> + Sem r Bool +checkMLSOne2OneEstablished self (Qualified other otherDomain) = do + debug $ remote "galley" . msg (val "Get the MLS one-to-one conversation") + response <- galleyRequest req + case HTTP.statusCode (HTTP.responseStatus response) of + 403 -> pure False + 400 -> pure False + _ {- 200 is assumed -} -> do + conv <- decodeBodyOrThrow @Conversation "galley" response + let mEpoch = case cnvProtocol conv of + ProtocolProteus -> Nothing + ProtocolMLS meta -> Just . cnvmlsEpoch $ meta + ProtocolMixed meta -> Just . cnvmlsEpoch $ meta + pure $ case mEpoch of + Nothing -> False + Just (Epoch e) -> e > 0 + where + req = + method GET + . paths + [ "i", + "conversations", + "mls-one2one", + toByteString' otherDomain, + toByteString' other + ] + . zUser (tUnqualified self) diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index f81fd20f7a7..23d7d3bbb0a 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -93,7 +93,7 @@ import Wire.API.Event.Conversation (Connect (Connect)) import Wire.API.Federation.API.Brig import Wire.API.Federation.Error import Wire.API.Properties -import Wire.API.Routes.Internal.Galley.ConversationsIntra (UpsertOne2OneConversationRequest, UpsertOne2OneConversationResponse) +import Wire.API.Routes.Internal.Galley.ConversationsIntra import Wire.API.Routes.Internal.Galley.TeamsIntra (GuardLegalholdPolicyConflicts (GuardLegalholdPolicyConflicts)) import Wire.API.Team.LegalHold (LegalholdProtectee) import Wire.API.Team.Member qualified as Team @@ -643,42 +643,32 @@ acceptConnectConv from conn = (liftSem . acceptLocalConnectConv from conn . tUnqualified) (const (throwM federationNotImplemented)) --- | Calls 'Galley.API.blockConvH'. -blockLocalConv :: +blockConv :: ( Member (Embed HttpClientIO) r, Member TinyLog r ) => Local UserId -> - Maybe ConnId -> - ConvId -> + Qualified ConvId -> Sem r () -blockLocalConv lusr conn cnv = do +blockConv lusr qcnv = do Log.debug $ remote "galley" - . field "conv" (toByteString cnv) + . field "conv" (toByteString . qUnqualified $ qcnv) + . field "domain" (toByteString . qDomain $ qcnv) . msg (val "Blocking conversation") - embed $ void $ galleyRequest PUT req + embed . void $ galleyRequest PUT req where req = - paths ["/i/conversations", toByteString' cnv, "block"] + paths + [ "i", + "conversations", + toByteString' (qDomain qcnv), + toByteString' (qUnqualified qcnv), + "block" + ] . zUser (tUnqualified lusr) - . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx -blockConv :: - ( Member (Embed HttpClientIO) r, - Member TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - Qualified ConvId -> - AppT r () -blockConv lusr conn = - foldQualified - lusr - (liftSem . blockLocalConv lusr conn . tUnqualified) - (const (throwM federationNotImplemented)) - -- | Calls 'Galley.API.unblockConvH'. unblockLocalConv :: ( Member (Embed HttpClientIO) r, @@ -723,11 +713,11 @@ upsertOne2OneConversation :: HasRequestId m ) => UpsertOne2OneConversationRequest -> - m UpsertOne2OneConversationResponse + m () upsertOne2OneConversation urequest = do response <- galleyRequest POST req case Bilge.statusCode response of - 200 -> decodeBody "galley" response + 200 -> pure () _ -> throwM internalServerError where req = diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index edd2d4a14d0..2e4d7435980 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -126,9 +126,11 @@ conversationAPI :: API IConversationAPI GalleyEffects conversationAPI = mkNamedAPI @"conversation-get-member" Query.internalGetMember <@> mkNamedAPI @"conversation-accept-v2" Update.acceptConv + <@> mkNamedAPI @"conversation-block-unqualified" Update.blockConvUnqualified <@> mkNamedAPI @"conversation-block" Update.blockConv <@> mkNamedAPI @"conversation-unblock" Update.unblockConv <@> mkNamedAPI @"conversation-meta" Query.getConversationMeta + <@> mkNamedAPI @"conversation-mls-one-to-one" Query.getMLSOne2OneConversation legalholdWhitelistedTeamsAPI :: API ILegalholdWhitelistedTeamsAPI GalleyEffects legalholdWhitelistedTeamsAPI = mkAPI $ \tid -> hoistAPIHandler Imports.id (base tid) diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs index 039ca96f012..031a4dd81d3 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/services/galley/src/Galley/API/One2One.hs @@ -35,6 +35,7 @@ import Galley.Types.UserList import Imports import Polysemy import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation.Protocol import Wire.API.Routes.Internal.Galley.ConversationsIntra import Wire.API.User @@ -58,17 +59,8 @@ iUpsertOne2OneConversation :: Member MemberStore r ) => UpsertOne2OneConversationRequest -> - Sem r UpsertOne2OneConversationResponse + Sem r () iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do - let convId = - fromMaybe - ( one2OneConvId - BaseProtocolProteusTag - (tUntagged uooLocalUser) - (tUntagged uooRemoteUser) - ) - uooConvId - let dolocal :: Local ConvId -> Sem r () dolocal lconvId = do mbConv <- getConversation (tUnqualified lconvId) @@ -90,10 +82,15 @@ iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do void $ createMember lconvId uooLocalUser unless (null (convRemoteMembers conv)) $ acceptConnectConversation (tUnqualified lconvId) - (LocalActor, Excluded) -> + (LocalActor, Excluded) -> do deleteMembers (tUnqualified lconvId) (UserList [tUnqualified uooLocalUser] []) + let mGroupId = case convProtocol conv of + ProtocolProteus -> Nothing + ProtocolMLS meta -> Just . cnvmlsGroupId $ meta + ProtocolMixed meta -> Just . cnvmlsGroupId $ meta + for_ mGroupId $ flip removeAllMLSClientsOfUser (tUntagged uooLocalUser) (RemoteActor, Included) -> do void $ createMembers (tUnqualified lconvId) (UserList [] [uooRemoteUser]) unless (null (convLocalMembers conv)) $ @@ -111,5 +108,4 @@ iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do deleteMembersInRemoteConversation rconvId [tUnqualified uooLocalUser] (RemoteActor, _) -> pure () - foldQualified uooLocalUser dolocal doremote convId - pure (UpsertOne2OneConversationResponse convId) + foldQualified uooLocalUser dolocal doremote uooConvId diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index c6195576758..ddc89b92164 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -21,6 +21,7 @@ module Galley.API.Update ( -- * Managing Conversations acceptConv, blockConv, + blockConvUnqualified, unblockConv, checkReusableCode, joinConversationByReusableCode, @@ -164,6 +165,22 @@ acceptConv lusr conn cnv = do conversationView lusr conv' blockConv :: + ( Member ConversationStore r, + Member (ErrorS 'ConvNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member MemberStore r + ) => + Local UserId -> + Qualified ConvId -> + Sem r () +blockConv lusr qcnv = + foldQualified + lusr + (\lcnv -> blockConvUnqualified (tUnqualified lusr) (tUnqualified lcnv)) + (\rcnv -> blockRemoteConv lusr rcnv) + qcnv + +blockConvUnqualified :: ( Member ConversationStore r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, @@ -172,7 +189,7 @@ blockConv :: UserId -> ConvId -> Sem r () -blockConv zusr cnv = do +blockConvUnqualified zusr cnv = do conv <- E.getConversation cnv >>= noteS @'ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ throwS @'InvalidOperation @@ -180,6 +197,17 @@ blockConv zusr cnv = do when (zusr `isMember` mems) $ E.deleteMembers cnv (UserList [zusr] []) +blockRemoteConv :: + ( Member (ErrorS 'ConvNotFound) r, + Member MemberStore r + ) => + Local UserId -> + Remote ConvId -> + Sem r () +blockRemoteConv (tUnqualified -> usr) rcnv = do + unlessM (E.checkLocalMemberRemoteConv usr rcnv) $ throwS @'ConvNotFound + E.deleteMembersInRemoteConversation rcnv [usr] + unblockConv :: ( Member ConversationStore r, Member (Error InternalError) r, diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index abd3a0139e6..f4a043cd11e 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -384,6 +384,11 @@ removeMLSClients groupId (Qualified usr domain) cs = retry x5 . batch $ do for_ cs $ \c -> addPrepQuery Cql.removeMLSClient (groupId, domain, usr, c) +removeAllMLSClientsOfUser :: GroupId -> Qualified UserId -> Client () +removeAllMLSClientsOfUser groupId (Qualified usr domain) = + retry x5 $ + write Cql.removeAllMLSClientsOfUser (params LocalQuorum (groupId, domain, usr)) + removeAllMLSClients :: GroupId -> Client () removeAllMLSClients groupId = do retry x5 $ write Cql.removeAllMLSClients (params LocalQuorum (Identity groupId)) @@ -416,6 +421,7 @@ interpretMemberStoreToCassandra = interpret $ \case AddMLSClients lcnv quid cs -> embedClient $ addMLSClients lcnv quid cs PlanClientRemoval lcnv cids -> embedClient $ planMLSClientRemoval lcnv cids RemoveMLSClients lcnv quid cs -> embedClient $ removeMLSClients lcnv quid cs + RemoveAllMLSClientsOfUser lcnv quid -> embedClient $ removeAllMLSClientsOfUser lcnv quid RemoveAllMLSClients gid -> embedClient $ removeAllMLSClients gid LookupMLSClients lcnv -> embedClient $ lookupMLSClients lcnv LookupMLSClientLeafIndices lcnv -> embedClient $ lookupMLSClientLeafIndices lcnv diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index 560d8d9a19f..df52a52571b 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -493,6 +493,9 @@ planMLSClientRemoval = "update mls_group_member_client set removal_pending = tru removeMLSClient :: PrepQuery W (GroupId, Domain, UserId, ClientId) () removeMLSClient = "delete from mls_group_member_client where group_id = ? and user_domain = ? and user = ? and client = ?" +removeAllMLSClientsOfUser :: PrepQuery W (GroupId, Domain, UserId) () +removeAllMLSClientsOfUser = "delete from mls_group_member_client where group_id = ? and user_domain = ? and user = ?" + removeAllMLSClients :: PrepQuery W (Identity GroupId) () removeAllMLSClients = "DELETE FROM mls_group_member_client WHERE group_id = ?" diff --git a/services/galley/src/Galley/Effects/MemberStore.hs b/services/galley/src/Galley/Effects/MemberStore.hs index 0513cc6570e..56cd4fe9740 100644 --- a/services/galley/src/Galley/Effects/MemberStore.hs +++ b/services/galley/src/Galley/Effects/MemberStore.hs @@ -44,6 +44,7 @@ module Galley.Effects.MemberStore addMLSClients, planClientRemoval, removeMLSClients, + removeAllMLSClientsOfUser, removeAllMLSClients, lookupMLSClients, lookupMLSClientLeafIndices, @@ -88,6 +89,7 @@ data MemberStore m a where AddMLSClients :: GroupId -> Qualified UserId -> Set (ClientId, LeafIndex) -> MemberStore m () PlanClientRemoval :: Foldable f => GroupId -> f ClientIdentity -> MemberStore m () RemoveMLSClients :: GroupId -> Qualified UserId -> Set ClientId -> MemberStore m () + RemoveAllMLSClientsOfUser :: GroupId -> Qualified UserId -> MemberStore m () RemoveAllMLSClients :: GroupId -> MemberStore m () LookupMLSClients :: GroupId -> MemberStore m ClientMap LookupMLSClientLeafIndices :: GroupId -> MemberStore m (ClientMap, IndexMap) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 21c0c844a08..2ac9f185e71 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -3694,16 +3694,11 @@ testAllOne2OneConversationRequests = do testOne2OneConversationRequest :: Bool -> Actor -> DesiredMembership -> TestM () testOne2OneConversationRequest shouldBeLocal actor desired = do alice <- qTagUnsafe <$> randomQualifiedUser - (bob, expectedConvId) <- generateRemoteAndConvId shouldBeLocal alice + (bob, convId) <- generateRemoteAndConvId shouldBeLocal alice - convId <- do - let req = UpsertOne2OneConversationRequest alice bob actor desired Nothing - res <- - iUpsertOne2OneConversation req - responseJsonError res - - liftIO $ convId @?= expectedConvId + do + let req = UpsertOne2OneConversationRequest alice bob actor desired convId + iUpsertOne2OneConversation req !!! statusCode === const 200 if shouldBeLocal then diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 22236c3c810..070010d0867 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -120,12 +120,9 @@ getConversationsAllFound = do uooRemoteUser = rAlice, uooActor = LocalActor, uooActorDesiredMembership = Included, - uooConvId = Just cnv1Id + uooConvId = cnv1Id } - UpsertOne2OneConversationResponse cnv1IdReturned <- - responseJsonError - =<< iUpsertOne2OneConversation createO2O - liftIO $ assertEqual "Mismatch in the generated conversation ID" cnv1IdReturned cnv1Id + iUpsertOne2OneConversation createO2O !!! const 200 === statusCode do convs <- diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index e9ca4a544c8..b6227da8967 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -2895,23 +2895,18 @@ iUpsertOne2OneConversation req = do createOne2OneConvWithRemote :: HasCallStack => Local UserId -> Remote UserId -> TestM () createOne2OneConvWithRemote localUser remoteUser = do - let mkRequest actor mConvId = + let convId = one2OneConvId BaseProtocolProteusTag (tUntagged localUser) (tUntagged remoteUser) + mkRequest actor = UpsertOne2OneConversationRequest { uooLocalUser = localUser, uooRemoteUser = remoteUser, uooActor = actor, uooActorDesiredMembership = Included, - uooConvId = mConvId + uooConvId = convId } - ooConvId <- - fmap uuorConvId - . responseJsonError - =<< iUpsertOne2OneConversation (mkRequest LocalActor Nothing) - Local UserId -> TestM (Remote UserId, Qualified ConvId) generateRemoteAndConvId = generateRemoteAndConvIdWithDomain (Domain "far-away.example.com")