-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

-- | Map federation errors to client-facing errors.
--
-- This module contains most of the error-mapping logic that turns the various
-- possible errors that can occur while making a federated request into errors
-- that are meaningful for the clients.
--
-- There are three types of errors, from lowest level to highest:
--
--  * 'FederatorClientHTTP2Error': this is thrown when something fails while
--     connecting or making a request to the local federator.
--  * 'FederatorClientError': this is the most common type of error,
--     corresponding to a failure at the level of the federator client. It
--     includes, for example, a failure to reach a remote federator, or an
--     error on the remote side.
--  * 'FederationError': this is created by users of the federator client. It
--     can either wrap a 'FederatorClientError', or be an error that is outside
--     the scope of the client, such as when a federated request succeeds with
--     an unexpected result.
--
-- A general federated request is normally performed as a chain of HTTP
-- requests (some of which are HTTP2). Errors can occur at each node of the
-- chain, as well as in the communication between two adjacent nodes. A
-- successful request goes through the following stages:
--
--  1) a service (say brig) makes a request to (the outward service of) the
--     local federator (HTTP2);
--  2) the local federator processes this request;
--  3) the local federator makes a request to (the inward service of) a remote
--     one (HTTP2);
--  4) the remote federator processes this request;
--  5) from the remote federator to a service on that backend (HTTP);
--  6) the remote service processes this request.
--
-- Failures at step 1 in the chain result in 'FederatorClientHTTP2Error', while
-- any other failure results in a 'FederatorClientError'.
--
-- Immediate failures in the outward service of a federator (stage 2) result in
-- a 403 status code being returned to the federator client, which is then
-- translated into an error with label federation-local-error.
--
-- Failures which occurred while making a request to a remote federator (stages
-- 3 to 6) are turned into 5xx errors by federator itself, and then passed on
-- through without any further mapping. This includes issues in stage 4,
-- which are seen by the local federator as 403 status codes returned by the
-- remote, as well as arbitrary error codes returned by a service.
--
-- Note that the federation API follows the convention that any error should be
-- returned as part of a successful response with status code 200. Therefore any
-- 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
  ( -- * Federation errors
    FederatorClientHTTP2Error (..),
    FederatorClientError (..),
    FederationError (..),
    VersionNegotiationError (..),
    federationErrorToWai,
    federationRemoteHTTP2Error,
    federationRemoteResponseError,
    federationNotImplemented,
    federationNotConfigured,

    -- * Error status codes
    unexpectedFederationResponseStatus,
    federatorConnectionRefusedStatus,
  )
where

import Data.Aeson qualified as Aeson
import Data.Domain
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Encoding.Error qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Encoding qualified as LT
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 qualified as Wai
import OpenSSL.Session (SomeSSLException)
import Servant.Client
import Wire.API.Error
import Wire.Network.DNS.SRV

-- | Transport-layer errors in federator client.
data FederatorClientHTTP2Error
  = FederatorClientNoStatusCode
  | FederatorClientHTTP2Exception HTTP2.HTTP2Error
  | FederatorClientTLSException SomeSSLException
  | FederatorClientConnectionError IOException
  deriving (Int -> FederatorClientHTTP2Error -> ShowS
[FederatorClientHTTP2Error] -> ShowS
FederatorClientHTTP2Error -> String
(Int -> FederatorClientHTTP2Error -> ShowS)
-> (FederatorClientHTTP2Error -> String)
-> ([FederatorClientHTTP2Error] -> ShowS)
-> Show FederatorClientHTTP2Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FederatorClientHTTP2Error -> ShowS
showsPrec :: Int -> FederatorClientHTTP2Error -> ShowS
$cshow :: FederatorClientHTTP2Error -> String
show :: FederatorClientHTTP2Error -> String
$cshowList :: [FederatorClientHTTP2Error] -> ShowS
showList :: [FederatorClientHTTP2Error] -> ShowS
Show, Typeable)

instance Exception FederatorClientHTTP2Error

