diff --git a/changelog.d/2-features/WPB-6783 b/changelog.d/2-features/WPB-6783 new file mode 100644 index 00000000000..c746b345e37 --- /dev/null +++ b/changelog.d/2-features/WPB-6783 @@ -0,0 +1 @@ +Support unblocking a user in an MLS 1-to-1 conversation diff --git a/integration/test/Test/MLS/One2One.hs b/integration/test/Test/MLS/One2One.hs index 1e2f10e02ee..aac9725d9c9 100644 --- a/integration/test/Test/MLS/One2One.hs +++ b/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] 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 b6be1bade6a..d07f48258dc 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/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 = diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 1144931940f..b7ba931541f 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/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) diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 5f41c261e5c..5b6240a09ec 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/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 -> diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index cc44dd3b250..067d14389f5 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/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 -> diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index c04173cf918..9adc85b9af0 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/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 ) => diff --git a/services/brig/src/Brig/Effects/GalleyProvider.hs b/services/brig/src/Brig/Effects/GalleyProvider.hs index c45d58a81b2..24843dbaa0b 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider.hs +++ b/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 diff --git a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs index 84d6ba98cf9..447f8386b41 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs @@ -19,7 +19,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.RPC hiding (galleyRequest) import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import Control.Error (hush) @@ -48,7 +48,6 @@ 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 @@ -93,6 +92,7 @@ interpretGalleyProviderToRpc disabledVersions galleyEndpoint = GetVerificationCodeEnabled id' -> getVerificationCodeEnabled id' GetExposeInvitationURLsToTeamAdmin id' -> getTeamExposeInvitationURLsToTeamAdmin id' IsMLSOne2OneEstablished lusr qother -> checkMLSOne2OneEstablished lusr qother + UnblockConversation lusr mconn qcnv -> unblockConversation v lusr mconn qcnv galleyRequest :: (Member Rpc r, Member (Input Endpoint) r) => (Request -> Request) -> Sem r (Response (Maybe LByteString)) galleyRequest req = do @@ -537,22 +537,17 @@ 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 <- 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 + responseSelf <- galleyRequest 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 = method GET @@ -561,6 +556,39 @@ checkMLSOne2OneEstablished self (Qualified other otherDomain) = do "conversations", "mls-one2one", toByteString' otherDomain, - toByteString' other + toByteString' other, + "established" ] . zUser (tUnqualified self) + +unblockConversation :: + ( Member (Error ParseException) r, + Member (Input Endpoint) r, + Member Rpc 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 $ galleyRequest putReq + galleyRequest getReq >>= decodeBodyOrThrow @Conversation "galley" + where + putReq = + method PUT + . paths ["i", "conversations", toByteString' cdom, toByteString' cnv, "unblock"] + . zUser (tUnqualified lusr) + . maybe id (header "Z-Connection" . fromConnId) mconn + . expect2xx + getReq = + method GET + . paths [toHeader v, "conversations", toByteString' cdom, toByteString' cnv] + . zUser (tUnqualified lusr) + . expect2xx diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 23d7d3bbb0a..2dbd9109b0e 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -29,7 +29,6 @@ module Brig.IO.Intra createConnectConv, acceptConnectConv, blockConv, - unblockConv, upsertOne2OneConversation, -- * Clients @@ -669,42 +668,6 @@ blockConv lusr qcnv = do . zUser (tUnqualified lusr) . expect2xx --- | Calls 'Galley.API.unblockConvH'. -unblockLocalConv :: - ( Member (Embed HttpClientIO) r, - Member TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - ConvId -> - Sem r Conversation -unblockLocalConv lusr conn cnv = do - Log.debug $ - remote "galley" - . field "conv" (toByteString cnv) - . msg (val "Unblocking conversation") - embed $ galleyRequest PUT req >>= decodeBody "galley" - where - req = - paths ["/i/conversations", toByteString' cnv, "unblock"] - . zUser (tUnqualified lusr) - . maybe id (header "Z-Connection" . fromConnId) conn - . expect2xx - -unblockConv :: - ( Member (Embed HttpClientIO) r, - Member TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - Qualified ConvId -> - AppT r Conversation -unblockConv luid conn = - foldQualified - luid - (liftSem . unblockLocalConv luid conn . tUnqualified) - (const (throwM federationNotImplemented)) - upsertOne2OneConversation :: ( MonadReader Env m, MonadIO m, diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 15d0107d009..5e66acec806 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -127,9 +127,11 @@ conversationAPI = <@> mkNamedAPI @"conversation-accept-v2" Update.acceptConv <@> mkNamedAPI @"conversation-block-unqualified" Update.blockConvUnqualified <@> mkNamedAPI @"conversation-block" Update.blockConv + <@> mkNamedAPI @"conversation-unblock-unqualified" Update.unblockConvUnqualified <@> mkNamedAPI @"conversation-unblock" Update.unblockConv <@> mkNamedAPI @"conversation-meta" Query.getConversationMeta <@> mkNamedAPI @"conversation-mls-one-to-one" Query.getMLSOne2OneConversation + <@> mkNamedAPI @"conversation-mls-one-to-one-established" Query.isMLSOne2OneEstablished legalholdWhitelistedTeamsAPI :: API ILegalholdWhitelistedTeamsAPI GalleyEffects legalholdWhitelistedTeamsAPI = mkAPI $ \tid -> hoistAPIHandler Imports.id (base tid) diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 37b2f295dc7..aaa01a9daa4 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -38,6 +38,7 @@ module Galley.API.Query getMLSSelfConversation, getMLSSelfConversationWithError, getMLSOne2OneConversation, + isMLSOne2OneEstablished, ) where @@ -65,6 +66,7 @@ import Galley.API.Mapping qualified as Mapping import Galley.API.One2One import Galley.API.Util import Galley.Data.Conversation qualified as Data +import Galley.Data.Conversation.Types qualified as Data import Galley.Data.Types (Code (codeConversation)) import Galley.Data.Types qualified as Data import Galley.Effects @@ -89,6 +91,7 @@ import System.Logger.Class qualified as Logger import Wire.API.Conversation hiding (Member) import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Code +import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Conversation.Role qualified as Public import Wire.API.Error @@ -792,7 +795,7 @@ getRemoteMLSOne2OneConversation lself qother rconv = do -- a conversation can only be remote if it is hosted on the other user's domain rother <- if qDomain qother == tDomain rconv - then pure (toRemoteUnsafe (tDomain rconv) (qUnqualified qother)) + then pure (qualifyAs rconv (qUnqualified qother)) else throw (InternalErrorWithDescription "Unexpected 1-1 conversation domain") resp <- @@ -806,6 +809,67 @@ getRemoteMLSOne2OneConversation lself qother rconv = do throw (FederationUnexpectedBody "Backend mismatch when retrieving a remote 1-1 conversation") GetOne2OneConversationNotConnected -> throwS @'NotConnected +-- | Check if an MLS 1-1 conversation has been established, namely if its epoch +-- is non-zero. The conversation will only be stored in the database when its +-- first commit arrives. +-- +-- For the federated case, we do not make the assumption that the other backend +-- uses the same function to calculate the conversation ID and corresponding +-- group ID, however we /do/ assume that the two backends agree on which of the +-- two is responsible for hosting the conversation. +isMLSOne2OneEstablished :: + ( Member ConversationStore r, + Member (Input Env) r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (ErrorS 'MLSNotEnabled) r, + Member (ErrorS 'NotConnected) r, + Member FederatorAccess r + ) => + Local UserId -> + Qualified UserId -> + Sem r Bool +isMLSOne2OneEstablished lself qother = do + assertMLSEnabled + let convId = one2OneConvId BaseProtocolMLSTag (tUntagged lself) qother + foldQualified + lself + isLocalMLSOne2OneEstablished + (isRemoteMLSOne2OneEstablished lself qother) + convId + +isLocalMLSOne2OneEstablished :: + Member ConversationStore r => + Local ConvId -> + Sem r Bool +isLocalMLSOne2OneEstablished lconv = do + mconv <- E.getConversation (tUnqualified lconv) + pure $ case mconv of + Nothing -> False + Just conv -> do + let meta = fst <$> Data.mlsMetadata conv + maybe False ((> 0) . epochNumber . cnvmlsEpoch) meta + +isRemoteMLSOne2OneEstablished :: + ( Member (ErrorS 'NotConnected) r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member FederatorAccess r + ) => + Local UserId -> + Qualified UserId -> + Remote conv -> + Sem r Bool +isRemoteMLSOne2OneEstablished lself qother rconv = do + conv <- getRemoteMLSOne2OneConversation lself qother rconv + pure . (> 0) $ case cnvProtocol conv of + ProtocolProteus -> 0 + ProtocolMLS meta -> ep meta + ProtocolMixed meta -> ep meta + where + ep :: ConversationMLSData -> Word64 + ep = epochNumber . cnvmlsEpoch + ------------------------------------------------------------------------------- -- Helpers diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 809f0376188..9e74a97aaa6 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -23,6 +23,7 @@ module Galley.API.Update blockConv, blockConvUnqualified, unblockConv, + unblockConvUnqualified, checkReusableCode, joinConversationByReusableCode, joinConversationById, @@ -175,8 +176,8 @@ blockConv :: blockConv lusr qcnv = foldQualified lusr - (\lcnv -> blockConvUnqualified (tUnqualified lusr) (tUnqualified lcnv)) - (\rcnv -> blockRemoteConv lusr rcnv) + (blockConvUnqualified (tUnqualified lusr) . tUnqualified) + (blockRemoteConv lusr) qcnv blockConvUnqualified :: @@ -208,6 +209,26 @@ blockRemoteConv (tUnqualified -> usr) rcnv = do E.deleteMembersInRemoteConversation rcnv [usr] unblockConv :: + ( Member ConversationStore r, + Member (Error InternalError) r, + Member (ErrorS 'ConvNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member NotificationSubsystem r, + Member (Input UTCTime) r, + Member MemberStore r, + Member TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + Qualified ConvId -> + Sem r () +unblockConv lusr conn = + foldQualified + lusr + (void . unblockConvUnqualified lusr conn . tUnqualified) + (unblockRemoteConv lusr) + +unblockConvUnqualified :: ( Member ConversationStore r, Member (Error InternalError) r, Member (ErrorS 'ConvNotFound) r, @@ -221,7 +242,7 @@ unblockConv :: Maybe ConnId -> ConvId -> Sem r Conversation -unblockConv lusr conn cnv = do +unblockConvUnqualified lusr conn cnv = do conv <- E.getConversation cnv >>= noteS @'ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ @@ -229,6 +250,15 @@ unblockConv lusr conn cnv = do conv' <- acceptOne2One lusr conv conn conversationView lusr conv' +unblockRemoteConv :: + ( Member MemberStore r + ) => + Local UserId -> + Remote ConvId -> + Sem r () +unblockRemoteConv lusr rcnv = do + E.createMembersInRemoteConversation rcnv [tUnqualified lusr] + -- conversation updates handleUpdateResult :: UpdateResult Event -> Response