{-# 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
withHeader :: forall (scheme :: Scheme). Header -> Option scheme
withHeader (Text
k, Text
v) = ByteString -> ByteString -> Option scheme
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header (String -> ByteString
L.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
k) (String -> ByteString
L.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
v)

setHeaders :: Headers -> R.Option scheme
setHeaders :: forall (scheme :: Scheme). Headers -> Option scheme
setHeaders = (Header -> Option scheme) -> [Header] -> Option scheme
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Header -> Option scheme
forall (scheme :: Scheme). Header -> Option scheme
withHeader ([Header] -> Option scheme)
-> (Headers -> [Header]) -> Headers -> Option scheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> [Header]
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 URI
-> Maybe
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
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 -> String -> IO ByteString
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid Endpoint: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> URI -> String
forall b a. (Show a, IsString b) => a -> b
show URI
uri String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"!")
  (Just (Left (Url 'Http
u, Option 'Http
o))) -> LbsResponse -> ByteString
LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody (LbsResponse -> ByteString) -> IO LbsResponse -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HttpConfig -> Req LbsResponse -> IO LbsResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (POST
-> Url 'Http
-> ReqBodyLbs
-> Proxy LbsResponse
-> Option 'Http
-> Req LbsResponse
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 Option 'Http -> Option 'Http -> Option 'Http
forall a. Semigroup a => a -> a -> a
<> Headers -> Option 'Http
forall (scheme :: Scheme). Headers -> Option scheme
setHeaders Headers
headers))
  (Just (Right (Url 'Https
u, Option 'Https
o))) -> LbsResponse -> ByteString
LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody (LbsResponse -> ByteString) -> IO LbsResponse -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HttpConfig -> Req LbsResponse -> IO LbsResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (POST
-> Url 'Https
-> ReqBodyLbs
-> Proxy LbsResponse
-> Option 'Https
-> Req LbsResponse
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 Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> Headers -> Option 'Https
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 = ByteString -> Either (FetchError a) a
forall a. FromJSON a => ByteString -> Either (FetchError a) a
decodeResponse (ByteString -> Either (FetchError a) a)
-> IO ByteString -> IO (Either (FetchError a) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URI -> ByteString -> Headers -> IO ByteString
post URI
uri (GQLRequest -> ByteString
forall a. ToJSON a => a -> ByteString
encode (GQLRequest -> ByteString) -> GQLRequest -> ByteString
forall a b. (a -> b) -> a -> b
$ Request a -> GQLRequest
forall a.
(RequestType a, ToJSON (RequestArgs a)) =>
Request a -> GQLRequest
toRequest Request a
r) Headers
h