-- | Possible errors resulting from a use of the federator client.
data FederatorClientError
  = -- | An error that occurred when establishing a connection to or
    -- communicating with the local federator.
    FederatorClientHTTP2Error FederatorClientHTTP2Error
  | -- | Federator client does not currently support streaming, so this error
    -- will be thrown when using federator client to call APIs that contain a
    -- streaming body.
    FederatorClientStreamingNotSupported
  | -- | This error will be thrown when the response received from federator
    -- cannot be parsed by the servant machinery (e.g. its content type is
    -- malformed or unsupported).
    FederatorClientServantError ClientError
  | -- | This error will be thrown when federator returns an error response.
    FederatorClientError Wai.Error
  | -- | This happens when an invalid version information response is returned
    -- by federator, or when negotiation fails because no common version could
    -- be found.
    FederatorClientVersionNegotiationError VersionNegotiationError
  | -- | This happens when no endpoint for the negotiated version could be
    -- found among the alternative. This error could in principle be checked
    -- statically, but it is not trivial to do so.
    FederatorClientVersionMismatch
  deriving (Int -> FederatorClientError -> ShowS
[FederatorClientError] -> ShowS
FederatorClientError -> String
(Int -> FederatorClientError -> ShowS)
-> (FederatorClientError -> String)
-> ([FederatorClientError] -> ShowS)
-> Show FederatorClientError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FederatorClientError -> ShowS
showsPrec :: Int -> FederatorClientError -> ShowS
$cshow :: FederatorClientError -> String
show :: FederatorClientError -> String
$cshowList :: [FederatorClientError] -> ShowS
showList :: [FederatorClientError] -> ShowS
Show, Typeable)

instance Exception FederatorClientError

-- | High level federation errors. When something goes wrong during a federated
-- call, this error type should be used to represent the failure that occurred.
--
-- Note that federator client itself can only throw errors of type
-- 'FederatorClientError', corresponding to the 'FederationCallFailure'
-- constructor of 'FederationError'.
data FederationError
  = -- | To be used by endpoints to signal federation code paths that haven't
    -- been fully implemented yet.
    FederationNotImplemented
  | -- | No federator endpoint has been set, so no call to federator client can
    -- be made.
    FederationNotConfigured
  | -- | An error occurred while invoking federator client (see
    -- 'FederatorClientError' for more details).
    FederationCallFailure FederatorClientError
  | -- | Federator client was invoked successfully, but the returned value is
    -- incorrect. For example, if a single conversation was requested from the
    -- remote backend, but multiple conversations have been returned. This can
    -- indicate a bug in either backend, or an incompatibility in the
    -- server-to-server API.
    FederationUnexpectedBody Text
  | -- | Federator client got an unexpected error response from remote backend.
    -- Also used for error conditions that will go away in a future release,
    -- like "can't delete remote domains from config file", which is only
    -- needed until we start disregarding the config file.
    FederationUnexpectedError Text
  deriving (Int -> FederationError -> ShowS
[FederationError] -> ShowS
FederationError -> String
(Int -> FederationError -> ShowS)
-> (FederationError -> String)
-> ([FederationError] -> ShowS)
-> Show FederationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FederationError -> ShowS
showsPrec :: Int -> FederationError -> ShowS
$cshow :: FederationError -> String
show :: FederationError -> String
$cshowList :: [FederationError] -> ShowS
showList :: [FederationError] -> ShowS
Show, Typeable)

data VersionNegotiationError
  = InvalidVersionInfo
  | RemoteTooOld
  | RemoteTooNew
  deriving (Int -> VersionNegotiationError -> ShowS
[VersionNegotiationError] -> ShowS
VersionNegotiationError -> String
(Int -> VersionNegotiationError -> ShowS)
-> (VersionNegotiationError -> String)
-> ([VersionNegotiationError] -> ShowS)
-> Show VersionNegotiationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VersionNegotiationError -> ShowS
showsPrec :: Int -> VersionNegotiationError -> ShowS
$cshow :: VersionNegotiationError -> String
show :: VersionNegotiationError -> String
$cshowList :: [VersionNegotiationError] -> ShowS
showList :: [VersionNegotiationError] -> ShowS
Show, Typeable)

versionNegotiationErrorMessage :: VersionNegotiationError -> LText
versionNegotiationErrorMessage :: VersionNegotiationError -> LText
versionNegotiationErrorMessage VersionNegotiationError
InvalidVersionInfo =
  LText
