module Wire.API.Federation.Error
(
FederatorClientHTTP2Error (..),
FederatorClientError (..),
FederationError (..),
VersionNegotiationError (..),
federationErrorToWai,
federationRemoteHTTP2Error,
federationRemoteResponseError,
federationNotImplemented,
federationNotConfigured,
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
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
data FederatorClientError
=
FederatorClientHTTP2Error FederatorClientHTTP2Error
|
FederatorClientStreamingNotSupported
|
FederatorClientServantError ClientError
|
FederatorClientError Wai.Error
|
FederatorClientVersionNegotiationError VersionNegotiationError
|
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
data FederationError
=
FederationNotImplemented
|
FederationNotConfigured
|
FederationCallFailure FederatorClientError
|
FederationUnexpectedBody Text
|
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
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"