[WPB-6144] Prevent MLS one-to-one messaging for a blocking user (q1-2024) - no dependencies on the notification subsystem

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 (#3889, #3906)

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

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

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 =

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 <https://www.gnu.org/licenses/>.
 
-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

services/brig/src/Brig/API/Connection.hs

@@ -42,28 +42,33 @@ 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
 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 (Member)
+import Polysemy
+import Polysemy.TinyLog (TinyLog)
 import System.Logger.Class qualified as Log
 import System.Logger.Message
 import Wire.API.Connection hiding (relationWithHistory)
 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
 
 ensureNotSameTeam :: Member GalleyProvider r => Local UserId -> Local UserId -> (ConnectionM r) ()
 ensureNotSameTeam self target = do
@@ -205,7 +210,11 @@ checkLegalholdPolicyConflict uid1 uid2 = do
   oneway status2 status1
 
 updateConnection ::
-  Member FederationConfigStore r =>
+  ( Member FederationConfigStore r,
+    Member TinyLog r,
+    Member (Embed HttpClientIO) r,
+    Member GalleyProvider r
+  ) =>
   Local UserId ->
   Qualified UserId ->
   Relation ->
@@ -225,6 +234,11 @@ updateConnection self other newStatus conn =
 -- because a connection between two team members can not exist in the first place.
 -- {#RefConnectionTeam}
 updateConnectionToLocalUser ::
+  forall r.
+  ( Member (Embed HttpClientIO) r,
+    Member GalleyProvider r,
+    Member TinyLog r
+  ) =>
   -- | From
   Local UserId ->
   -- | To
@@ -312,7 +326,12 @@ updateConnectionToLocalUser self other newStatus conn = do
       Log.info $
         logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o))
           . msg (val "Blocking connection")
-      traverse_ (wrapHttp . 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)
@@ -344,7 +363,7 @@ updateConnectionToLocalUser self other newStatus conn = do
         logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o))
           . msg (val "Cancelling connection")
       lfrom <- qualifyLocal (ucFrom s2o)
-      lift $ traverse_ (wrapHttp . 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 $ Intra.onConnectionEvent (tUnqualified self) conn e2o
@@ -383,6 +402,9 @@ mkRelationWithHistory oldRel = \case
 
 updateConnectionInternal ::
   forall r.
+  ( Member (Embed HttpClientIO) r,
+    Member TinyLog r
+  ) =>
   UpdateConnectionsInternal ->
   ExceptT ConnectionError (AppT r) ()
 updateConnectionInternal = \case
@@ -411,7 +433,7 @@ updateConnectionInternal = \case
         o2s <- localConnection other self
         for_ [s2o, o2s] $ \(uconn :: UserConnection) -> lift $ do
           lfrom <- qualifyLocal (ucFrom uconn)
-          traverse_ (wrapHttp . 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
           Intra.onConnectionEvent (tUnqualified self) Nothing ev