"Remote federator returned invalid version information"
versionNegotiationErrorMessage VersionNegotiationError
RemoteTooOld =
  LText
"Version negotiation failed: the remote backend is too old"
versionNegotiationErrorMessage VersionNegotiationError
RemoteTooNew =
  LText
"Version negotiation failed: the remote backend is too new"

instance Exception FederationError

instance APIError FederationError where
  toResponse :: FederationError -> JSONResponse
toResponse = Error -> JSONResponse
forall e. APIError e => e -> JSONResponse
toResponse (Error -> JSONResponse)
-> (FederationError -> Error) -> FederationError -> JSONResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederationError -> Error
federationErrorToWai

federationErrorToWai :: FederationError -> Wai.Error
federationErrorToWai :: FederationError -> Error
federationErrorToWai FederationError
FederationNotImplemented = Error
federationNotImplemented
federationErrorToWai FederationError
FederationNotConfigured = Error
federationNotConfigured
federationErrorToWai (FederationCallFailure FederatorClientError
err) = FederatorClientError -> Error
federationClientErrorToWai FederatorClientError
err
federationErrorToWai (FederationUnexpectedBody Text
s) = Text -> Error
federationUnexpectedBody Text
s
federationErrorToWai (FederationUnexpectedError Text
t) = Text -> Error
federationUnexpectedError Text
t

federationClientErrorToWai :: FederatorClientError -> Wai.Error
federationClientErrorToWai :: FederatorClientError -> Error
federationClientErrorToWai (FederatorClientHTTP2Error FederatorClientHTTP2Error
e) =
  FederatorClientHTTP2Error -> Error
federationClientHTTP2Error FederatorClientHTTP2Error
e
federationClientErrorToWai FederatorClientError
FederatorClientStreamingNotSupported =
  Status -> LText -> LText -> Error
Wai.mkError Status
HTTP.status500 LText
"internal-error" LText
"Federated streaming not implemented"
federationClientErrorToWai (FederatorClientServantError ClientError
err) =
  ClientError -> Error
federationServantErrorToWai ClientError
err
federationClientErrorToWai (FederatorClientError Error
err) = Error
err
federationClientErrorToWai (FederatorClientVersionNegotiationError VersionNegotiationError
err) =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
unexpectedFederationResponseStatus
    LText
"federation-version-error"
    (VersionNegotiationError -> LText
versionNegotiationErrorMessage VersionNegotiationError
err)
federationClientErrorToWai FederatorClientError
FederatorClientVersionMismatch =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
HTTP.status500
    LText
"internal-error"
    LText
"Endpoint version mismatch in federation client"

federationRemoteHTTP2Error :: SrvTarget -> Text -> FederatorClientHTTP2Error -> Wai.Error
federationRemoteHTTP2Error :: SrvTarget -> Text -> FederatorClientHTTP2Error -> Error
federationRemoteHTTP2Error SrvTarget
target Text
path = \case
  FederatorClientHTTP2Error
FederatorClientNoStatusCode ->
    ( Status -> LText -> LText -> Error
Wai.mkError
        Status
unexpectedFederationResponseStatus
        LText
"federation-http2-error"
        LText
"No status code in HTTP2 response"
    )
      Error -> (Error -> Error) -> Error
forall a b. a -> (a -> b) -> b
& Error -> Error
addErrData
  (FederatorClientHTTP2Exception HTTP2Error
e) ->
    ( Status -> LText -> LText -> Error
Wai.mkError
        Status
unexpectedFederationResponseStatus
        LText
"federation-http2-error"
        (String -> LText
LT.pack (HTTP2Error -> String
forall e. Exception e => e -> String
displayException HTTP2Error
e))
    )
      Error -> (Error -> Error) -> Error
forall a b. a -> (a -> b) -> b
& Error -> Error
addErrData
  (FederatorClientTLSException SomeSSLException
e) ->
    ( Status -> LText -> LText -> Error
Wai.mkError
        (Int -> ByteString -> Status
HTTP.mkStatus Int
525 ByteString
"SSL Handshake Failure")
        LText
"federation-tls-error"
        (String -> LText
LT.pack (SomeSSLException -> String
forall e. Exception e => e -> String
displayException SomeSSLException
e))
    )
      Error -> (Error -> Error) -> Error
