graphql-engine/server/src-lib/Hasura/HTTP.hs
Daniel Harvey 88ace749bc server: Fix a bunch of HLint suggestions
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4738
GitOrigin-RevId: d0c0b13ac02ca80e51ae3d582f2e6917f76ad202
2022-06-21 11:12:42 +00:00

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)