mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 04:24:35 +03:00
88ace749bc
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4738 GitOrigin-RevId: d0c0b13ac02ca80e51ae3d582f2e6917f76ad202
142 lines
5.6 KiB
Haskell
142 lines
5.6 KiB
Haskell
module Hasura.HTTP
|
|
( wreqOptions,
|
|
HttpException (..),
|
|
hdrsToText,
|
|
addDefaultHeaders,
|
|
defaultHeaders,
|
|
HttpResponse (..),
|
|
addHttpResponseHeaders,
|
|
getHTTPExceptionStatus,
|
|
serializeHTTPExceptionMessage,
|
|
)
|
|
where
|
|
|
|
import Control.Exception (fromException)
|
|
import Control.Lens hiding ((.=))
|
|
import Data.Aeson qualified as J
|
|
import Data.Aeson.KeyMap qualified as KM
|
|
import Data.CaseInsensitive (original)
|
|
import Data.HashMap.Strict qualified as M
|
|
import Data.Text qualified as T
|
|
import Data.Text.Conversions (UTF8 (..), convertText)
|
|
import Data.Text.Encoding qualified as TE
|
|
import Hasura.Prelude
|
|
import Hasura.Server.Utils (redactSensitiveHeader)
|
|
import Hasura.Server.Version (currentVersion)
|
|
import Network.HTTP.Client qualified as HTTP
|
|
import Network.HTTP.Client.Restricted qualified as Restricted
|
|
import Network.HTTP.Types qualified as HTTP
|
|
import Network.Wreq qualified as Wreq
|
|
|
|
hdrsToText :: [HTTP.Header] -> [(Text, Text)]
|
|
hdrsToText hdrs =
|
|
[ (bsToTxt $ original hdrName, bsToTxt hdrVal)
|
|
| (hdrName, hdrVal) <- hdrs
|
|
]
|
|
|
|
wreqOptions :: HTTP.Manager -> [HTTP.Header] -> Wreq.Options
|
|
wreqOptions manager hdrs =
|
|
Wreq.defaults
|
|
& Wreq.headers .~ addDefaultHeaders hdrs
|
|
& Wreq.checkResponse ?~ (\_ _ -> return ())
|
|
& Wreq.manager .~ Right manager
|
|
|
|
-- Adds defaults headers overwriting any existing ones
|
|
addDefaultHeaders :: [HTTP.Header] -> [HTTP.Header]
|
|
addDefaultHeaders hdrs = defaultHeaders <> rmDefaultHeaders hdrs
|
|
where
|
|
rmDefaultHeaders = filter (not . isDefaultHeader)
|
|
|
|
isDefaultHeader :: HTTP.Header -> Bool
|
|
isDefaultHeader (hdrName, _) = hdrName `elem` map fst defaultHeaders
|
|
|
|
defaultHeaders :: [HTTP.Header]
|
|
defaultHeaders = [contentType, userAgent]
|
|
where
|
|
contentType = ("Content-Type", "application/json")
|
|
userAgent =
|
|
( "User-Agent",
|
|
"hasura-graphql-engine/" <> unUTF8 (convertText currentVersion)
|
|
)
|
|
|
|
newtype HttpException = HttpException
|
|
{unHttpException :: HTTP.HttpException}
|
|
deriving (Show)
|
|
|
|
getHTTPExceptionStatus :: HttpException -> Maybe Int
|
|
getHTTPExceptionStatus = \case
|
|
(HttpException (HTTP.HttpExceptionRequest _ httpExceptionContent)) ->
|
|
case httpExceptionContent of
|
|
HTTP.StatusCodeException response _ -> Just $ HTTP.statusCode $ HTTP.responseStatus response
|
|
HTTP.ProxyConnectException _ _ status -> Just $ HTTP.statusCode status
|
|
_ -> Nothing
|
|
(HttpException (HTTP.InvalidUrlException _ _)) -> Nothing
|
|
|
|
serializeHTTPExceptionMessage :: HttpException -> Text
|
|
serializeHTTPExceptionMessage (HttpException (HTTP.HttpExceptionRequest _ httpExceptionContent)) =
|
|
case httpExceptionContent of
|
|
HTTP.StatusCodeException _ _ -> "unexpected"
|
|
HTTP.TooManyRedirects _ -> "Too many redirects"
|
|
HTTP.OverlongHeaders -> "Overlong headers"
|
|
HTTP.ResponseTimeout -> "Response timeout"
|
|
HTTP.ConnectionTimeout -> "Connection timeout"
|
|
HTTP.ConnectionFailure _ -> "Connection failure"
|
|
HTTP.InvalidStatusLine _ -> "Invalid HTTP Status Line"
|
|
HTTP.InternalException err -> case fromException err of
|
|
Just (Restricted.ConnectionRestricted _ _) -> "Blocked connection to private IP address"
|
|
Nothing -> "Internal Exception"
|
|
HTTP.ProxyConnectException {} -> "Proxy connection exception"
|
|
HTTP.NoResponseDataReceived -> "No response data received"
|
|
HTTP.TlsNotSupported -> "TLS not supported"
|
|
HTTP.InvalidDestinationHost _ -> "Invalid destination host"
|
|
HTTP.InvalidHeader _ -> "Invalid Header"
|
|
HTTP.InvalidRequestHeader _ -> "Invalid Request Header"
|
|
HTTP.WrongRequestBodyStreamSize _ _ -> "Wrong request body stream size"
|
|
HTTP.ResponseBodyTooShort _ _ -> "Response body too short"
|
|
HTTP.InvalidChunkHeaders -> "Invalid chunk headers"
|
|
HTTP.IncompleteHeaders -> "Incomplete headers"
|
|
_ -> "unexpected"
|
|
serializeHTTPExceptionMessage (HttpException (HTTP.InvalidUrlException url reason)) = T.pack $ "URL: " <> url <> " is invalid because " <> reason
|
|
|
|
encodeHTTPRequestJSON :: HTTP.Request -> J.Value
|
|
encodeHTTPRequestJSON request =
|
|
J.Object $
|
|
KM.fromList
|
|
[ ("host", J.toJSON $ TE.decodeUtf8 $ HTTP.host request),
|
|
("port", J.toJSON $ HTTP.port request),
|
|
("secure", J.toJSON $ HTTP.secure request),
|
|
("requestHeaders", J.toJSON $ M.fromList $ hdrsToText $ map redactSensitiveHeader $ HTTP.requestHeaders request),
|
|
("path", J.toJSON $ TE.decodeUtf8 $ HTTP.path request),
|
|
("queryString", J.toJSON $ TE.decodeUtf8 $ HTTP.queryString request),
|
|
("method", J.toJSON $ TE.decodeUtf8 $ HTTP.method request),
|
|
("responseTimeout", J.String $ tshow $ HTTP.responseTimeout request)
|
|
]
|
|
|
|
instance J.ToJSON HttpException where
|
|
toJSON httpException =
|
|
case httpException of
|
|
(HttpException (HTTP.InvalidUrlException _ e)) ->
|
|
J.object
|
|
[ "type" J..= ("invalid_url" :: Text),
|
|
"message" J..= e
|
|
]
|
|
(HttpException (HTTP.HttpExceptionRequest req _)) ->
|
|
let statusMaybe = getHTTPExceptionStatus httpException
|
|
exceptionContent = serializeHTTPExceptionMessage httpException
|
|
reqJSON = encodeHTTPRequestJSON req
|
|
in J.object $
|
|
[ "type" J..= ("http_exception" :: Text),
|
|
"message" J..= exceptionContent,
|
|
"request" J..= reqJSON
|
|
]
|
|
<> maybe mempty (\status -> ["status" J..= status]) statusMaybe
|
|
|
|
data HttpResponse a = HttpResponse
|
|
{ _hrBody :: !a,
|
|
_hrHeaders :: !HTTP.ResponseHeaders
|
|
}
|
|
deriving (Functor, Foldable, Traversable)
|
|
|
|
addHttpResponseHeaders :: HTTP.ResponseHeaders -> HttpResponse a -> HttpResponse a
|
|
addHttpResponseHeaders newHeaders (HttpResponse b h) = HttpResponse b (newHeaders <> h)
|