[WPB-6783] Support unblocking an MLS 1-to-1 conversation (the q1-2024 port)

changelog.d/2-features/WPB-6783

@@ -0,0 +1 @@
+Support unblocking a user in an MLS 1-to-1 conversation

integration/test/Test/MLS/One2One.hs

@@ -21,6 +21,7 @@ import API.Brig
 import API.Galley
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Char8 as B8
+import qualified Data.Set as Set
 import MLS.Util
 import Notifications
 import SetupHelpers
@@ -67,7 +68,7 @@ testMLSOne2OneBlocked otherDomain = do
 testMLSOne2OneBlockedAfterConnected :: HasCallStack => One2OneScenario -> App ()
 testMLSOne2OneBlockedAfterConnected scenario = do
   alice <- randomUser OwnDomain def
-  let otherDomain = one2OneScenarioDomain scenario
+  let otherDomain = one2OneScenarioUserDomain scenario
       convDomain = one2OneScenarioConvDomain scenario
   bob <- createMLSOne2OnePartner otherDomain alice convDomain
   conv <- getMLSOne2OneConversation alice bob >>= getJSON 200
@@ -101,6 +102,61 @@ testMLSOne2OneBlockedAfterConnected scenario = do
     void $ postMLSMessage mp.sender mp.message >>= getJSON 201
     awaitAnyEvent 2 ws `shouldMatch` (Nothing :: Maybe Value)
 
+-- | Alice and Bob are initially connected, then Alice blocks Bob, and finally
+-- Alice unblocks Bob.
+testMLSOne2OneUnblocked :: HasCallStack => One2OneScenario -> App ()
+testMLSOne2OneUnblocked scenario = do
+  alice <- randomUser OwnDomain def
+  let otherDomain = one2OneScenarioUserDomain scenario
+      convDomain = one2OneScenarioConvDomain scenario
+  bob <- createMLSOne2OnePartner otherDomain alice convDomain
+  conv <- getMLSOne2OneConversation alice bob >>= getJSON 200
+  do
+    convId <- conv %. "qualified_id"
+    bobConv <- getMLSOne2OneConversation bob alice >>= getJSON 200
+    convId `shouldMatch` (bobConv %. "qualified_id")
+
+  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]
+  traverse_ uploadNewKeyPackage [bob1]
+  resetGroup alice1 conv
+  withWebSocket bob1 $ \ws -> do
+    commit <- createAddCommit alice1 [bob]
+    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))
+
+  -- Alice blocks Bob
+  void $ putConnection alice bob "blocked" >>= getBody 200
+  void $ getMLSOne2OneConversation alice bob >>= getJSON 403
+
+  -- Reset the group membership in the test setup as only 'bob1' is left in
+  -- reality, even though the test state believes 'alice1' is still part of the
+  -- conversation.
+  modifyMLSState $ \s -> s {members = Set.singleton bob1}
+
+  -- Bob creates a new client and adds it to the one-to-one conversation just so
+  -- that the epoch advances.
+  bob2 <- createMLSClient def bob
+  traverse_ uploadNewKeyPackage [bob2]
+  void $ createAddCommit bob1 [bob] >>= sendAndConsumeCommitBundle
+
+  -- Alice finally unblocks Bob
+  void $ putConnection alice bob "accepted" >>= getBody 200
+  void $ getMLSOne2OneConversation alice bob >>= getJSON 200
+
+  -- Alice rejoins via an external commit
+  void $ createExternalCommit alice1 Nothing >>= sendAndConsumeCommitBundle
+
+  -- Check that an application message can get to Bob
+  withWebSockets [bob1, bob2] $ \wss -> do
+    mp <- createApplicationMessage alice1 "hello, I've always been here"
+    void $ sendAndConsumeMessage mp
+    let isMessage n = nPayload n %. "type" `isEqual` "conversation.mls-message-add"
+    forM_ wss $ \ws -> do
+      n <- awaitMatch isMessage ws
+      nPayload n %. "data" `shouldMatch` B8.unpack (Base64.encode mp.message)
+
 testGetMLSOne2OneSameTeam :: App ()
 testGetMLSOne2OneSameTeam = do
   (alice, _, _) <- createTeam OwnDomain 1
