2018-12-13 10:26:15 +03:00
|
|
|
module Hasura.HTTP
|
|
|
|
( wreqOptions
|
|
|
|
, HttpException(..)
|
2019-03-05 15:24:47 +03:00
|
|
|
, hdrsToText
|
2019-08-23 11:57:19 +03:00
|
|
|
, addDefaultHeaders
|
2020-04-24 10:55:51 +03:00
|
|
|
, HttpResponse(..)
|
2021-08-25 04:52:38 +03:00
|
|
|
, addHttpResponseHeaders
|
2018-12-13 10:26:15 +03:00
|
|
|
) where
|
2018-11-23 16:02:46 +03:00
|
|
|
|
|
|
|
import Hasura.Prelude
|
|
|
|
|
2020-01-23 00:55:55 +03:00
|
|
|
import Control.Lens hiding ((.=))
|
|
|
|
import Data.CaseInsensitive (original)
|
|
|
|
import Data.Text.Conversions (UTF8 (..), convertText)
|
|
|
|
|
2018-12-13 10:26:15 +03:00
|
|
|
import qualified Data.Aeson as J
|
2018-11-23 16:02:46 +03:00
|
|
|
import qualified Network.HTTP.Client as HTTP
|
|
|
|
import qualified Network.HTTP.Types as HTTP
|
|
|
|
import qualified Network.Wreq as Wreq
|
|
|
|
|
2020-01-23 00:55:55 +03:00
|
|
|
import Hasura.Server.Version (HasVersion, currentVersion)
|
2018-11-23 16:02:46 +03:00
|
|
|
|
2019-03-05 15:24:47 +03:00
|
|
|
hdrsToText :: [HTTP.Header] -> [(Text, Text)]
|
|
|
|
hdrsToText hdrs =
|
|
|
|
[ (bsToTxt $ original hdrName, bsToTxt hdrVal)
|
|
|
|
| (hdrName, hdrVal) <- hdrs
|
|
|
|
]
|
|
|
|
|
2020-01-23 00:55:55 +03:00
|
|
|
wreqOptions :: HasVersion => HTTP.Manager -> [HTTP.Header] -> Wreq.Options
|
2018-11-23 16:02:46 +03:00
|
|
|
wreqOptions manager hdrs =
|
|
|
|
Wreq.defaults
|
2019-08-23 11:57:19 +03:00
|
|
|
& Wreq.headers .~ addDefaultHeaders hdrs
|
2018-11-23 16:02:46 +03:00
|
|
|
& Wreq.checkResponse ?~ (\_ _ -> return ())
|
|
|
|
& Wreq.manager .~ Right manager
|
2019-08-23 11:57:19 +03:00
|
|
|
|
|
|
|
-- Adds defaults headers overwriting any existing ones
|
2020-01-23 00:55:55 +03:00
|
|
|
addDefaultHeaders :: HasVersion => [HTTP.Header] -> [HTTP.Header]
|
2019-08-23 11:57:19 +03:00
|
|
|
addDefaultHeaders hdrs = defaultHeaders <> rmDefaultHeaders hdrs
|
|
|
|
where
|
|
|
|
rmDefaultHeaders = filter (not . isDefaultHeader)
|
|
|
|
|
2020-01-23 00:55:55 +03:00
|
|
|
isDefaultHeader :: HasVersion => HTTP.Header -> Bool
|
2020-04-24 10:55:51 +03:00
|
|
|
isDefaultHeader (hdrName, _) = hdrName `elem` map fst defaultHeaders
|
2019-08-23 11:57:19 +03:00
|
|
|
|
2020-01-23 00:55:55 +03:00
|
|
|
defaultHeaders :: HasVersion => [HTTP.Header]
|
2019-08-23 11:57:19 +03:00
|
|
|
defaultHeaders = [contentType, userAgent]
|
2018-11-23 16:02:46 +03:00
|
|
|
where
|
|
|
|
contentType = ("Content-Type", "application/json")
|
|
|
|
userAgent = ( "User-Agent"
|
2020-01-23 00:55:55 +03:00
|
|
|
, "hasura-graphql-engine/" <> unUTF8 (convertText currentVersion)
|
2018-11-23 16:02:46 +03:00
|
|
|
)
|
2018-12-13 10:26:15 +03:00
|
|
|
|
|
|
|
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
|
|
|
|
]
|
2020-04-24 10:55:51 +03:00
|
|
|
|
|
|
|
data HttpResponse a
|
|
|
|
= HttpResponse
|
|
|
|
{ _hrBody :: !a
|
|
|
|
, _hrHeaders :: !HTTP.ResponseHeaders
|
|
|
|
} deriving (Functor, Foldable, Traversable)
|
2021-08-25 04:52:38 +03:00
|
|
|
|
|
|
|
addHttpResponseHeaders :: HTTP.ResponseHeaders -> HttpResponse a -> HttpResponse a
|
|
|
|
addHttpResponseHeaders newHeaders (HttpResponse b h) = HttpResponse b (newHeaders <> h)
|