forall a b. a -> (a -> b) -> b
& Error -> Error
addErrData
  (FederatorClientConnectionError IOException
e) ->
    ( Status -> LText -> LText -> Error
Wai.mkError
        Status
federatorConnectionRefusedStatus
        LText
"federation-connection-refused"
        (String -> LText
LT.pack (IOException -> String
forall e. Exception e => e -> String
displayException IOException
e))
    )
      Error -> (Error -> Error) -> Error
forall a b. a -> (a -> b) -> b
& Error -> Error
addErrData
  where
    addErrData :: Error -> Error
addErrData Error
err =
      Error
err
        { Wai.errorData =
            ( (mkDomain . T.decodeUtf8With T.lenientDecode . srvTargetDomain $ target) ::
                Either String Domain
            )
              & either (const Nothing) (\Domain
dom -> ErrorData -> Maybe ErrorData
forall a. a -> Maybe a
Just (Domain -> Text -> ErrorData
Wai.FederationErrorData Domain
dom Text
path))
        }

federationClientHTTP2Error :: FederatorClientHTTP2Error -> Wai.Error
federationClientHTTP2Error :: FederatorClientHTTP2Error -> Error
federationClientHTTP2Error (FederatorClientConnectionError IOException
e) =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
HTTP.status500
    LText
"federation-not-available"
    (String -> LText
LT.pack (IOException -> String
forall e. Exception e => e -> String
displayException IOException
e))
federationClientHTTP2Error FederatorClientHTTP2Error
e =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
HTTP.status500
    LText
"federation-local-error"
    (String -> LText
LT.pack (FederatorClientHTTP2Error -> String
forall e. Exception e => e -> String
displayException FederatorClientHTTP2Error
e))

federationRemoteResponseError :: SrvTarget -> Text -> HTTP.Status -> LByteString -> Wai.Error
federationRemoteResponseError :: SrvTarget -> Text -> Status -> LByteString -> Error
federationRemoteResponseError SrvTarget
target Text
path Status
status LByteString
body =
  ( Status -> LText -> LText -> Error
Wai.mkError
      Status
unexpectedFederationResponseStatus
      LText
"federation-remote-error"
      ( LText
"A remote federator failed with status code: "
          LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> String -> LText
LT.pack (Int -> String
forall a. Show a => a -> String
show (Status -> Int
HTTP.statusCode Status
status))
      )
  )
    { Wai.errorData =
        ( (mkDomain . T.decodeUtf8With T.lenientDecode . srvTargetDomain $ target) ::
            Either String Domain
        )
          & either (const Nothing) (\Domain
dom -> ErrorData -> Maybe ErrorData
forall a. a -> Maybe a
Just (Domain -> Text -> ErrorData
Wai.FederationErrorData Domain
dom Text
path)),
      Wai.innerError =
        Just $
          fromMaybe
            ( Wai.mkError
                status
                "unknown-error"
                (LT.decodeUtf8With T.lenientDecode body)
            )
            (Aeson.decode body)
    }

federationServantErrorToWai :: ClientError -> Wai.Error
federationServantErrorToWai :: ClientError -> Error
federationServantErrorToWai (DecodeFailure Text
msg Response
_) = Text -> Error
federationInvalidBody Text
msg
-- the following error is never thrown by federator client
federationServantErrorToWai (FailureResponse RequestF () (BaseUrl, ByteString)
_ Response
_) = Error
federationUnknownError
federationServantErrorToWai (InvalidContentTypeHeader Response
res) =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
unexpectedFederationResponseStatus
    LText
"federation-invalid-content-type"
    (LText
"Content-type: " LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> Response -> LText
forall a. ResponseF a -> LText
federationErrorContentType Response
res)
federationServantErrorToWai (UnsupportedContentType MediaType
mediaType Response
res) =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
unexpectedFederationResponseStatus
    LText
