1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-26 17:03:07 +03:00
graphql-engine/server/src-lib/Hasura/HTTP.hs

77 lines
2.4 KiB
Haskell
Raw Normal View History

module Hasura.HTTP
( wreqOptions
, HttpException(..)
, hdrsToText
, addDefaultHeaders
, HttpResponse(..)
, addHttpResponseHeaders
) where
import Hasura.Prelude
import Control.Lens hiding ((.=))
import Data.CaseInsensitive (original)
import Data.Text.Conversions (UTF8 (..), convertText)
import qualified Data.Aeson as J
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wreq as Wreq
import Hasura.Server.Version (HasVersion, currentVersion)
hdrsToText :: [HTTP.Header] -> [(Text, Text)]
hdrsToText hdrs =
[ (bsToTxt $ original hdrName, bsToTxt hdrVal)
| (hdrName, hdrVal) <- hdrs
]
wreqOptions :: HasVersion => 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 :: HasVersion => [HTTP.Header] -> [HTTP.Header]
addDefaultHeaders hdrs = defaultHeaders <> rmDefaultHeaders hdrs
where
rmDefaultHeaders = filter (not . isDefaultHeader)
isDefaultHeader :: HasVersion => HTTP.Header -> Bool
isDefaultHeader (hdrName, _) = hdrName `elem` map fst defaultHeaders
defaultHeaders :: HasVersion => [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)
instance J.ToJSON HttpException where
toJSON = \case
(HttpException (HTTP.InvalidUrlException _ e)) ->
J.object [ "type" J..= ("invalid_url" :: Text)
, "message" J..= e
]
(HttpException (HTTP.HttpExceptionRequest _ cont)) ->
J.object [ "type" J..= ("http_exception" :: Text)
, "message" J..= show cont
]
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)