@@ -121,9 +177,9 @@ instance HasTests x => HasTests (One2OneScenario -> x) where
       <> mkTests m (n <> "[domain=other;conv=own]") s f (x One2OneScenarioLocalConv)
       <> mkTests m (n <> "[domain=other;conv=other]") s f (x One2OneScenarioRemoteConv)
 
-one2OneScenarioDomain :: One2OneScenario -> Domain
-one2OneScenarioDomain One2OneScenarioLocal = OwnDomain
-one2OneScenarioDomain _ = OtherDomain
+one2OneScenarioUserDomain :: One2OneScenario -> Domain
+one2OneScenarioUserDomain One2OneScenarioLocal = OwnDomain
+one2OneScenarioUserDomain _ = OtherDomain
 
 one2OneScenarioConvDomain :: One2OneScenario -> Domain
 one2OneScenarioConvDomain One2OneScenarioLocal = OwnDomain
@@ -133,7 +189,7 @@ one2OneScenarioConvDomain One2OneScenarioRemoteConv = OtherDomain
 testMLSOne2One :: HasCallStack => One2OneScenario -> App ()
 testMLSOne2One scenario = do
   alice <- randomUser OwnDomain def
-  let otherDomain = one2OneScenarioDomain scenario
+  let otherDomain = one2OneScenarioUserDomain scenario
       convDomain = one2OneScenarioConvDomain scenario
   bob <- createMLSOne2OnePartner otherDomain alice convDomain
   [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]

libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs

@@ -517,7 +517,7 @@ type IConversationAPI =
     -- - MemberJoin event to other, if the conversation existed and only the other was member
     --   before
     :<|> Named
-           "conversation-unblock"
+           "conversation-unblock-unqualified"
            ( CanThrow 'InvalidOperation
                :> CanThrow 'ConvNotFound
                :> ZLocalUser
@@ -527,6 +527,21 @@ type IConversationAPI =
                :> "unblock"
                :> Put '[Servant.JSON] Conversation
            )
+    -- 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
+    --   before
+    :<|> Named
+           "conversation-unblock"
+           ( CanThrow 'InvalidOperation
+               :> CanThrow 'ConvNotFound
+               :> ZLocalUser
+               :> ZOptConn
+               :> "conversations"
+               :> QualifiedCapture "cnv" ConvId
+               :> "unblock"
+               :> Put '[Servant.JSON] ()
+           )
     :<|> Named
            "conversation-meta"
            ( CanThrow 'ConvNotFound
@@ -545,6 +560,17 @@ type IConversationAPI =
                :> QualifiedCapture "user" UserId
                :> Get '[Servant.JSON] Conversation
            )
+    :<|> Named
+           "conversation-mls-one-to-one-established"
+           ( CanThrow 'NotConnected
+               :> CanThrow 'MLSNotEnabled
+               :> ZLocalUser
+               :> "conversations"
+               :> "mls-one2one"
+               :> QualifiedCapture "user" UserId
+               :> "established"
+               :> Get '[Servant.JSON] Bool
+           )
 
 swaggerDoc :: OpenApi
 swaggerDoc =

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

@@ -330,8 +330,8 @@ updateConnectionToLocalUser self other newStatus conn = do
       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
+        isEstablished <- isMLSOne2OneEstablished self (tUntagged other)
+        when (isEstablished == Established) $ Intra.blockConv self mlsConvId
       wrapClient $ Just <$> Data.updateConnection s2o BlockedWithHistory
 
     unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError (AppT r) (Maybe UserConnection)
@@ -342,7 +342,13 @@ updateConnectionToLocalUser self other newStatus conn = do
       lift . Log.info $
         logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o))
           . msg (val "Unblocking connection")
-      cnv <- lift $ traverse (wrapHttp . Intra.unblockConv self conn) (ucConvId s2o)
+      cnv <- lift . liftSem $ traverse (unblockConversation self conn) (ucConvId s2o)
+      mlsEnabled <- view (settings . enableMLS)
+      lift . liftSem $ when (fromMaybe False mlsEnabled) $ do
+        let mlsConvId = one2OneConvId BaseProtocolMLSTag (tUntagged self) (tUntagged other)
+        isEstablished <- isMLSOne2OneEstablished self (tUntagged other)
+        when (isEstablished == NotAMember || isEstablished == Established) . void $
+          unblockConversation self conn mlsConvId
       when (ucStatus o2s == Sent && new == Accepted) . lift $ do
         o2s' <-
           wrapClient $
