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..70d315f9e42 --- /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 (#3889, #3906) 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 88484ca4480..161aa2648f5 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,8 +57,10 @@ 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) @@ -64,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 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 diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 8d75155198a..34dc5caef80 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 @@ -103,39 +107,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. @@ -145,6 +151,7 @@ updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do -- -- Returns the connection, and whether it was updated or not. transitionTo :: + (Member GalleyProvider r) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -157,8 +164,14 @@ 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 having no pre-existing connection implies + -- there was no conversation. Creating an MLS conversation 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 <- @@ -167,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. @@ -191,6 +215,7 @@ pushEvent self mzcon connection = do Intra.onConnectionEvent (tUnqualified self) mzcon event performLocalAction :: + (Member GalleyProvider r) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -246,6 +271,7 @@ performLocalAction self mzcon other mconnection action = do -- B connects & A reacts: Accepted Accepted -- @ performRemoteAction :: + (Member GalleyProvider r) => Local UserId -> Remote UserId -> Maybe UserConnection -> @@ -263,7 +289,9 @@ performRemoteAction self other mconnection action = do reaction _ = Nothing createConnectionToRemoteUser :: - Member FederationConfigStore r => + ( Member FederationConfigStore r, + Member GalleyProvider r + ) => Local UserId -> ConnId -> Remote UserId -> @@ -275,7 +303,9 @@ createConnectionToRemoteUser self zcon other = do fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect updateConnectionToRemoteUser :: - Member FederationConfigStore r => + ( Member FederationConfigStore r, + Member GalleyProvider r + ) => Local UserId -> Remote UserId -> Relation -> diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index d77fa67f554..76d00a9656d 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -110,7 +110,9 @@ getFederationStatus _ request = do pure $ NonConnectedBackends (request.domains \\ fedDomains) sendConnectionAction :: - Member FederationConfigStore r => + ( Member FederationConfigStore r, + Member GalleyProvider r + ) => Domain -> NewConnectionRequest -> Handler r NewConnectionResponse diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 72e6eaeb8ff..b00c788a13b 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -76,6 +76,7 @@ import Imports hiding (head) import Network.Wai.Routing hiding (toList) import Network.Wai.Utilities as Utilities import Polysemy +import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) import Servant.OpenApi.Internal.Orphans () import System.Logger.Class qualified as Log @@ -102,13 +103,15 @@ import Wire.API.User.RichInfo servantSitemap :: forall r p. - ( Member BlacklistStore r, - Member CodeStore r, + ( Member (Embed HttpClientIO) r, + Member (UserPendingActivationStore p) r, Member BlacklistPhonePrefixStore r, - Member PasswordResetStore r, + Member BlacklistStore r, + Member CodeStore r, + Member FederationConfigStore r, Member GalleyProvider r, - Member (UserPendingActivationStore p) r, - Member FederationConfigStore r + Member PasswordResetStore r, + Member TinyLog r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -143,12 +146,14 @@ mlsAPI :: ServerT BrigIRoutes.MLSAPI (Handler r) mlsAPI = getMLSClients accountAPI :: - ( Member BlacklistStore r, - Member CodeStore r, + ( Member (Embed HttpClientIO) r, + Member (UserPendingActivationStore p) r, Member BlacklistPhonePrefixStore r, - Member PasswordResetStore r, + Member BlacklistStore r, + Member CodeStore r, Member GalleyProvider r, - Member (UserPendingActivationStore p) r + Member PasswordResetStore r, + Member TinyLog r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -568,7 +573,12 @@ revokeIdentityH (Just email) Nothing = lift $ NoContent <$ API.revokeIdentity (L revokeIdentityH Nothing (Just phone) = lift $ NoContent <$ API.revokeIdentity (Right phone) revokeIdentityH bade badp = throwStd (badRequest ("need exactly one of email, phone: " <> Imports.cs (show (bade, badp)))) -updateConnectionInternalH :: UpdateConnectionsInternal -> (Handler r) NoContent +updateConnectionInternalH :: + ( Member (Embed HttpClientIO) r, + Member TinyLog r + ) => + UpdateConnectionsInternal -> + Handler r NoContent updateConnectionInternalH updateConn = do API.updateConnectionInternal updateConn !>> connError pure NoContent diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index d61beffefa4..23dc00dbeff 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -101,6 +101,7 @@ import Imports hiding (head) import Network.Socket (PortNumber) import Network.Wai.Utilities as Utilities import Polysemy +import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) import Servant qualified import Servant.OpenApi.Internal.Orphans () @@ -271,7 +272,9 @@ servantSitemap :: Member PublicKeyBundle r, Member (UserPendingActivationStore p) r, Member Jwk r, - Member FederationConfigStore r + Member FederationConfigStore r, + Member (Embed HttpClientIO) r, + Member TinyLog r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -1013,6 +1016,10 @@ createConnection self conn target = do API.createConnection lself conn target !>> connError updateLocalConnection :: + ( Member GalleyProvider r, + Member TinyLog r, + Member (Embed HttpClientIO) r + ) => UserId -> ConnId -> UserId -> @@ -1025,7 +1032,11 @@ updateLocalConnection self conn other (Public.cuStatus -> newStatus) = do <$> API.updateConnectionToLocalUser lself lother newStatus (Just conn) !>> connError updateConnection :: - Member FederationConfigStore r => + ( Member FederationConfigStore r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member GalleyProvider r + ) => UserId -> ConnId -> Qualified UserId -> diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index d178e9867df..b88cb764201 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -80,6 +80,7 @@ module Brig.App wrapHttpClientE, wrapHttp, HttpClientIO (..), + runHttpClientIO, liftSem, lowerAppT, temporaryGetEnv, @@ -529,7 +530,7 @@ wrapHttp (HttpClientIO m) = do liftIO . runClient c . runHttpT manager $ runReaderT m env newtype HttpClientIO a = HttpClientIO - { runHttpClientIO :: ReaderT Env (HttpT Cas.Client) a + { unHttpClientIO :: ReaderT Env (HttpT Cas.Client) a } deriving newtype ( Functor, @@ -546,6 +547,13 @@ newtype HttpClientIO a = HttpClientIO MonadIndexIO ) +runHttpClientIO :: MonadIO m => Env -> HttpClientIO a -> m a +runHttpClientIO env = + runClient (env ^. casClient) + . runHttpT (env ^. httpManager) + . flip runReaderT env + . unHttpClientIO + instance MonadZAuth HttpClientIO where liftZAuth za = view zauthEnv >>= flip runZAuth za diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 386033d74f4..d989afc7446 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -28,6 +28,7 @@ import Control.Lens ((^.)) import Control.Monad.Catch (throwM) import Imports import Polysemy (Embed, Final, embedToFinal, runFinal) +import Polysemy.Embed (runEmbedded) import Polysemy.Error (Error, mapError, runError) import Polysemy.TinyLog (TinyLog) import Wire.Sem.Concurrency @@ -56,6 +57,7 @@ type BrigCanonicalEffects = Error ParseException, Error SomeException, TinyLog, + Embed HttpClientIO, Embed IO, Concurrency 'Unsafe, Final IO @@ -67,6 +69,7 @@ runBrigToIO e (AppT ma) = do <=< ( runFinal . unsafelyPerformConcurrency . embedToFinal + . runEmbedded (runHttpClientIO e) . loggerToTinyLog (e ^. applog) . runError @SomeException . mapError @ParseException SomeException 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 2605aa1219c..39d7ee5dad6 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs @@ -38,14 +38,18 @@ 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 import Polysemy import Polysemy.Error +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 @@ -55,7 +59,6 @@ import Wire.API.Team.Member qualified as Member import Wire.API.Team.Member qualified as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility -import Wire.Sem.Logger interpretGalleyProviderToRPC :: ( Member (Error ParseException) r, @@ -87,6 +90,7 @@ interpretGalleyProviderToRPC disabledVersions = GetAllFeatureConfigsForUser m_id' -> getAllFeatureConfigsForUser m_id' GetVerificationCodeEnabled id' -> getVerificationCodeEnabled id' GetExposeInvitationURLsToTeamAdmin id' -> getTeamExposeInvitationURLsToTeamAdmin id' + IsMLSOne2OneEstablished lusr qother -> checkMLSOne2OneEstablished lusr qother -- | Calls 'Galley.API.createSelfConversationH'. createSelfConv :: @@ -481,3 +485,37 @@ getTeamExposeInvitationURLsToTeamAdmin tid = do req = paths ["i", "teams", toByteString' tid, "features", featureNameBS @ExposeInvitationURLsToTeamAdminConfig] . expect2xx + +checkMLSOne2OneEstablished :: + ( Member (Error ParseException) r, + Member (ServiceRPC 'Galley) 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 <- 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 + where + req = + 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 1735cd65d5c..ed7ee5a9b80 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -90,15 +90,18 @@ import Gundeck.Types.Push.V2 qualified as Push import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status +import Polysemy +import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as TinyLog import System.Logger.Class as Log hiding (name, (.=)) import System.Logger.Extended qualified as ExLog import Wire.API.Connection -import Wire.API.Conversation +import Wire.API.Conversation hiding (Member) 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 @@ -734,50 +737,32 @@ acceptConnectConv from conn = (wrapHttp . acceptLocalConnectConv from conn . tUnqualified) (const (throwM federationNotImplemented)) --- | Calls 'Galley.API.blockConvH'. -blockLocalConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m +blockConv :: + ( Member (Embed HttpClientIO) r, + Member TinyLog r ) => Local UserId -> - Maybe ConnId -> - ConvId -> - m () -blockLocalConv lusr conn cnv = do - debug $ + Qualified ConvId -> + Sem r () +blockConv lusr qcnv = do + TinyLog.debug $ remote "galley" - . field "conv" (toByteString cnv) + . field "conv" (toByteString . qUnqualified $ qcnv) + . field "domain" (toByteString . qDomain $ qcnv) . msg (val "Blocking conversation") - 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 :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - Local UserId -> - Maybe ConnId -> - Qualified ConvId -> - m () -blockConv lusr conn = - foldQualified - lusr - (blockLocalConv lusr conn . tUnqualified) - (const (throwM federationNotImplemented)) - -- | Calls 'Galley.API.unblockConvH'. unblockLocalConv :: ( MonadReader Env m, @@ -830,11 +815,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/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 1920db1a85d..a2676ae2d22 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -64,7 +64,7 @@ import Network.Wai.Routing.Route (App) import Network.Wai.Utilities (lookupRequestId) import Network.Wai.Utilities.Server import Network.Wai.Utilities.Server qualified as Server -import Polysemy (Member) +import Polysemy hiding (run) import Servant (Context ((:.)), (:<|>) (..)) import Servant qualified import System.Logger (Logger, msg, val, (.=), (~~)) diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 18b2df3cad8..ba0ceb5b4d1 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -127,9 +127,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..05b1d16b9c4 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/services/galley/src/Galley/API/One2One.hs @@ -58,17 +58,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,7 +81,7 @@ 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] []) @@ -111,5 +102,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 bd860ef86b0..e9afdbdc512 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, @@ -166,6 +167,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, @@ -174,7 +191,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 @@ -182,6 +199,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/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")