"federation-unsupported-content-type"
    ( LText
"Content-type: "
        LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> Response -> LText
forall a. ResponseF a -> LText
federationErrorContentType Response
res
        LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> LText
", Media-Type: "
        LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> String -> LText
LT.pack (MediaType -> String
forall a. Show a => a -> String
show MediaType
mediaType)
    )
federationServantErrorToWai (ConnectionError SomeException
e) =
  Text -> Error
federationUnavailable (Text -> Error)
-> (SomeException -> Text) -> SomeException -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
displayException (SomeException -> Error) -> SomeException -> Error
forall a b. (a -> b) -> a -> b
$ SomeException
e

federationErrorContentType :: ResponseF a -> LT.Text
federationErrorContentType :: forall a. ResponseF a -> LText
federationErrorContentType =
  Text -> LText
LT.fromStrict
    (Text -> LText) -> (ResponseF a -> Text) -> ResponseF a -> LText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8
    (ByteString -> Text)
-> (ResponseF a -> ByteString) -> ResponseF a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> ((HeaderName, ByteString) -> ByteString)
-> Maybe (HeaderName, ByteString)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd
    (Maybe (HeaderName, ByteString) -> ByteString)
-> (ResponseF a -> Maybe (HeaderName, ByteString))
-> ResponseF a
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> Bool)
-> Seq (HeaderName, ByteString) -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(HeaderName
name, ByteString
_) -> HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"Content-Type")
    (Seq (HeaderName, ByteString) -> Maybe (HeaderName, ByteString))
-> (ResponseF a -> Seq (HeaderName, ByteString))
-> ResponseF a
-> Maybe (HeaderName, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseF a -> Seq (HeaderName, ByteString)
forall a. ResponseF a -> Seq (HeaderName, ByteString)
responseHeaders

unexpectedFederationResponseStatus :: Status
unexpectedFederationResponseStatus :: Status
unexpectedFederationResponseStatus = Int -> ByteString -> Status
HTTP.Status Int
533 ByteString
"Unexpected Federation Response"

federatorConnectionRefusedStatus :: Status
federatorConnectionRefusedStatus :: Status
federatorConnectionRefusedStatus = Int -> ByteString -> Status
HTTP.Status Int
521 ByteString
"Remote Federator Connection Refused"

federationNotImplemented :: Wai.Error
federationNotImplemented :: Error
federationNotImplemented =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
HTTP.status500
    LText
"federation-not-implemented"
    LText
"Federation is not yet implemented for this endpoint"

federationInvalidBody :: Text -> Wai.Error
federationInvalidBody :: Text -> Error
federationInvalidBody Text
msg =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
unexpectedFederationResponseStatus
    LText
"federation-invalid-body"
    (LText
"Could not parse remote federator response: " LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> Text -> LText
LT.fromStrict Text
msg)

federationUnexpectedBody :: Text -> Wai.Error
federationUnexpectedBody :: Text -> Error
federationUnexpectedBody Text
msg =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
unexpectedFederationResponseStatus
    LText
"federation-unexpected-body"
    (LText
"Could parse body, but response was not expected: " LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> Text -> LText
LT.fromStrict Text
msg)

federationUnexpectedError :: Text -> Wai.Error
federationUnexpectedError :: Text -> Error
federationUnexpectedError Text
msg =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
unexpectedFederationResponseStatus
    LText
"federation-unexpected-wai-error"
    (LText
"Could parse body, but got an unexpected error response: " LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> Text -> LText
LT.fromStrict Text
msg)

federationNotConfigured :: Wai.Error
federationNotConfigured :: Error
federationNotConfigured =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
HTTP.status400
    LText
"federation-not-enabled"
    LText
"no federator configured"

federationUnavailable :: Text -> Wai.Error
federationUnavailable :: Text -> Error
federationUnavailable Text
err =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
HTTP.status500
    LText
"federation-not-available"
    (LText
"Local federator not available: " LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> Text -> LText
LT.fromStrict Text
err)

federationUnknownError :: Wai.Error
federationUnknownError :: Error
federationUnknownError =
  Status -> LText -> LText -> Error
Wai.mkError
    Status
unexpectedFederationResponseStatus
    LText
"unknown-federation-error"
    LText
"Unknown federation error"