[WPB-6783] Support unblocking an MLS 1-to-1 conversation

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
@@ -122,9 +178,9 @@ instance TestCases One2OneScenario where
       MkTestCase "[domain=other;conv=other]" One2OneScenarioRemoteConv
     ]
 
-one2OneScenarioDomain :: One2OneScenario -> Domain
-one2OneScenarioDomain One2OneScenarioLocal = OwnDomain
-one2OneScenarioDomain _ = OtherDomain
+one2OneScenarioUserDomain :: One2OneScenario -> Domain
+one2OneScenarioUserDomain One2OneScenarioLocal = OwnDomain
+one2OneScenarioUserDomain _ = OtherDomain
 
 one2OneScenarioConvDomain :: One2OneScenario -> Domain
 one2OneScenarioConvDomain One2OneScenarioLocal = OwnDomain
@@ -134,7 +190,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

@@ -341,8 +341,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)
@@ -353,7 +353,13 @@ updateConnectionToLocalUser self other newStatus conn = do
       lift . Log.info $
         logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o))
           . msg (val "Unblocking connection")
-      cnv <- lift $ traverse (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 $
@@ -413,7 +419,8 @@ mkRelationWithHistory oldRel = \case
 
 updateConnectionInternal ::
   forall r.
-  ( Member NotificationSubsystem r,
+  ( Member GalleyProvider r,
+    Member NotificationSubsystem r,
     Member TinyLog r,
     Member (Embed HttpClientIO) r
   ) =>
@@ -480,7 +487,7 @@ updateConnectionInternal = \case
         unblockDirected :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) ()
         unblockDirected uconn uconnRev = do
           lfrom <- qualifyLocal (ucFrom uconnRev)
-          void . lift . for (ucConvId uconn) $ 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

@@ -152,7 +152,7 @@ desiredMembership a r =
 --
 -- Returns the connection, and whether it was updated or not.
 transitionTo ::
-  (Member NotificationSubsystem r, Member GalleyProvider r) =>
+  (Member GalleyProvider r, Member NotificationSubsystem 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)
@@ -220,7 +224,7 @@ pushEvent self mzcon connection = do
   liftSem $ Intra.onConnectionEvent (tUnqualified self) mzcon event
 
 performLocalAction ::
-  (Member NotificationSubsystem r, Member GalleyProvider r) =>
+  (Member GalleyProvider r, Member NotificationSubsystem r) =>
   Local UserId ->
   Maybe ConnId ->
   Remote UserId ->
@@ -276,7 +280,7 @@ performLocalAction self mzcon other mconnection action = do
 -- B connects & A reacts:  Accepted  Accepted
 -- @
 performRemoteAction ::
-  (Member NotificationSubsystem r, Member GalleyProvider r) =>
+  (Member GalleyProvider r, Member NotificationSubsystem r) =>
   Local UserId ->
   Remote UserId ->
   Maybe UserConnection ->
@@ -294,9 +298,9 @@ performRemoteAction self other mconnection action = do
     reaction _ = Nothing
 
 createConnectionToRemoteUser ::
-  ( Member FederationConfigStore r,
-    Member NotificationSubsystem r,
-    Member GalleyProvider r
+  ( Member GalleyProvider r,
+    Member FederationConfigStore r,
+    Member NotificationSubsystem r
   ) =>
   Local UserId ->
   ConnId ->
@@ -309,9 +313,9 @@ createConnectionToRemoteUser self zcon other = do
   fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect
 
 updateConnectionToRemoteUser ::
-  ( Member NotificationSubsystem r,
-    Member FederationConfigStore r,
-    Member GalleyProvider r
+  ( Member GalleyProvider r,
+    Member NotificationSubsystem r,
+    Member FederationConfigStore r
   ) =>
   Local UserId ->
   Remote UserId ->

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

@@ -111,8 +111,8 @@ getFederationStatus _ request = do
 
 sendConnectionAction ::
   ( Member FederationConfigStore r,
-    Member NotificationSubsystem r,
-    Member GalleyProvider r
+    Member GalleyProvider r,
+    Member NotificationSubsystem r
   ) =>
   Domain ->
   NewConnectionRequest ->

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

@@ -677,7 +677,8 @@ revokeIdentityH Nothing (Just phone) = lift $ NoContent <$ API.revokeIdentity (R
 revokeIdentityH bade badp = throwStd (badRequest ("need exactly one of email, phone: " <> Imports.cs (show (bade, badp))))
 
 updateConnectionInternalH ::
-  ( Member NotificationSubsystem r,
+  ( Member GalleyProvider r,
+    Member NotificationSubsystem r,
     Member TinyLog r,
     Member (Embed HttpClientIO) r
   ) =>

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