@@ -402,8 +408,9 @@ mkRelationWithHistory oldRel = \case
 
 updateConnectionInternal ::
   forall r.
-  ( Member (Embed HttpClientIO) r,
-    Member TinyLog r
+  ( Member GalleyProvider r,
+    Member TinyLog r,
+    Member (Embed HttpClientIO) r
   ) =>
   UpdateConnectionsInternal ->
   ExceptT ConnectionError (AppT r) ()
@@ -468,7 +475,7 @@ updateConnectionInternal = \case
         unblockDirected :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) ()
         unblockDirected uconn uconnRev = do
           lfrom <- qualifyLocal (ucFrom uconnRev)
-          void . lift . for (ucConvId uconn) $ wrapHttp . Intra.unblockConv lfrom Nothing
+          void . lift . liftSem . for (ucConvId uconn) $ unblockConversation lfrom Nothing
           uconnRevRel :: RelationWithHistory <- relationWithHistory lfrom (ucTo uconnRev)
           uconnRev' <- lift . wrapClient $ Data.updateConnection uconnRev (undoRelationHistory uconnRevRel)
           connName <- lift . wrapClient $ Data.lookupName (tUnqualified lfrom)

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

@@ -151,7 +151,7 @@ desiredMembership a r =
 --
 -- Returns the connection, and whether it was updated or not.
 transitionTo ::
-  (Member GalleyProvider r) =>
+  Member GalleyProvider r =>
   Local UserId ->
   Maybe ConnId ->
   Remote UserId ->
@@ -192,14 +192,18 @@ transitionTo self mzcon other (Just connection) (Just rel) actor = do
         fromMaybe
           (one2OneConvId BaseProtocolProteusTag (tUntagged self) (tUntagged other))
           $ ucConvId connection
-  lift $ updateOne2OneConv self Nothing other proteusConvId (desiredMembership actor rel) actor
+      desiredMem = desiredMembership actor rel
+  lift $ updateOne2OneConv self Nothing other proteusConvId desiredMem 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
+    isEstablished <- lift . liftSem $ isMLSOne2OneEstablished self (tUntagged other)
+    lift
+      . when
+        ( isEstablished == Established
+            || (isEstablished == NotAMember && ucStatus connection == Blocked && rel == Accepted)
+        )
+      $ updateOne2OneConv self Nothing other mlsConvId desiredMem actor
 
   -- update connection
   connection' <- lift $ wrapClient $ Data.updateConnection connection (relationWithHistory rel)
@@ -215,7 +219,7 @@ pushEvent self mzcon connection = do
   Intra.onConnectionEvent (tUnqualified self) mzcon event
 
 performLocalAction ::
-  (Member GalleyProvider r) =>
+  Member GalleyProvider r =>
   Local UserId ->
   Maybe ConnId ->
   Remote UserId ->
@@ -271,7 +275,7 @@ performLocalAction self mzcon other mconnection action = do
 -- B connects & A reacts:  Accepted  Accepted
 -- @
 performRemoteAction ::
-  (Member GalleyProvider r) =>
+  Member GalleyProvider r =>
   Local UserId ->
   Remote UserId ->
   Maybe UserConnection ->

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

