{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Client.Fetch.Http
( httpRequest,
)
where
import Data.Aeson (FromJSON, ToJSON, encode)
import qualified Data.ByteString.Char8 as L
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.Map as M
import Data.Morpheus.Client.Fetch.GQLClient (Header, Headers)
import Data.Morpheus.Client.Fetch.RequestType
( Request,
RequestType (RequestArgs),
decodeResponse,
toRequest,
)
import Data.Morpheus.Client.Fetch.Types (GQLClientResult)
import qualified Data.Text as T
import Network.HTTP.Req
( POST (..),
ReqBodyLbs (ReqBodyLbs),
defaultHttpConfig,
header,
lbsResponse,
req,
responseBody,
runReq,
useURI,
)
import qualified Network.HTTP.Req as R (Option)
import Relude hiding (ByteString)
import Text.URI (URI)
withHeader :: Header -> R.Option scheme
(Text
k, Text
v) = forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header (String -> ByteString
L.pack forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
k) (String -> ByteString
L.pack forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
v)
setHeaders :: Headers -> R.Option scheme
= forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (scheme :: Scheme). Header -> Option scheme
withHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList
post :: URI -> ByteString -> Headers -> IO ByteString
post :: URI -> ByteString -> Headers -> IO ByteString
post URI
uri ByteString
body Headers
headers = case forall (scheme0 :: Scheme) (scheme1 :: Scheme).
URI
-> Maybe
(Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1))
useURI URI
uri of
Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid Endpoint: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show URI
uri forall a. Semigroup a => a -> a -> a
<> String
"!")
(Just (Left (Url 'Http
u, Option 'Http
o))) -> forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST Url 'Http
u (ByteString -> ReqBodyLbs
ReqBodyLbs ByteString
body) Proxy LbsResponse
lbsResponse (Option 'Http
o forall a. Semigroup a => a -> a -> a
<> forall (scheme :: Scheme). Headers -> Option scheme
setHeaders Headers
headers))
(Just (Right (Url 'Https
u, Option 'Https
o))) -> forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST Url 'Https
u (ByteString -> ReqBodyLbs
ReqBodyLbs ByteString
body) Proxy LbsResponse
lbsResponse (Option 'Https
o forall a. Semigroup a => a -> a -> a
<> forall (scheme :: Scheme). Headers -> Option scheme
setHeaders Headers
headers))
httpRequest :: (FromJSON a, RequestType a, ToJSON (RequestArgs a)) => URI -> Request a -> Headers -> IO (GQLClientResult a)
httpRequest :: forall a.
(FromJSON a, RequestType a, ToJSON (RequestArgs a)) =>
URI -> Request a -> Headers -> IO (GQLClientResult a)
httpRequest URI
uri Request a
r Headers
h = forall a. FromJSON a => ByteString -> Either (FetchError a) a
decodeResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URI -> ByteString -> Headers -> IO ByteString
post URI
uri (forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ forall a.
(RequestType a, ToJSON (RequestArgs a)) =>
Request a -> GQLRequest
toRequest Request a
r) Headers
h