diff --git a/changelog.d/1-api-changes/WPB-3640 b/changelog.d/1-api-changes/WPB-3640 new file mode 100644 index 00000000000..5ebb8831e91 --- /dev/null +++ b/changelog.d/1-api-changes/WPB-3640 @@ -0,0 +1 @@ +Conversation creation endpoints can now return `unreachable_backends` error responses with status code 503 if any of the involved backends are unreachable. The conversation is not created in that case. diff --git a/integration/test/Test/Conversation.hs b/integration/test/Test/Conversation.hs index 9fcf9c11e06..4cec7efbbbc 100644 --- a/integration/test/Test/Conversation.hs +++ b/integration/test/Test/Conversation.hs @@ -51,8 +51,8 @@ testDynamicBackendsNotFederating = do $ bindResponse (getFederationStatus uidA [domainB, domainC]) $ \resp -> do - resp.status `shouldMatchInt` 422 - resp.json %. "label" `shouldMatch` "federation-denied" + resp.status `shouldMatchInt` 503 + resp.json %. "unreachable_backends" `shouldMatchSet` [domainB, domainC] testDynamicBackendsFullyConnectedWhenAllowDynamic :: HasCallStack => App () testDynamicBackendsFullyConnectedWhenAllowDynamic = do @@ -123,8 +123,8 @@ testFederationStatus = do bindResponse (getFederationStatus uid [invalidDomain]) $ \resp -> do - resp.status `shouldMatchInt` 422 - resp.json %. "label" `shouldMatch` "invalid-domain" + resp.status `shouldMatchInt` 503 + resp.json %. "unreachable_backends" `shouldMatchSet` [invalidDomain] bindResponse (getFederationStatus uid [federatingRemoteDomain]) @@ -327,3 +327,24 @@ testAddMembersNonFullyConnectedProteus = do bindResponse (addMembers u1 cid members) $ \resp -> do resp.status `shouldMatchInt` 409 resp.json %. "non_federating_backends" `shouldMatchSet` [domainB, domainC] + +testConvWithUnreachableRemoteUsers :: App () +testConvWithUnreachableRemoteUsers = do + let overrides = + def {dbBrig = setField "optSettings.setFederationStrategy" "allowAll"} + <> fullSearchWithAll + ([alice, alex, bob, charlie, dylan], domains) <- + startDynamicBackends [overrides, overrides] $ \domains -> do + own <- make OwnDomain & asString + other <- make OtherDomain & asString + users <- createAndConnectUsers $ [own, own, other] <> domains + pure (users, domains) + + let newConv = defProteus {qualifiedUsers = [alex, bob, charlie, dylan]} + bindResponse (postConversation alice newConv) $ \resp -> do + resp.status `shouldMatchInt` 503 + resp.json %. "unreachable_backends" `shouldMatchSet` domains + + convs <- getAllConvs alice >>= asList + regConvs <- filterM (\c -> (==) <$> (c %. "type" & asInt) <*> pure 0) convs + regConvs `shouldMatch` ([] :: [Value]) diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs index c496c313926..01b7a4cee8f 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs @@ -31,8 +31,6 @@ import Control.Error import Data.Aeson hiding (Error) import Data.Aeson.Types (Pair) import Data.Domain -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NE import Data.Text.Lazy.Encoding (decodeUtf8) import Imports import Network.HTTP.Types @@ -51,24 +49,23 @@ mkError c l m = Error c l m Nothing instance Exception Error data ErrorData = FederationErrorData - { federrDomains :: NonEmpty Domain, + { federrDomain :: !Domain, federrPath :: !Text } deriving (Eq, Show, Typeable) instance ToJSON ErrorData where - toJSON (FederationErrorData ds p) = + toJSON (FederationErrorData d p) = object [ "type" .= ("federation" :: Text), - "domain" .= NE.head ds, -- deprecated in favour for `domains` - "domains" .= ds, + "domain" .= d, "path" .= p ] instance FromJSON ErrorData where parseJSON = withObject "ErrorData" $ \o -> FederationErrorData - <$> o .: "domains" + <$> o .: "domain" <*> o .: "path" -- | Assumes UTF-8 encoding. diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index 57cbdb1fdfa..a0eaa4d5886 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -57,11 +57,9 @@ import Data.ByteString.Builder import Data.ByteString.Char8 qualified as C import Data.ByteString.Lazy qualified as LBS import Data.Domain (domainText) -import Data.List.NonEmpty qualified as NE import Data.Metrics.GC (spawnGCMetricsCollector) import Data.Metrics.Middleware import Data.Streaming.Zlib (ZlibException (..)) -import Data.Text qualified as T import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Lazy.Encoding qualified as LT import Imports @@ -400,13 +398,8 @@ logErrorMsg (Wai.Error c l m md) = . maybe id logErrorData md . msg (val "\"" +++ m +++ val "\"") where - logErrorData (Wai.FederationErrorData (NE.toList -> d) p) = - field - "domains" - ( val "[" - +++ T.intercalate ", " (map domainText d) - +++ val "]" - ) + logErrorData (Wai.FederationErrorData d p) = + field "domain" (domainText d) . field "path" p logErrorMsgWithRequest :: Maybe ByteString -> Wai.Error -> Msg -> Msg diff --git a/libs/wire-api-federation/default.nix b/libs/wire-api-federation/default.nix index 66e4a95ed2a..2ac0f43e549 100644 --- a/libs/wire-api-federation/default.nix +++ b/libs/wire-api-federation/default.nix @@ -26,7 +26,6 @@ , lib , metrics-wai , mtl -, polysemy , QuickCheck , schema-profunctor , servant @@ -67,7 +66,6 @@ mkDerivation { lens metrics-wai mtl - polysemy QuickCheck schema-profunctor servant diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 258b8efa001..7400abaa4da 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -390,6 +390,7 @@ data ConversationUpdateResponse | ConversationUpdateResponseUpdate ConversationUpdate | ConversationUpdateResponseNoChanges | ConversationUpdateResponseNonFederatingBackends NonFederatingBackends + | ConversationUpdateResponseUnreachableBackends UnreachableBackends deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 4519b7f9f6f..f2a220a2c3d 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -44,7 +44,6 @@ import Data.ByteString.Builder import Data.ByteString.Conversion (toByteString') import Data.ByteString.Lazy qualified as LBS import Data.Domain -import Data.List.NonEmpty (NonEmpty) import Data.Sequence qualified as Seq import Data.Set qualified as Set import Data.Text.Encoding qualified as Text @@ -226,13 +225,13 @@ withHTTP2StreamingRequest successfulStatus req handleResponse = do FederatorClientError ( mkFailureResponse (responseStatusCode resp) - [ceTargetDomain env] + (ceTargetDomain env) (toLazyByteString (requestPath req)) (toLazyByteString bdy) ) -mkFailureResponse :: HTTP.Status -> NonEmpty Domain -> LByteString -> LByteString -> Wai.Error -mkFailureResponse status domains path body +mkFailureResponse :: HTTP.Status -> Domain -> LByteString -> LByteString -> Wai.Error +mkFailureResponse status domain path body -- If the outward federator fails with 403, that means that there was an -- error at the level of the local federator (most likely due to a bug somewhere -- in wire-server). It does not make sense to return this error directly to the @@ -252,7 +251,7 @@ mkFailureResponse status domains path body { Wai.errorData = Just Wai.FederationErrorData - { Wai.federrDomains = domains, + { Wai.federrDomain = domain, Wai.federrPath = "/federation" <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs index d1745ce2dea..02fd6403a44 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs @@ -66,27 +66,23 @@ -- error response from services during a federated call should be considered a bug -- in the implementation of the federation API, and is therefore wrapped in a 533. module Wire.API.Federation.Error - ( FederatorClientHTTP2Error (..), + ( -- * Federation errors + FederatorClientHTTP2Error (..), FederatorClientError (..), FederationError (..), VersionNegotiationError (..), - UnreachableBackendsError (..), federationErrorToWai, federationRemoteHTTP2Error, federationRemoteResponseError, federationNotImplemented, federationNotConfigured, - -- * utilities - throwUnreachableUsers, - throwUnreachableDomains, + -- * Error status codes + unexpectedFederationResponseStatus, + federatorConnectionRefusedStatus, ) where -import Data.Domain -import Data.List.NonEmpty qualified as NE -import Data.Qualified -import Data.Set qualified as Set import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.Lazy qualified as LT @@ -94,14 +90,10 @@ import Imports import Network.HTTP.Types.Status import Network.HTTP.Types.Status qualified as HTTP import Network.HTTP2.Client qualified as HTTP2 -import Network.Wai.Utilities.Error import Network.Wai.Utilities.Error qualified as Wai import OpenSSL.Session (SomeSSLException) -import Polysemy -import Polysemy.Error qualified as P import Servant.Client import Wire.API.Error -import Wire.API.Unreachable -- | Transport-layer errors in federator client. data FederatorClientHTTP2Error @@ -167,11 +159,6 @@ data FederationError -- like "can't delete remote domains from config file", which is only -- needed until we start disregarding the config file. FederationUnexpectedError Text - | -- | One or more remote backends is unreachable - -- - -- FUTUREWORK: Remove this data constructor and rely on the - -- 'UnreachableBackendsError' error type instead. - FederationUnreachableDomainsOld (Set Domain) deriving (Show, Typeable) data VersionNegotiationError @@ -180,12 +167,6 @@ data VersionNegotiationError | RemoteTooNew deriving (Show, Typeable) --- | A new error type in federation that describes a collection of unreachable --- backends by providing their domains. -newtype UnreachableBackendsError = UnreachableBackendsError - { unUnreachableBackendsError :: Set Domain - } - versionNegotiationErrorMessage :: VersionNegotiationError -> LText versionNegotiationErrorMessage InvalidVersionInfo = "Remote federator returned invalid version information" @@ -205,7 +186,6 @@ federationErrorToWai FederationNotConfigured = federationNotConfigured federationErrorToWai (FederationCallFailure err) = federationClientErrorToWai err federationErrorToWai (FederationUnexpectedBody s) = federationUnexpectedBody s federationErrorToWai (FederationUnexpectedError t) = federationUnexpectedError t -federationErrorToWai (FederationUnreachableDomainsOld ds) = federationUnreachableError ds federationClientErrorToWai :: FederatorClientError -> Wai.Error federationClientErrorToWai (FederatorClientHTTP2Error e) = @@ -332,17 +312,6 @@ federationUnexpectedError msg = "federation-unexpected-wai-error" ("Could parse body, but got an unexpected error response: " <> LT.fromStrict msg) -federationUnreachableError :: Set Domain -> Wai.Error -federationUnreachableError (Set.toList -> ds) = - Wai.Error - status - "federation-unreachable-domains-error" - ("The following domains are unreachable: " <> (LT.pack . show . map domainText) ds) - (flip FederationErrorData T.empty <$> NE.nonEmpty ds) - where - status :: Status - status = HTTP.Status 503 "Unreachable federated domains" - federationNotConfigured :: Wai.Error federationNotConfigured = Wai.mkError @@ -363,17 +332,3 @@ federationUnknownError = unexpectedFederationResponseStatus "unknown-federation-error" "Unknown federation error" - --------------------------------------------------------------------------------- --- Utilities - -throwUnreachableUsers :: Member (P.Error FederationError) r => UnreachableUsers -> Sem r a -throwUnreachableUsers = - throwUnreachableDomains - . Set.fromList - . NE.toList - . fmap qDomain - . unreachableUsers - -throwUnreachableDomains :: Member (P.Error FederationError) r => Set Domain -> Sem r a -throwUnreachableDomains = P.throw . FederationUnreachableDomainsOld diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index da2304bd1e9..53862a2f92f 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -97,7 +97,6 @@ library , lens , metrics-wai , mtl - , polysemy , QuickCheck >=2.13 , schema-profunctor , servant >=0.16 diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index 382b39b99a6..f28e178727a 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -35,7 +35,6 @@ module Wire.API.Conversation cnvReceiptMode, cnvAccessRoles, CreateGroupConversation (..), - CreateConversationUnreachableBackends (..), ConversationCoverView (..), ConversationList (..), ListConversations (..), @@ -314,22 +313,6 @@ instance ToSchema CreateGroupConversation where fromFlatList :: Ord a => [Qualified a] -> Map Domain (Set a) fromFlatList = fmap Set.fromList . indexQualified -newtype CreateConversationUnreachableBackends = CreateConversationUnreachableBackends - { createConvUnreachableBackends :: Set Domain - } - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform CreateConversationUnreachableBackends) - deriving (ToJSON, FromJSON, S.ToSchema) via Schema CreateConversationUnreachableBackends - -instance ToSchema CreateConversationUnreachableBackends where - schema = - objectWithDocModifier - "CreateConversationUnreachableBackends" - (description ?~ "A federated conversation cannot be created because there are unreachable backends") - $ CreateConversationUnreachableBackends - <$> (Set.toList . createConvUnreachableBackends) - .= field "unreachable_backends" (Set.fromList <$> array schema) - -- | Limited view of a 'Conversation'. Is used to inform users with an invite -- link about the conversation. data ConversationCoverView = ConversationCoverView diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index c032c844b48..e701a063790 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -27,13 +27,18 @@ module Wire.API.Error.Galley TeamFeatureError (..), MLSProposalFailure (..), NonFederatingBackends (..), + UnreachableBackends (..), + unreachableUsersToUnreachableBackends, + UnreachableBackendsLegacy (..), ) where import Control.Lens ((%~), (.~), (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Containers.ListUtils import Data.Domain import Data.Proxy +import Data.Qualified import Data.Schema import Data.Singletons.TH (genSingletons) import Data.Swagger qualified as S @@ -41,6 +46,7 @@ import Data.Tagged import GHC.TypeLits import Imports import Network.HTTP.Types.Status qualified as HTTP +import Network.Wai.Utilities.Error qualified as Wai import Network.Wai.Utilities.JSONResponse import Polysemy import Polysemy.Error @@ -51,6 +57,7 @@ import Wire.API.Error.Brig qualified as BrigError import Wire.API.Routes.API import Wire.API.Team.Member import Wire.API.Team.Permission +import Wire.API.Unreachable import Wire.API.Util.Aeson (CustomEncoded (..)) data GalleyError @@ -452,3 +459,66 @@ type instance ErrorEffect NonFederatingBackends = Error NonFederatingBackends instance Member (Error JSONResponse) r => ServerEffect (Error NonFederatingBackends) r where interpretServerEffect = mapError toResponse + +-------------------------------------------------------------------------------- +-- Unreachable backends + +-- | This is returned when adding members to the conversation is not possible +-- because the backends involved do not form a fully connected graph. +data UnreachableBackends = UnreachableBackends {backends :: [Domain]} + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema UnreachableBackends + +instance APIError UnreachableBackends where + toResponse e = + JSONResponse + { status = unreachableBackendsStatus, + value = toJSON e + } + +unreachableBackendsStatus :: HTTP.Status +unreachableBackendsStatus = HTTP.status503 + +instance ToSchema UnreachableBackends where + schema = + object "UnreachableBackends" $ + UnreachableBackends + <$> (.backends) .= field "unreachable_backends" (array schema) + +instance IsSwaggerError UnreachableBackends where + addToSwagger = + addErrorResponseToSwagger (HTTP.statusCode unreachableBackendsStatus) $ + mempty + & S.description .~ "Some domains are unreachable" + & S.schema ?~ S.Inline (S.toSchema (Proxy @UnreachableBackends)) + +type instance ErrorEffect UnreachableBackends = Error UnreachableBackends + +instance Member (Error JSONResponse) r => ServerEffect (Error UnreachableBackends) r where + interpretServerEffect = mapError toResponse + +unreachableUsersToUnreachableBackends :: UnreachableUsers -> UnreachableBackends +unreachableUsersToUnreachableBackends = + UnreachableBackends + . nubOrd + . map qDomain + . toList + . unreachableUsers + +-- | A newtype wrapper to preserve backward compatibility of the error response +-- for older versions. +newtype UnreachableBackendsLegacy = UnreachableBackendsLegacy UnreachableBackends + deriving (IsSwaggerError) + +instance APIError UnreachableBackendsLegacy where + toResponse _ = + toResponse $ + Wai.mkError + unreachableBackendsStatus + "federation-connection-refused" + "Some backends are unreachable" + +type instance ErrorEffect UnreachableBackendsLegacy = Error UnreachableBackendsLegacy + +instance Member (Error JSONResponse) r => ServerEffect (Error UnreachableBackendsLegacy) r where + interpretServerEffect = mapError toResponse 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 780fc9bd5c4..e9d4e7e834f 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -202,12 +202,13 @@ type InternalAPIBase = :> CanThrow 'ConvNotFound :> CanThrow 'InvalidOperation :> CanThrow 'NotConnected + :> CanThrow UnreachableBackends :> ZLocalUser :> ZOptConn :> "conversations" :> "connect" :> ReqBody '[Servant.JSON] Connect - :> ExtendedConversationVerb + :> ConversationVerb ) :<|> Named "guard-legalhold-policy-conflicts" @@ -418,6 +419,7 @@ type IFederationAPI = Named "get-federation-status" ( Summary "Get the federation status (only needed for integration/QA tests at the time of writing it)" + :> CanThrow UnreachableBackends :> ZLocalUser :> "federation-status" :> ReqBody '[Servant.JSON] RemoteDomains diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs index dc7a8ac2b50..ce778e7d62e 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs @@ -47,87 +47,25 @@ import Wire.API.Team.Feature type ConversationResponse = ResponseForExistedCreated Conversation --- | A type similar to 'ConversationResponse' introduced to allow for a failure --- to add remote members while creating a non-group conversation. The type is --- not unified with 'CreateGroupConversationResponse' as that one relies on JSON --- for client API v4, yet 'ExtendedConversationResponse' should work for older --- versions too. -data ExtendedConversationResponse - = ConversationResponseExisted Conversation - | ConversationResponseUnreachableBackends CreateConversationUnreachableBackends - | ConversationResponseCreated Conversation - -instance - ( ResponseType r1 ~ Conversation, - ResponseType r2 ~ CreateConversationUnreachableBackends, - ResponseType r3 ~ Conversation - ) => - AsUnion '[r1, r2, r3] ExtendedConversationResponse - where - toUnion (ConversationResponseExisted x) = Z (I x) - toUnion (ConversationResponseUnreachableBackends x) = S (Z (I x)) - toUnion (ConversationResponseCreated x) = S (S (Z (I x))) - - fromUnion (Z (I x)) = ConversationResponseExisted x - fromUnion (S (Z (I x))) = ConversationResponseUnreachableBackends x - fromUnion (S (S (Z (I x)))) = ConversationResponseCreated x - fromUnion (S (S (S x))) = case x of {} - -type UnreachableBackendsResponse = - Respond - 503 - "Unreachable backends in conversation creation" - CreateConversationUnreachableBackends - --- | JSON of the type is specific to V2 -type ExtendedConversationResponsesV2 = - '[ WithHeaders - ConversationHeaders - Conversation - (VersionedRespond 'V2 200 "Conversation existed" Conversation), - UnreachableBackendsResponse, - WithHeaders - ConversationHeaders - Conversation - (VersionedRespond 'V2 201 "Conversation created" Conversation) - ] - --- | Versioned to the latest API version -type ExtendedConversationResponses = - '[ WithHeaders - ConversationHeaders - Conversation - (Respond 200 "Conversation existed" Conversation), - UnreachableBackendsResponse, - WithHeaders - ConversationHeaders - Conversation - (Respond 201 "Conversation created" Conversation) - ] - -- | A type similar to 'ConversationResponse' introduced to allow for a failure -- to add remote members while creating a conversation or due to involved -- backends forming an incomplete graph. data CreateGroupConversationResponse = GroupConversationExisted Conversation - | GroupConversationUnreachableBackends CreateConversationUnreachableBackends | GroupConversationCreated CreateGroupConversation instance ( ResponseType r1 ~ Conversation, - ResponseType r2 ~ CreateConversationUnreachableBackends, - ResponseType r3 ~ CreateGroupConversation + ResponseType r2 ~ CreateGroupConversation ) => - AsUnion '[r1, r2, r3] CreateGroupConversationResponse + AsUnion '[r1, r2] CreateGroupConversationResponse where toUnion (GroupConversationExisted x) = Z (I x) - toUnion (GroupConversationUnreachableBackends x) = S (Z (I x)) - toUnion (GroupConversationCreated x) = S (S (Z (I x))) + toUnion (GroupConversationCreated x) = S (Z (I x)) fromUnion (Z (I x)) = GroupConversationExisted x - fromUnion (S (Z (I x))) = GroupConversationUnreachableBackends x - fromUnion (S (S (Z (I x)))) = GroupConversationCreated x - fromUnion (S (S (S x))) = case x of {} + fromUnion (S (Z (I x))) = GroupConversationCreated x + fromUnion (S (S x)) = case x of {} type ConversationHeaders = '[DescHeader "Location" "Conversation ID" ConvId] @@ -146,13 +84,6 @@ type ConversationVerb = ] ConversationResponse -type ExtendedConversationVerb = - MultiVerb - 'POST - '[JSON] - ExtendedConversationResponses - ExtendedConversationResponse - type CreateGroupConversationVerb = MultiVerb 'POST @@ -161,7 +92,6 @@ type CreateGroupConversationVerb = ConversationHeaders Conversation (Respond 200 "Conversation existed" Conversation), - UnreachableBackendsResponse, WithHeaders ConversationHeaders CreateGroupConversation @@ -451,17 +381,14 @@ type ConversationAPI = :> CanThrow 'NotATeamMember :> CanThrow OperationDenied :> CanThrow 'MissingLegalholdConsent + :> CanThrow UnreachableBackendsLegacy :> Description "This returns 201 when a new conversation is created, and 200 when the conversation already existed" :> ZLocalUser :> ZOptClient :> ZOptConn :> "conversations" :> VersionedReqBody 'V2 '[Servant.JSON] NewConv - :> MultiVerb - 'POST - '[JSON] - ExtendedConversationResponsesV2 - ExtendedConversationResponse + :> ConversationV2Verb ) :<|> Named "create-group-conversation@v3" @@ -480,13 +407,14 @@ type ConversationAPI = :> CanThrow 'NotATeamMember :> CanThrow OperationDenied :> CanThrow 'MissingLegalholdConsent + :> CanThrow UnreachableBackendsLegacy :> Description "This returns 201 when a new conversation is created, and 200 when the conversation already existed" :> ZLocalUser :> ZOptClient :> ZOptConn :> "conversations" :> ReqBody '[Servant.JSON] NewConv - :> ExtendedConversationVerb + :> ConversationVerb ) :<|> Named "create-group-conversation" @@ -505,6 +433,7 @@ type ConversationAPI = :> CanThrow OperationDenied :> CanThrow 'MissingLegalholdConsent :> CanThrow NonFederatingBackends + :> CanThrow UnreachableBackends :> Description "This returns 201 when a new conversation is created, and 200 when the conversation already existed" :> ZLocalUser :> ZOptClient @@ -566,16 +495,13 @@ type ConversationAPI = :> CanThrow OperationDenied :> CanThrow 'TeamNotFound :> CanThrow 'MissingLegalholdConsent + :> CanThrow UnreachableBackendsLegacy :> ZLocalUser :> ZConn :> "conversations" :> "one2one" :> VersionedReqBody 'V2 '[JSON] NewConv - :> MultiVerb - 'POST - '[JSON] - ExtendedConversationResponsesV2 - ExtendedConversationResponse + :> ConversationV2Verb ) :<|> Named "create-one-to-one-conversation" @@ -591,12 +517,13 @@ type ConversationAPI = :> CanThrow OperationDenied :> CanThrow 'TeamNotFound :> CanThrow 'MissingLegalholdConsent + :> CanThrow UnreachableBackendsLegacy :> ZLocalUser :> ZConn :> "conversations" :> "one2one" :> ReqBody '[JSON] NewConv - :> ExtendedConversationVerb + :> ConversationVerb ) -- This endpoint can lead to the following events being sent: -- - MemberJoin event to members @@ -616,6 +543,7 @@ type ConversationAPI = :> CanThrow 'NotConnected :> CanThrow 'MissingLegalholdConsent :> CanThrow NonFederatingBackends + :> CanThrow UnreachableBackends :> ZLocalUser :> ZConn :> "conversations" @@ -640,6 +568,7 @@ type ConversationAPI = :> CanThrow 'NotConnected :> CanThrow 'MissingLegalholdConsent :> CanThrow NonFederatingBackends + :> CanThrow UnreachableBackends :> ZLocalUser :> ZConn :> "conversations" @@ -665,6 +594,7 @@ type ConversationAPI = :> CanThrow 'NotConnected :> CanThrow 'MissingLegalholdConsent :> CanThrow NonFederatingBackends + :> CanThrow UnreachableBackends :> ZLocalUser :> ZConn :> "conversations" diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs index 8a6d6a9c07a..f026628c4e6 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs @@ -76,6 +76,7 @@ type MLSMessagingAPI = :> CanThrow 'MissingLegalholdConsent :> CanThrow MLSProposalFailure :> CanThrow NonFederatingBackends + :> CanThrow UnreachableBackends :> "messages" :> ZLocalUser :> ZOptClient @@ -111,6 +112,7 @@ type MLSMessagingAPI = :> CanThrow 'MissingLegalholdConsent :> CanThrow MLSProposalFailure :> CanThrow NonFederatingBackends + :> CanThrow UnreachableBackends :> "messages" :> ZLocalUser :> ZOptClient @@ -148,6 +150,7 @@ type MLSMessagingAPI = :> CanThrow 'MissingLegalholdConsent :> CanThrow MLSProposalFailure :> CanThrow NonFederatingBackends + :> CanThrow UnreachableBackends :> "commit-bundles" :> ZLocalUser :> ZOptClient diff --git a/services/brig/docs/swagger.md b/services/brig/docs/swagger.md index 786c380ae58..3a7136a7f6a 100644 --- a/services/brig/docs/swagger.md +++ b/services/brig/docs/swagger.md @@ -49,8 +49,7 @@ For errors that are more likely to be transient, we suggest clients to retry wha **Note**: when a failure occurs as a result of making a federated RPC to another backend, the error response contains the following extra fields: - `type`: "federation" (just the literal string in quotes, which can be used as an error type identifier when parsing errors) - - `domain`: the target backend of the RPC that failed (deprecated in favour for `domains`); - - `domains`: the target backends of the RPC which failed; + - `domain`: the target backend of the RPC that failed; - `path`: the path of the RPC that failed. ### Domain errors @@ -58,7 +57,6 @@ For errors that are more likely to be transient, we suggest clients to retry wha Errors in this category result from trying to communicate with a backend that is considered non-existent or invalid. They can result from invalid user input or client issues, but they can also be a symptom of misconfiguration in one or multiple backends. These errors have a 4xx status code. - **Remote backend not found** (status: 422, label: `invalid-domain`): This backend attempted to contact a backend which does not exist or is not properly configured. For the most part, clients can consider this error equivalent to a domain not existing, although it should be noted that certain mistakes in the DNS configuration on a remote backend can lead to the backend not being recognized, and hence to this error. It is therefore not advisable to take any destructive action upon encountering this error, such as deleting remote users from conversations. - - **Remote backend unreachable** (status: 503, label: `federation-unreachable-domains-error`): Similar to `invalid-domain`. - **Federation denied locally** (status: 400, label: `federation-denied`): This backend attempted an RPC to a non-whitelisted backend. Similar considerations as for the previous error apply. - **Federation not enabled** (status: 400, label: `federation-not-enabled`): Federation has not been configured for this backend. This will happen if a federation-aware client tries to talk to a backend for which federation is disabled, or if federation was disabled on the backend after reaching a federation-specific state (e.g. conversations with remote users). There is no way to cleanly recover from these errors at this point. diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 1a84159f12f..73f97184b83 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -64,7 +64,6 @@ import Data.Time (UTCTime, getCurrentTime) import Data.Time.Clock (diffUTCTime) import Data.UUID qualified as UUID import Data.UUID.V4 qualified as UUID -import Data.Vector qualified as V import Federator.MockServer (FederatedRequest (..), MockException (..)) import Imports hiding (head) import Imports qualified @@ -634,8 +633,8 @@ testUserInvalidDomain brig = do const 422 === statusCode const (Just "/federation/api-version") === preview (ix "data" . ix "path") . responseJsonUnsafe @Value - const (Just (Array (V.fromList ["invalid.example.com"]))) - === preview (ix "data" . ix "domains") . responseJsonUnsafe @Value + const (Just "invalid.example.com") + === preview (ix "data" . ix "domain") . responseJsonUnsafe @Value testExistingUserUnqualified :: Brig -> Http () testExistingUserUnqualified brig = do diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index f4fed63c7b0..6497d4bcfe3 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -40,6 +40,7 @@ module Galley.API.Action addLocalUsersToRemoteConv, ConversationUpdate, getFederationStatus, + checkFederationStatus, firstConflictOrFullyConnected, ) where @@ -131,6 +132,7 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con Member (ErrorS 'TooManyMembers) r, Member (ErrorS 'MissingLegalholdConsent) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, @@ -264,10 +266,29 @@ type family HasConversationActionGalleyErrors (tag :: ConversationActionTag) :: ErrorS 'ConvNotFound ] -getFederationStatus :: Member FederatorAccess r => Local UserId -> RemoteDomains -> Sem r FederationStatus -getFederationStatus _ req = do - firstConflictOrFullyConnected - <$> E.runFederatedConcurrently +checkFederationStatus :: + ( Member (Error UnreachableBackends) r, + Member (Error NonFederatingBackends) r, + Member FederatorAccess r + ) => + RemoteDomains -> + Sem r () +checkFederationStatus req = do + status <- getFederationStatus req + case status of + FullyConnected -> pure () + NotConnectedDomains dom1 dom2 -> throw (NonFederatingBackends dom1 dom2) + +getFederationStatus :: + ( Member (Error UnreachableBackends) r, + Member FederatorAccess r + ) => + RemoteDomains -> + Sem r FederationStatus +getFederationStatus req = do + fmap firstConflictOrFullyConnected + . (ensureNoUnreachableBackends =<<) + $ E.runFederatedConcurrentlyEither (flip toRemoteUnsafe () <$> Set.toList req.rdDomains) (\qds -> fedClient @'Brig @"get-not-fully-connected-backends" (DomainSet (tDomain qds `Set.delete` req.rdDomains))) @@ -424,9 +445,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do Sem r () checkRemoteBackendsConnected lusr = do let remoteDomains = tDomain <$> snd (partitionQualified lusr $ NE.toList invited) - getFederationStatus lusr (RemoteDomains $ Set.fromList remoteDomains) >>= \case - NotConnectedDomains a b -> throw (NonFederatingBackends a b) - FullyConnected -> pure () + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) conv :: Data.Conversation conv = tUnqualified lconv @@ -806,7 +825,6 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do (_, FederationNotConfigured) -> pure () (_, FederationUnexpectedBody _) -> pure () (_, FederationUnexpectedError _) -> pure () - (_, ex@(FederationUnreachableDomainsOld _)) -> throw ex updates <- E.runFederatedConcurrentlyEither (toList (bmRemotes targets)) $ \ruids -> do diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 555b72ba734..c786ae1ab9a 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -32,7 +32,6 @@ module Galley.API.Create where import Control.Lens hiding ((??)) -import Data.Domain import Data.Id import Data.List1 (list1) import Data.Misc (FutureWork (FutureWork)) @@ -104,6 +103,7 @@ createGroupConversationUpToV3 :: Member (ErrorS 'MLSNonEmptyMemberList) r, Member (ErrorS 'MLSMissingSenderClient) r, Member (ErrorS 'MissingLegalholdConsent) r, + Member (Error UnreachableBackendsLegacy) r, Member FederatorAccess r, Member GundeckAccess r, Member (Input Env) r, @@ -117,14 +117,16 @@ createGroupConversationUpToV3 :: Maybe ClientId -> Maybe ConnId -> NewConv -> - Sem r ExtendedConversationResponse -createGroupConversationUpToV3 lusr mCreatorClient conn newConv = - createGroupConversationGeneric - lusr - mCreatorClient - conn - newConv - (\_ds lu conv -> toExtended <$> conversationCreated lu conv) + Sem r ConversationResponse +createGroupConversationUpToV3 lusr mCreatorClient conn newConv = mapError UnreachableBackendsLegacy $ + do + conv <- + createGroupConversationGeneric + lusr + mCreatorClient + conn + newConv + conversationCreated lusr conv -- | The public-facing endpoint for creating group conversations in the client -- API in version 4 and above. @@ -144,6 +146,7 @@ createGroupConversation :: Member (ErrorS 'MLSNonEmptyMemberList) r, Member (ErrorS 'MLSMissingSenderClient) r, Member (ErrorS 'MissingLegalholdConsent) r, + Member (Error UnreachableBackends) r, Member FederatorAccess r, Member GundeckAccess r, Member (Input Env) r, @@ -160,15 +163,16 @@ createGroupConversation :: Sem r CreateGroupConversationResponse createGroupConversation lusr mCreatorClient conn newConv = do let remoteDomains = tDomain <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) - getFederationStatus lusr (RemoteDomains $ Set.fromList remoteDomains) >>= \case - NotConnectedDomains rd1 rd2 -> throw $ NonFederatingBackends rd1 rd2 - FullyConnected -> - createGroupConversationGeneric - lusr - mCreatorClient - conn - newConv - groupConversationCreated + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) + cnv <- + createGroupConversationGeneric + lusr + mCreatorClient + conn + newConv + conv <- conversationView lusr cnv + pure . GroupConversationCreated $ + CreateGroupConversation conv mempty createGroupConversationGeneric :: ( Member BrigAccess r, @@ -185,6 +189,7 @@ createGroupConversationGeneric :: Member (ErrorS 'MLSNonEmptyMemberList) r, Member (ErrorS 'MLSMissingSenderClient) r, Member (ErrorS 'MissingLegalholdConsent) r, + Member (Error UnreachableBackends) r, Member FederatorAccess r, Member GundeckAccess r, Member (Input Env) r, @@ -198,12 +203,8 @@ createGroupConversationGeneric :: Maybe ClientId -> Maybe ConnId -> NewConv -> - -- | The function that incorporates unreachable backends in the response. In - -- the client API up to and including V3 this function simply ignores the - -- first argument. - (Set Domain -> Local UserId -> Conversation -> Sem r resp) -> - Sem r resp -createGroupConversationGeneric lusr mCreatorClient conn newConv convRespond = do + Sem r Conversation +createGroupConversationGeneric lusr mCreatorClient conn newConv = do (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv let tinfo = newConvTeam newConv checkCreateConvPermissions lusr newConv tinfo allUsers @@ -230,17 +231,9 @@ createGroupConversationGeneric lusr mCreatorClient conn newConv convRespond = do (ProtocolMLS _mlsMeta, Nothing) -> throwS @'MLSMissingSenderClient -- NOTE: We only send (conversation) events to members of the conversation - runError @UnreachableBackendsError - (notifyCreatedConversation lusr conn conv) - >>= \case - Left (UnreachableBackendsError ds) -> do - E.deleteConversation . Data.convId $ conv - convRespond ds lusr conv - Right () -> do - c <- - E.getConversation (tUnqualified lcnv) - >>= note (BadConvState (tUnqualified lcnv)) - convRespond Set.empty lusr c + notifyCreatedConversation lusr conn conv + E.getConversation (tUnqualified lcnv) + >>= note (BadConvState (tUnqualified lcnv)) ensureNoLegalholdConflicts :: ( Member (ErrorS 'MissingLegalholdConsent) r, @@ -323,7 +316,6 @@ createProteusSelfConversation lusr = do conversationCreated lusr c createOne2OneConversation :: - forall r. ( Member BrigAccess r, Member ConversationStore r, Member (Error FederationError) r, @@ -336,6 +328,7 @@ createOne2OneConversation :: Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotConnected) r, + Member (Error UnreachableBackendsLegacy) r, Member FederatorAccess r, Member GundeckAccess r, Member (Input UTCTime) r, @@ -345,32 +338,46 @@ createOne2OneConversation :: Local UserId -> ConnId -> NewConv -> - Sem r ExtendedConversationResponse -createOne2OneConversation lusr zcon j = do - let allUsers = newConvMembers lusr j - other <- ensureOne (ulAll lusr allUsers) - when (tUntagged lusr == other) $ - throwS @'InvalidOperation - mtid <- case newConvTeam j of - Just ti -> do - foldQualified - lusr - (\lother -> checkBindingTeamPermissions lother (cnvTeamId ti)) - (const (pure Nothing)) - other - Nothing -> ensureConnected lusr allUsers $> Nothing - foldQualified - lusr - (fmap toExtended <$> createLegacyOne2OneConversationUnchecked lusr zcon (newConvName j) mtid) - (createOne2OneConversationUnchecked lusr zcon (newConvName j) mtid . tUntagged) - other + Sem r ConversationResponse +createOne2OneConversation lusr zcon j = + mapError @UnreachableBackends @UnreachableBackendsLegacy UnreachableBackendsLegacy $ do + let allUsers = newConvMembers lusr j + other <- ensureOne (ulAll lusr allUsers) + when (tUntagged lusr == other) $ + throwS @'InvalidOperation + mtid <- case newConvTeam j of + Just ti -> do + foldQualified + lusr + (\lother -> checkBindingTeamPermissions lother (cnvTeamId ti)) + (const (pure Nothing)) + other + Nothing -> ensureConnected lusr allUsers $> Nothing + foldQualified + lusr + (createLegacyOne2OneConversationUnchecked lusr zcon (newConvName j) mtid) + (createOne2OneConversationUnchecked lusr zcon (newConvName j) mtid . tUntagged) + other where - verifyMembership :: TeamId -> UserId -> Sem r () + verifyMembership :: + ( Member (ErrorS 'NoBindingTeamMembers) r, + Member TeamStore r + ) => + TeamId -> + UserId -> + Sem r () verifyMembership tid u = do membership <- E.getTeamMember tid u when (isNothing membership) $ throwS @'NoBindingTeamMembers checkBindingTeamPermissions :: + ( Member (ErrorS 'NoBindingTeamMembers) r, + Member (ErrorS 'NonBindingTeam) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamStore r + ) => Local UserId -> TeamId -> Sem r (Maybe TeamId) @@ -420,10 +427,9 @@ createLegacyOne2OneConversationUnchecked self zcon name mtid other = do Just c -> conversationExisted self c Nothing -> do c <- E.createConversation lcnv nc - runError @UnreachableBackendsError (notifyCreatedConversation self (Just zcon) c) + runError @UnreachableBackends (notifyCreatedConversation self (Just zcon) c) >>= \case - Left (UnreachableBackendsError _) -> do - E.deleteConversation (Data.convId c) + Left _ -> do throw . InternalErrorWithDescription $ "A one-to-one conversation on one backend cannot involve unreachable backends" Right () -> conversationCreated self c @@ -432,6 +438,7 @@ createOne2OneConversationUnchecked :: ( Member ConversationStore r, Member (Error FederationError) r, Member (Error InternalError) r, + Member (Error UnreachableBackends) r, Member FederatorAccess r, Member GundeckAccess r, Member (Input UTCTime) r, @@ -442,7 +449,7 @@ createOne2OneConversationUnchecked :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Sem r ExtendedConversationResponse + Sem r ConversationResponse createOne2OneConversationUnchecked self zcon name mtid other = do let create = foldQualified @@ -455,6 +462,7 @@ createOne2OneConversationLocally :: ( Member ConversationStore r, Member (Error FederationError) r, Member (Error InternalError) r, + Member (Error UnreachableBackends) r, Member FederatorAccess r, Member GundeckAccess r, Member (Input UTCTime) r, @@ -466,11 +474,11 @@ createOne2OneConversationLocally :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Sem r ExtendedConversationResponse + Sem r ConversationResponse createOne2OneConversationLocally lcnv self zcon name mtid other = do mc <- E.getConversation (tUnqualified lcnv) case mc of - Just c -> toExtended <$> conversationExisted self c + Just c -> conversationExisted self c Nothing -> do let meta = (defConversationMetadata (tUnqualified self)) @@ -485,15 +493,8 @@ createOne2OneConversationLocally lcnv self zcon name mtid other = do ncProtocol = ProtocolProteusTag } c <- E.createConversation lcnv nc - runError @UnreachableBackendsError (notifyCreatedConversation self (Just zcon) c) - >>= \case - Left (UnreachableBackendsError ds) -> do - E.deleteConversation (Data.convId c) - pure - . ConversationResponseUnreachableBackends - . CreateConversationUnreachableBackends - $ ds - Right () -> toExtended <$> conversationCreated self c + notifyCreatedConversation self (Just zcon) c + conversationCreated self c createOne2OneConversationRemotely :: Member (Error FederationError) r => @@ -503,7 +504,7 @@ createOne2OneConversationRemotely :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Sem r ExtendedConversationResponse + Sem r ConversationResponse createOne2OneConversationRemotely _ _ _ _ _ _ = throw FederationNotImplemented @@ -514,6 +515,7 @@ createConnectConversation :: Member (Error InternalError) r, Member (Error InvalidInput) r, Member (ErrorS 'InvalidOperation) r, + Member (Error UnreachableBackends) r, Member FederatorAccess r, Member GundeckAccess r, Member (Input UTCTime) r, @@ -523,7 +525,7 @@ createConnectConversation :: Local UserId -> Maybe ConnId -> Connect -> - Sem r ExtendedConversationResponse + Sem r ConversationResponse createConnectConversation lusr conn j = do lrecipient <- ensureLocal lusr (cRecipient j) n <- rangeCheckedMaybe (cName j) @@ -548,24 +550,16 @@ createConnectConversation lusr conn j = do c <- E.createConversation lcnv nc now <- input let e = Event (tUntagged lcnv) Nothing (tUntagged lusr) now (EdConnect j) - runError @UnreachableBackendsError (notifyCreatedConversation lusr conn c) - >>= \case - Left (UnreachableBackendsError ds) -> do - E.deleteConversation (Data.convId c) - pure - . ConversationResponseUnreachableBackends - . CreateConversationUnreachableBackends - $ ds - Right () -> do - for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> - E.push1 $ - p - & pushRoute .~ RouteDirect - & pushConn .~ conn - toExtended <$> conversationCreated lusr c + notifyCreatedConversation lusr conn c + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> + E.push1 $ + p + & pushRoute .~ RouteDirect + & pushConn .~ conn + conversationCreated lusr c update n conv = do let mems = Data.convLocalMembers conv - in fmap toExtended . conversationExisted lusr + in conversationExisted lusr =<< if tUnqualified lusr `isMember` mems then -- we already were in the conversation, maybe also other connect n conv @@ -645,10 +639,6 @@ newRegularConversation lusr newConv = do ------------------------------------------------------------------------------- -- Helpers -toExtended :: ConversationResponse -> ExtendedConversationResponse -toExtended (Existed c) = ConversationResponseExisted c -toExtended (Created c) = ConversationResponseCreated c - conversationCreated :: ( Member (Error InternalError) r, Member P.TinyLog r @@ -658,34 +648,15 @@ conversationCreated :: Sem r ConversationResponse conversationCreated lusr cnv = Created <$> conversationView lusr cnv -groupConversationCreated :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Set Domain -> - Local UserId -> - Data.Conversation -> - Sem r CreateGroupConversationResponse -groupConversationCreated ds lusr cnv = do - if Set.null ds - then do - conv <- conversationView lusr cnv - pure . GroupConversationCreated $ - CreateGroupConversation conv mempty - else - pure - . GroupConversationUnreachableBackends - . CreateConversationUnreachableBackends - $ ds - -- | The return set contains all the remote users that could not be contacted. -- Consequently, the unreachable users are not added to the member list. This -- behavior might be changed later on when a message/event queue per remote -- backend is implemented. notifyCreatedConversation :: - ( Member (Error FederationError) r, + ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, - Member (Error UnreachableBackendsError) r, + Member (Error UnreachableBackends) r, Member FederatorAccess r, Member GundeckAccess r, Member (Input UTCTime) r, diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index c55c39e8443..c1a475c6a54 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -259,15 +259,14 @@ leaveConversation requestingDomain lc = do Nothing () case outcome of - Left e@(FederationUnreachableDomainsOld _) -> throw e Left e -> do logFederationError lcnv e throw . internalErr $ e - Right update -> pure (update, conv) + Right _ -> pure conv case res of Left e -> pure $ F.LeaveConversationResponse (Left e) - Right (_update, conv) -> do + Right conv -> do let remotes = filter ((== qDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) let botsAndMembers = BotsAndMembers mempty (Set.fromList remotes) mempty do @@ -282,7 +281,6 @@ leaveConversation requestingDomain lc = do botsAndMembers () case outcome of - Left e@(FederationUnreachableDomainsOld _) -> throw e Left e -> do logFederationError lcnv e throw . internalErr $ e @@ -421,7 +419,6 @@ onUserDeleted origDomain udcn = do botsAndMembers () case outcome of - Left e@(FederationUnreachableDomainsOld _) -> throw e Left e -> logFederationError lc e Right _ -> pure () pure EmptyResponse @@ -510,13 +507,16 @@ updateConversation origDomain updateRequest = do . runError @NoChanges . fmap (either F.ConversationUpdateResponseNonFederatingBackends id) . runError @NonFederatingBackends + . fmap (either F.ConversationUpdateResponseUnreachableBackends id) + . runError @UnreachableBackends . fmap F.ConversationUpdateResponseUpdate handleMLSMessageErrors :: ( r1 ~ Append MLSBundleStaticErrors - ( Error NonFederatingBackends + ( Error UnreachableBackends + ': Error NonFederatingBackends ': Error MLSProposalFailure ': Error GalleyError ': Error MLSProtocolError @@ -534,6 +534,8 @@ handleMLSMessageErrors = . runError . fmap (either F.MLSMessageResponseNonFederatingBackends id) . runError + . fmap (either (F.MLSMessageResponseUnreachableBackends . Set.fromList . (.backends)) id) + . runError @UnreachableBackends . mapToGalleyError @MLSBundleStaticErrors sendMLSCommitBundle :: diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index c7445c57393..dc4176dc049 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -133,7 +133,7 @@ internalAPI = federationAPI :: API IFederationAPI GalleyEffects federationAPI = - mkNamedAPI @"get-federation-status" getFederationStatus + mkNamedAPI @"get-federation-status" (const getFederationStatus) legalholdWhitelistedTeamsAPI :: API ILegalholdWhitelistedTeamsAPI GalleyEffects legalholdWhitelistedTeamsAPI = mkAPI $ \tid -> hoistAPIHandler id (base tid) diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 9e97a5c8909..c8509d199e6 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -141,6 +141,7 @@ postMLSMessageFromLocalUserV1 :: Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MLSUnsupportedMessage) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member (Input (Local ())) r, Member ProposalStore r, Member Resource r, @@ -178,6 +179,7 @@ postMLSMessageFromLocalUser :: Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MLSUnsupportedMessage) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member (Input (Local ())) r, Member ProposalStore r, Member Resource r, @@ -206,6 +208,7 @@ postMLSCommitBundle :: Members MLSBundleStaticErrors r, Member (Error FederationError) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member Resource r ) => Local x -> @@ -227,6 +230,7 @@ postMLSCommitBundleFromLocalUser :: Members MLSBundleStaticErrors r, Member (Error FederationError) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member Resource r ) => Local UserId -> @@ -247,8 +251,8 @@ postMLSCommitBundleFromLocalUser lusr mc conn bundle = do postMLSCommitBundleToLocalConv :: ( HasProposalEffects r, Members MLSBundleStaticErrors r, - Member (Error FederationError) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member Resource r ) => Qualified UserId -> @@ -295,8 +299,8 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do ApplicationMessage _ -> throwS @'MLSUnsupportedMessage ProposalMessage _ -> throwS @'MLSUnsupportedMessage - propagateMessage qusr (qualifyAs lcnv conv) cm conn (rmRaw (cbCommitMsg bundle)) - >>= mapM_ throwUnreachableUsers + mUnreachables <- propagateMessage qusr (qualifyAs lcnv conv) cm conn (rmRaw (cbCommitMsg bundle)) + traverse_ (throw . unreachableUsersToUnreachableBackends) mUnreachables for_ (cbWelcome bundle) $ postMLSWelcome lcnv conn @@ -311,6 +315,7 @@ postMLSCommitBundleToRemoteConv :: Member (Error MLSProtocolError) r, Member (Error MLSProposalFailure) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, @@ -341,7 +346,7 @@ postMLSCommitBundleToRemoteConv loc qusr con bundle rcnv = do MLSMessageResponseError e -> rethrowErrors @MLSBundleStaticErrors e MLSMessageResponseProtocolError e -> throw (mlsProtocolError e) MLSMessageResponseProposalFailure e -> throw (MLSProposalFailure e) - MLSMessageResponseUnreachableBackends ds -> throwUnreachableDomains ds + MLSMessageResponseUnreachableBackends ds -> throw (UnreachableBackends (toList ds)) MLSMessageResponseUpdates updates unreachables -> do for_ unreachables $ \us -> throw . InternalErrorWithDescription $ @@ -373,6 +378,7 @@ postMLSMessage :: Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MLSUnsupportedMessage) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member (Input (Local ())) r, Member ProposalStore r, Member Resource r, @@ -454,6 +460,7 @@ postMLSMessageToLocalConv :: Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MLSUnsupportedMessage) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member ProposalStore r, Member Resource r, Member TinyLog r @@ -621,6 +628,7 @@ processCommit :: Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MissingLegalholdConsent) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member Resource r ) => Qualified UserId -> @@ -756,6 +764,7 @@ processCommitWithAction :: Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MissingLegalholdConsent) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member Resource r ) => Qualified UserId -> @@ -785,6 +794,7 @@ processInternalCommit :: Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MissingLegalholdConsent) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member Resource r ) => Qualified UserId -> @@ -1094,6 +1104,7 @@ executeProposalAction :: Member (ErrorS 'MLSUnsupportedProposal) r, Member (ErrorS 'MLSSelfRemovalNotAllowed) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 19e2419541e..5f6ce8382e9 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -328,8 +328,9 @@ updateConversationReceiptMode :: ConversationReceiptModeUpdate -> Sem r (UpdateResult Event) updateConversationReceiptMode lusr zcon qcnv update = - mapError @NonFederatingBackends @InternalError (\_ -> InternalErrorWithDescription "Unexpected NonFederatingBackends error when updating remote receipt mode") $ - foldQualified + mapError @UnreachableBackends @InternalError (\_ -> InternalErrorWithDescription "Unexpected UnreachableBackends error when updating remote receipt mode") + . mapError @NonFederatingBackends @InternalError (\_ -> InternalErrorWithDescription "Unexpected NonFederatingBackends error when updating remote receipt mode") + $ foldQualified lusr ( \lcnv -> getUpdateResult . fmap lcuEvent $ @@ -353,6 +354,7 @@ updateRemoteConversation :: Member MemberStore r, Member TinyLog r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, RethrowErrors (HasConversationActionGalleyErrors tag) (Error NoChanges : r), SingI tag ) => @@ -374,6 +376,7 @@ updateRemoteConversation rcnv lusr conn action = getUpdateResult $ do ConversationUpdateResponseError err' -> rethrowErrors @(HasConversationActionGalleyErrors tag) err' ConversationUpdateResponseUpdate convUpdate -> pure convUpdate ConversationUpdateResponseNonFederatingBackends e -> throw e + ConversationUpdateResponseUnreachableBackends e -> throw e updateLocalStateOfRemoteConv (qualifyAs rcnv convUpdate) (Just conn) >>= note NoChanges updateConversationReceiptModeUnqualified :: @@ -788,6 +791,7 @@ addMembers :: Member (ErrorS 'MissingLegalholdConsent) r, Member (Error FederationError) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, @@ -826,6 +830,7 @@ addMembersUnqualifiedV2 :: Member (ErrorS 'TooManyMembers) r, Member (ErrorS 'MissingLegalholdConsent) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, @@ -864,6 +869,7 @@ addMembersUnqualified :: Member (ErrorS 'TooManyMembers) r, Member (ErrorS 'MissingLegalholdConsent) r, Member (Error NonFederatingBackends) r, + Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 67e38d1db9e..7dfa122432f 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -751,52 +751,50 @@ fromConversationCreated loc rc@ConversationCreated {..} = (ConvMembers this others) ProtocolProteus +ensureNoUnreachableBackends :: + Member (Error UnreachableBackends) r => + [Either (Remote e, b) a] -> + Sem r [a] +ensureNoUnreachableBackends results = do + let (errors, values) = partitionEithers results + unless (null errors) $ + throw (UnreachableBackends (map (tDomain . fst) errors)) + pure values + -- | Notify remote users of being added to a new conversation. In case a remote -- domain is unreachable, an exception is thrown, the conversation deleted and -- the client gets an error response. registerRemoteConversationMemberships :: - ( Member (Error UnreachableBackendsError) r, + ( Member ConversationStore r, + Member (Error UnreachableBackends) r, Member FederatorAccess r ) => -- | The time stamp when the conversation was created UTCTime -> Local Data.Conversation -> Sem r () -registerRemoteConversationMemberships now lc = do +registerRemoteConversationMemberships now lc = deleteOnUnreachable $ do let c = tUnqualified lc rc = toConversationCreated now c - allRemoteMembers = nubOrd {- (but why would there be duplicates?) -} (Data.convRemoteMembers c) allRemoteMembersQualified = remoteMemberQualify <$> allRemoteMembers allRemoteBuckets :: [Remote [RemoteMember]] = bucketRemote allRemoteMembersQualified - do - -- ping involved remote backends - unreachableBackends <- fmap (foldMap (either (pure . tDomain . fst) mempty)) $ - runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ -> - void $ fedClient @'Brig @"api-version" () - -- abort if there are unreachable backends - unless (null unreachableBackends) - . throw - . UnreachableBackendsError - . Set.fromList - $ unreachableBackends - - do + -- ping involved remote backends + void . (ensureNoUnreachableBackends =<<) $ + runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ -> + void $ fedClient @'Brig @"api-version" () + + void . (ensureNoUnreachableBackends =<<) $ -- let remote backends know about a subset of new joiners - failedToNotify :: Set Domain <- fmap (Set.fromList . foldMap (either (pure . tDomain . fst) mempty)) $ - runFederatedConcurrentlyEither allRemoteMembersQualified $ - \rrms -> - fedClient @'Galley @"on-conversation-created" - ( rc - { ccNonCreatorMembers = - toMembers (tUnqualified rrms) - } - ) - unless (null failedToNotify) - . throw - . UnreachableBackendsError - $ failedToNotify + runFederatedConcurrentlyEither allRemoteMembersQualified $ + \rrms -> + fedClient @'Galley @"on-conversation-created" + ( rc + { ccNonCreatorMembers = + toMembers (tUnqualified rrms) + } + ) -- reachable members in buckets per remote domain let joined :: [Remote [RemoteMember]] = allRemoteBuckets @@ -812,16 +810,10 @@ registerRemoteConversationMemberships now lc = do ) joined - do + void . (ensureNoUnreachableBackends =<<) $ -- Send an update to remotes about the final list of participants - failedToUpdate :: Set Domain <- - fmap (Set.fromList . foldMap (either (pure . tDomain . fst) mempty)) $ - runFederatedConcurrentlyBucketsEither joinedCoupled $ - fedClient @'Galley @"on-conversation-updated" . convUpdateJoin - unless (null failedToUpdate) - . throw - . UnreachableBackendsError - $ failedToUpdate + runFederatedConcurrentlyBucketsEither joinedCoupled $ + fedClient @'Galley @"on-conversation-updated" . convUpdateJoin where creator :: UserId creator = cnvmCreator . DataTypes.convMetadata . tUnqualified $ lc @@ -853,6 +845,16 @@ registerRemoteConversationMemberships now lc = do (ConversationJoin (tUntagged <$> newMembers) roleNameWireMember) } + deleteOnUnreachable :: + ( Member ConversationStore r, + Member (Error UnreachableBackends) r + ) => + Sem r a -> + Sem r a + deleteOnUnreachable m = catch @UnreachableBackends m $ \e -> do + deleteConversation (DataTypes.convId (tUnqualified lc)) + throw e + -------------------------------------------------------------------------------- -- Legalhold diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 6b1f1e84b94..65c66c54f37 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -44,7 +44,7 @@ import Bilge qualified import Bilge.Assert import Control.Concurrent.Async qualified as Async import Control.Exception (throw) -import Control.Lens (at, ix, preview, view, (.~), (?~)) +import Control.Lens (at, view, (.~), (?~)) import Control.Monad.Trans.Maybe import Data.Aeson hiding (json) import Data.ByteString qualified as BS @@ -66,7 +66,6 @@ import Data.Singletons import Data.Text qualified as T import Data.Text.Ascii qualified as Ascii import Data.Time.Clock (getCurrentTime) -import Data.Vector qualified as V import Federator.Discovery (DiscoveryFailure (..)) import Federator.MockServer import Galley.API.Mapping @@ -90,6 +89,7 @@ import Wire.API.Conversation.Code hiding (Value) import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Conversation.Typing +import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Brig @@ -2340,7 +2340,8 @@ postConvQualifiedNonExistentDomain = do postConvQualifiedFederationNotEnabled :: TestM () postConvQualifiedFederationNotEnabled = do alice <- randomUser - bob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId + let domain = Domain "some-remote-backend.example.com" + bob <- flip Qualified domain <$> randomId connectWithRemoteUser alice bob let federatorNotConfigured o = o @@ -2348,9 +2349,11 @@ postConvQualifiedFederationNotEnabled = do & optRabbitmq .~ Nothing withSettingsOverrides federatorNotConfigured $ do g <- viewGalley - postConvHelper g alice [bob] !!! do - const 400 === statusCode - const (Just "federation-not-enabled") === fmap label . responseJsonUnsafe + unreachable :: UnreachableBackends <- + responseJsonError + =<< postConvHelper g alice [bob] postConv alice [] (Just "remote gossip") [] Nothing Nothing localDomain <- viewFederationDomain let qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob - postQualifiedMembers alice (remoteBob :| []) qconvId - !!! do - const 422 === statusCode - const (Just (Array (V.fromList ["invalid.example.com"]))) - === preview (ix "data" . ix "domains") . responseJsonUnsafe @Value + e :: UnreachableBackends <- + responseJsonError + =<< postQualifiedMembers alice (remoteBob :| []) qconvId + randomId + let domain = Domain "some-remote-backend.example.com" + remoteBob <- flip Qualified domain <$> randomId qconvId <- decodeQualifiedConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing connectWithRemoteUser alice remoteBob -- federator endpoint being configured in brig and/or galley, but not being -- available (i.e. no service listing on that IP/port) can happen due to a - -- misconfiguration of federator. That should give a 500. + -- misconfiguration of federator. That should give an unreachable_backends error. -- Port 1 should always be wrong hopefully. let federatorUnavailable = optFederator ?~ Endpoint "127.0.0.1" 1 - withSettingsOverrides federatorUnavailable $ - postQualifiedMembers alice (remoteBob :| []) qconvId !!! do - const 500 === statusCode - const (Right "federation-not-available") === fmap label . responseJsonEither + withSettingsOverrides federatorUnavailable $ do + e :: UnreachableBackends <- + responseJsonError + =<< postQualifiedMembers alice (remoteBob :| []) qconvId assertFailure "Expected ConversationUpdateResponseUpdate but got ConversationUpdateResponseNoChanges" ConversationUpdateResponseUpdate up -> pure up ConversationUpdateResponseNonFederatingBackends _ -> assertFailure "Expected ConversationUpdateResponseUpdate but got ConversationUpdateResponseNonFederatingBackends" + ConversationUpdateResponseUnreachableBackends _ -> assertFailure "Expected ConversationUpdateResponseUpdate but got ConversationUpdateResponseUnreachableBackends" liftIO $ do cuOrigUserId cnvUpdate' @?= qbob