@@ -575,6 +575,7 @@ revokeIdentityH bade badp = throwStd (badRequest ("need exactly one of email, ph
 
 updateConnectionInternalH ::
   ( Member (Embed HttpClientIO) r,
+    Member GalleyProvider r,
     Member TinyLog r
   ) =>
   UpdateConnectionsInternal ->

services/brig/src/Brig/Effects/GalleyProvider.hs

@@ -36,6 +36,12 @@ import Wire.API.Team.Member qualified as Team
 import Wire.API.Team.Role
 import Wire.API.Team.SearchVisibility
 
+data MLSOneToOneEstablished
+  = Established
+  | NotEstablished
+  | NotAMember
+  deriving (Eq, Show)
+
 data GalleyProvider m a where
   CreateSelfConv ::
     UserId ->
@@ -109,6 +115,11 @@ data GalleyProvider m a where
   IsMLSOne2OneEstablished ::
     Local UserId ->
     Qualified UserId ->
-    GalleyProvider m Bool
+    GalleyProvider m MLSOneToOneEstablished
+  UnblockConversation ::
+    Local UserId ->
+    Maybe ConnId ->
+    Qualified ConvId ->
+    GalleyProvider m Conversation
 
 makeSem ''GalleyProvider

services/brig/src/Brig/Effects/GalleyProvider/RPC.hs

@@ -20,7 +20,7 @@ module Brig.Effects.GalleyProvider.RPC where
 
 import Bilge hiding (head, options, requestId)
 import Brig.API.Types
-import Brig.Effects.GalleyProvider (GalleyProvider (..))
+import Brig.Effects.GalleyProvider (GalleyProvider (..), MLSOneToOneEstablished (..))
 import Brig.Effects.ServiceRPC (Service (Galley), ServiceRPC)
 import Brig.Effects.ServiceRPC qualified as ServiceRPC
 import Brig.RPC
@@ -49,7 +49,6 @@ import Polysemy.TinyLog
 import Servant.API (toHeader)
 import System.Logger (Msg, field, msg, val)
 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
@@ -91,6 +90,7 @@ interpretGalleyProviderToRPC disabledVersions =
         GetVerificationCodeEnabled id' -> getVerificationCodeEnabled id'
         GetExposeInvitationURLsToTeamAdmin id' -> getTeamExposeInvitationURLsToTeamAdmin id'
         IsMLSOne2OneEstablished lusr qother -> checkMLSOne2OneEstablished lusr qother
+        UnblockConversation lusr mconn qcnv -> unblockConversation v lusr mconn qcnv
 
 -- | Calls 'Galley.API.createSelfConversationH'.
 createSelfConv ::
@@ -493,29 +493,54 @@ checkMLSOne2OneEstablished ::
   ) =>
   Local UserId ->
   Qualified UserId ->
-  Sem r Bool
+  Sem r MLSOneToOneEstablished
 checkMLSOne2OneEstablished self (Qualified other otherDomain) = do
   debug $ remote "galley" . msg (val "Get the MLS one-to-one conversation")
-  response <- ServiceRPC.request @'Galley GET 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
+  responseSelf <- ServiceRPC.request @'Galley GET req
+  case HTTP.statusCode (HTTP.responseStatus responseSelf) of
+    200 -> do
+      established <- decodeBodyOrThrow @Bool "galley" responseSelf
+      pure $ if established then Established else NotEstablished
+    403 -> pure NotAMember
+    400 -> pure NotEstablished
+    _ -> pure NotEstablished
   where
     req =
       paths
         [ "i",
           "conversations",
           "mls-one2one",
           toByteString' otherDomain,
-          toByteString' other
+          toByteString' other,
+          "established"
         ]
         . zUser (tUnqualified self)
+
+unblockConversation ::
+  ( Member (Error ParseException) r,
+    Member (ServiceRPC 'Galley) r,
+    Member TinyLog r
+  ) =>
+  Version ->
+  Local UserId ->
+  Maybe ConnId ->
+  Qualified ConvId ->
+  Sem r Conversation
+unblockConversation v lusr mconn (Qualified cnv cdom) = do
+  debug $
+    remote "galley"
+      . field "conv" (toByteString cnv)
+      . field "domain" (toByteString cdom)
+      . msg (val "Unblocking conversation")
+  void $ ServiceRPC.request @'Galley PUT putReq
+  ServiceRPC.request @'Galley GET getReq >>= decodeBodyOrThrow @Conversation "galley"
+  where
+    putReq =
+      paths ["i", "conversations", toByteString' cdom, toByteString' cnv, "unblock"]
+        . zUser (tUnqualified lusr)
+        . maybe id (header "Z-Connection" . fromConnId) mconn
+        . expect2xx
+    getReq =
+      paths [toHeader v, "conversations", toByteString' cdom, toByteString' cnv]
+        . zUser (tUnqualified lusr)
+        . expect2xx