{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
module Servant.HttpStreams.Internal where

import           Prelude ()
import           Prelude.Compat

import           Control.DeepSeq
                 (NFData, force)
import           Control.Exception
                 (IOException, SomeException (..), catch, evaluate, throwIO)
import           Control.Monad
                 (unless)
import           Control.Monad.Base
                 (MonadBase (..))
import           Control.Monad.Codensity
                 (Codensity (..))
import           Control.Monad.Error.Class
                 (MonadError (..))
import           Control.Monad.IO.Class
                 (MonadIO (..))
import           Control.Monad.Reader
                 (MonadReader, ReaderT, ask, runReaderT)
import           Control.Monad.Trans.Class
                 (lift)
import           Control.Monad.Trans.Except
                 (ExceptT, runExceptT)
import           Data.Bifunctor
                 (bimap, first)
import           Data.ByteString.Builder
                 (toLazyByteString)
import qualified Data.ByteString.Builder    as B
import qualified Data.ByteString.Lazy       as BSL
import qualified Data.CaseInsensitive       as CI
import           Data.Foldable
                 (for_, toList)
import           Data.Functor.Alt
                 (Alt (..))
import           Data.Maybe
                 (maybeToList)
import           Data.Proxy
                 (Proxy (..))
import           Data.Sequence
                 (fromList)
import           Data.String
                 (fromString)
import           GHC.Generics
import           Network.HTTP.Media
                 (renderHeader)
import           Network.HTTP.Types
                 (Status (..), hContentType, http11, renderQuery, statusIsSuccessful)
import           Servant.Client.Core

import qualified Network.Http.Client        as Client
import qualified Network.Http.Types         as Client
import qualified Servant.Types.SourceT      as S
import qualified System.IO.Streams          as Streams

-- | The environment in which a request is run.
--
-- 'ClientEnv' carries an open connection. See 'withClientEnvIO'.
--
data ClientEnv
    = ClientEnv
    { ClientEnv -> BaseUrl
baseUrl    :: BaseUrl
    , ClientEnv -> Connection
connection :: Client.Connection
    }

-- | 'ClientEnv' smart constructor.
mkClientEnv :: BaseUrl -> Client.Connection -> ClientEnv
mkClientEnv :: BaseUrl -> Connection -> ClientEnv
mkClientEnv = BaseUrl -> Connection -> ClientEnv
ClientEnv

-- | Open a connection to 'BaseUrl'.
withClientEnvIO :: BaseUrl -> (ClientEnv -> IO r) -> IO r
withClientEnvIO :: forall r. BaseUrl -> (ClientEnv -> IO r) -> IO r
withClientEnvIO BaseUrl
burl ClientEnv -> IO r
k = IO Connection -> (Connection -> IO r) -> IO r
forall γ. IO Connection -> (Connection -> IO γ) -> IO γ
Client.withConnection IO Connection
open ((Connection -> IO r) -> IO r) -> (Connection -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
    ClientEnv -> IO r
k (BaseUrl -> Connection -> ClientEnv
mkClientEnv BaseUrl
burl Connection
conn)
  where
    open :: IO Connection
open = ByteString -> Port -> IO Connection
Client.openConnection (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ BaseUrl -> String
baseUrlHost BaseUrl
burl) (Int -> Port
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Port) -> Int -> Port
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Int
baseUrlPort BaseUrl
burl)

-- | Generates a set of client functions for an API.
--
-- Example:
--
-- > type API = Capture "no" Int :> Get '[JSON] Int
-- >        :<|> Get '[JSON] [Bool]
-- >
-- > api :: Proxy API
-- > api = Proxy
-- >
-- > getInt :: Int -> ClientM Int
-- > getBools :: ClientM [Bool]
-- > getInt :<|> getBools = client api
client :: HasClient ClientM api => Proxy api -> Client ClientM api
client :: forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client Proxy api
api = Proxy api
api Proxy api -> Proxy ClientM -> Client ClientM api
forall (m :: * -> *) api.
HasClient m api =>
Proxy api -> Proxy m -> Client m api
`clientIn` (Proxy ClientM
forall {k} (t :: k). Proxy t
Proxy :: Proxy ClientM)

-- | Change the monad the client functions live in, by
--   supplying a conversion function
--   (a natural transformation to be precise).
--
--   For example, assuming you have some @manager :: 'Manager'@ and
--   @baseurl :: 'BaseUrl'@ around:
--
--   > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
--   > api :: Proxy API
--   > api = Proxy
--   > getInt :: IO Int
--   > postInt :: Int -> IO Int
--   > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)
--   >   where cenv = mkClientEnv manager baseurl
hoistClient
    :: HasClient ClientM api
    => Proxy api
    -> (forall a. m a -> n a)
    -> Client m api
    -> Client n api
hoistClient :: forall api (m :: * -> *) (n :: * -> *).
HasClient ClientM api =>
Proxy api -> (forall a. m a -> n a) -> Client m api -> Client n api
hoistClient = Proxy ClientM
-> Proxy api
-> (forall a. m a -> n a)
-> Client m api
-> Client n api
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (mon :: * -> *) (mon' :: * -> *).
Proxy ClientM
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad (Proxy ClientM
forall {k} (t :: k). Proxy t
Proxy :: Proxy ClientM)

-- | @ClientM@ is the monad in which client functions run. Contains the
-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
newtype ClientM a = ClientM
    { forall a.
ClientM a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a }
  deriving ( (forall a b. (a -> b) -> ClientM a -> ClientM b)
-> (forall a b. a -> ClientM b -> ClientM a) -> Functor ClientM
forall a b. a -> ClientM b -> ClientM a
forall a b. (a -> b) -> ClientM a -> ClientM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ClientM a -> ClientM b
fmap :: forall a b. (a -> b) -> ClientM a -> ClientM b
$c<$ :: forall a b. a -> ClientM b -> ClientM a
<$ :: forall a b. a -> ClientM b -> ClientM a
Functor, Functor ClientM
Functor ClientM =>
(forall a. a -> ClientM a)
-> (forall a b. ClientM (a -> b) -> ClientM a -> ClientM b)
-> (forall a b c.
    (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c)
-> (forall a b. ClientM a -> ClientM b -> ClientM b)
-> (forall a b. ClientM a -> ClientM b -> ClientM a)
-> Applicative ClientM
forall a. a -> ClientM a
forall a b. ClientM a -> ClientM b -> ClientM a
forall a b. ClientM a -> ClientM b -> ClientM b
forall a b. ClientM (a -> b) -> ClientM a -> ClientM b
forall a b c. (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> ClientM a
pure :: forall a. a -> ClientM a
$c<*> :: forall a b. ClientM (a -> b) -> ClientM a -> ClientM b
<*> :: forall a b. ClientM (a -> b) -> ClientM a -> ClientM b
$cliftA2 :: forall a b c. (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
liftA2 :: forall a b c. (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
$c*> :: forall a b. ClientM a -> ClientM b -> ClientM b
*> :: forall a b. ClientM a -> ClientM b -> ClientM b
$c<* :: forall a b. ClientM a -> ClientM b -> ClientM a
<* :: forall a b. ClientM a -> ClientM b -> ClientM a
Applicative, Applicative ClientM
Applicative ClientM =>
(forall a b. ClientM a -> (a -> ClientM b) -> ClientM b)
-> (forall a b. ClientM a -> ClientM b -> ClientM b)
-> (forall a. a -> ClientM a)
-> Monad ClientM
forall a. a -> ClientM a
forall a b. ClientM a -> ClientM b -> ClientM b
forall a b. ClientM a -> (a -> ClientM b) -> ClientM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. ClientM a -> (a -> ClientM b) -> ClientM b
>>= :: forall a b. ClientM a -> (a -> ClientM b) -> ClientM b
$c>> :: forall a b. ClientM a -> ClientM b -> ClientM b
>> :: forall a b. ClientM a -> ClientM b -> ClientM b
$creturn :: forall a. a -> ClientM a
return :: forall a. a -> ClientM a
Monad, Monad ClientM
Monad ClientM => (forall a. IO a -> ClientM a) -> MonadIO ClientM
forall a. IO a -> ClientM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> ClientM a
liftIO :: forall a. IO a -> ClientM a
MonadIO, (forall x. ClientM a -> Rep (ClientM a) x)
-> (forall x. Rep (ClientM a) x -> ClientM a)
-> Generic (ClientM a)
forall x. Rep (ClientM a) x -> ClientM a
forall x. ClientM a -> Rep (ClientM a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ClientM a) x -> ClientM a
forall a x. ClientM a -> Rep (ClientM a) x
$cfrom :: forall a x. ClientM a -> Rep (ClientM a) x
from :: forall x. ClientM a -> Rep (ClientM a) x
$cto :: forall a x. Rep (ClientM a) x -> ClientM a
to :: forall x. Rep (ClientM a) x -> ClientM a
Generic
           , MonadReader ClientEnv, MonadError ClientError)

instance MonadBase IO ClientM where
    liftBase :: forall a. IO a -> ClientM a
liftBase = ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) α
-> ClientM α
forall a.
ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientM a
ClientM (ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) α
 -> ClientM α)
-> (IO α
    -> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) α)
-> IO α
-> ClientM α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO α -> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) α
forall a.
IO a -> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Try clients in order, last error is preserved.
instance Alt ClientM where
    ClientM a
a <!> :: forall a. ClientM a -> ClientM a -> ClientM a
<!> ClientM a
b = ClientM a
a ClientM a -> (ClientError -> ClientM a) -> ClientM a
forall a. ClientM a -> (ClientError -> ClientM a) -> ClientM a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \ClientError
_ -> ClientM a
b

instance RunClient ClientM where
    runRequestAcceptStatus :: Maybe [Status] -> Request -> ClientM Response
runRequestAcceptStatus = Maybe [Status] -> Request -> ClientM Response
performRequest
    throwClientError :: forall a. ClientError -> ClientM a
throwClientError = ClientError -> ClientM a
forall a. ClientError -> ClientM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

instance RunStreamingClient ClientM where
    withStreamingRequest :: forall a. Request -> (StreamingResponse -> IO a) -> ClientM a
withStreamingRequest = Request -> (StreamingResponse -> IO a) -> ClientM a
forall a. Request -> (StreamingResponse -> IO a) -> ClientM a
performWithStreamingRequest

runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM :: forall a.
NFData a =>
ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM a
cm ClientEnv
env = ClientM a
-> ClientEnv
-> (Either ClientError a -> IO (Either ClientError a))
-> IO (Either ClientError a)
forall a b.
ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
withClientM ClientM a
cm ClientEnv
env (Either ClientError a -> IO (Either ClientError a)
forall a. a -> IO a
evaluate (Either ClientError a -> IO (Either ClientError a))
-> (Either ClientError a -> Either ClientError a)
-> Either ClientError a
-> IO (Either ClientError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ClientError a -> Either ClientError a
forall a. NFData a => a -> a
force)

withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
withClientM :: forall a b.
ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
withClientM ClientM a
cm ClientEnv
env Either ClientError a -> IO b
k =
    let Codensity forall b. (Either ClientError a -> IO b) -> IO b
f = ExceptT ClientError (Codensity IO) a
-> Codensity IO (Either ClientError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ClientError (Codensity IO) a
 -> Codensity IO (Either ClientError a))
-> ExceptT ClientError (Codensity IO) a
-> Codensity IO (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ (ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
 -> ClientEnv -> ExceptT ClientError (Codensity IO) a)
-> ClientEnv
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ExceptT ClientError (Codensity IO) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientEnv -> ExceptT ClientError (Codensity IO) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ClientEnv
env (ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
 -> ExceptT ClientError (Codensity IO) a)
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ExceptT ClientError (Codensity IO) a
forall a b. (a -> b) -> a -> b
$ ClientM a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
forall a.
ClientM a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
unClientM ClientM a
cm
    in (Either ClientError a -> IO b) -> IO b
forall b. (Either ClientError a -> IO b) -> IO b
f Either ClientError a -> IO b
k

performRequest :: Maybe [Status] -> Request -> ClientM Response
performRequest :: Maybe [Status] -> Request -> ClientM Response
performRequest Maybe [Status]
acceptStatus Request
req = do
    ClientEnv BaseUrl
burl Connection
conn <- ClientM ClientEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
    let (Request
req', OutputStream Builder -> IO ()
body) = BaseUrl -> Request -> (Request, OutputStream Builder -> IO ())
requestToClientRequest BaseUrl
burl Request
req
    Either ClientError Response
x <- ReaderT
  ClientEnv
  (ExceptT ClientError (Codensity IO))
  (Either ClientError Response)
-> ClientM (Either ClientError Response)
forall a.
ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientM a
ClientM (ReaderT
   ClientEnv
   (ExceptT ClientError (Codensity IO))
   (Either ClientError Response)
 -> ClientM (Either ClientError Response))
-> ReaderT
     ClientEnv
     (ExceptT ClientError (Codensity IO))
     (Either ClientError Response)
-> ClientM (Either ClientError Response)
forall a b. (a -> b) -> a -> b
$ ExceptT ClientError (Codensity IO) (Either ClientError Response)
-> ReaderT
     ClientEnv
     (ExceptT ClientError (Codensity IO))
     (Either ClientError Response)
forall (m :: * -> *) a. Monad m => m a -> ReaderT ClientEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT ClientError (Codensity IO) (Either ClientError Response)
 -> ReaderT
      ClientEnv
      (ExceptT ClientError (Codensity IO))
      (Either ClientError Response))
-> ExceptT ClientError (Codensity IO) (Either ClientError Response)
-> ReaderT
     ClientEnv
     (ExceptT ClientError (Codensity IO))
     (Either ClientError Response)
forall a b. (a -> b) -> a -> b
$ Codensity IO (Either ClientError Response)
-> ExceptT ClientError (Codensity IO) (Either ClientError Response)
forall (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Codensity IO (Either ClientError Response)
 -> ExceptT
      ClientError (Codensity IO) (Either ClientError Response))
-> Codensity IO (Either ClientError Response)
-> ExceptT ClientError (Codensity IO) (Either ClientError Response)
forall a b. (a -> b) -> a -> b
$ (forall b. (Either ClientError Response -> IO b) -> IO b)
-> Codensity IO (Either ClientError Response)
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (Either ClientError Response -> IO b) -> IO b)
 -> Codensity IO (Either ClientError Response))
-> (forall b. (Either ClientError Response -> IO b) -> IO b)
-> Codensity IO (Either ClientError Response)
forall a b. (a -> b) -> a -> b
$ \Either ClientError Response -> IO b
k -> do
        Connection -> Request -> (OutputStream Builder -> IO ()) -> IO ()
forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
Client.sendRequest Connection
conn Request
req' OutputStream Builder -> IO ()
body
        Connection -> (Response -> InputStream ByteString -> IO b) -> IO b
forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
Client.receiveResponse Connection
conn ((Response -> InputStream ByteString -> IO b) -> IO b)
-> (Response -> InputStream ByteString -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Response
res' InputStream ByteString
body' -> do
            let status :: Status
status = Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status) -> Int -> Status
forall a b. (a -> b) -> a -> b
$ Response -> Int
Client.getStatusCode Response
res'
            ByteString
lbs <- [ByteString] -> ByteString
BSL.fromChunks ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputStream ByteString -> IO [ByteString]
forall a. InputStream a -> IO [a]
Streams.toList InputStream ByteString
body'
            let res'' :: Response
res'' = Response -> ByteString -> Response
forall body. Response -> body -> ResponseF body
clientResponseToResponse Response
res' ByteString
lbs
                goodStatus :: Bool
goodStatus = case Maybe [Status]
acceptStatus of
                  Maybe [Status]
Nothing -> Status -> Bool
statusIsSuccessful Status
status
                  Just [Status]
good -> Status
status Status -> [Status] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Status]
good
            if Bool
goodStatus
            then Either ClientError Response -> IO b
k (Response -> Either ClientError Response
forall a b. b -> Either a b
Right Response
res'')
            else Either ClientError Response -> IO b
k (ClientError -> Either ClientError Response
forall a b. a -> Either a b
Left (BaseUrl -> Request -> Response -> ClientError
mkFailureResponse BaseUrl
burl Request
req Response
res''))

    (ClientError -> ClientM Response)
-> (Response -> ClientM Response)
-> Either ClientError Response
-> ClientM Response
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ClientError -> ClientM Response
forall a. ClientError -> ClientM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Response -> ClientM Response
forall a. a -> ClientM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ClientError Response
x

performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
performWithStreamingRequest :: forall a. Request -> (StreamingResponse -> IO a) -> ClientM a
performWithStreamingRequest Request
req StreamingResponse -> IO a
k = do
    ClientEnv BaseUrl
burl Connection
conn <- ClientM ClientEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
    let (Request
req', OutputStream Builder -> IO ()
body) = BaseUrl -> Request -> (Request, OutputStream Builder -> IO ())
requestToClientRequest BaseUrl
burl Request
req
    ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientM a
forall a.
ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientM a
ClientM (ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
 -> ClientM a)
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientM a
forall a b. (a -> b) -> a -> b
$ ExceptT ClientError (Codensity IO) a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT ClientEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT ClientError (Codensity IO) a
 -> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a)
-> ExceptT ClientError (Codensity IO) a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
forall a b. (a -> b) -> a -> b
$ Codensity IO a -> ExceptT ClientError (Codensity IO) a
forall (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Codensity IO a -> ExceptT ClientError (Codensity IO) a)
-> Codensity IO a -> ExceptT ClientError (Codensity IO) a
forall a b. (a -> b) -> a -> b
$ (forall b. (a -> IO b) -> IO b) -> Codensity IO a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (a -> IO b) -> IO b) -> Codensity IO a)
-> (forall b. (a -> IO b) -> IO b) -> Codensity IO a
forall a b. (a -> b) -> a -> b
$ \a -> IO b
k1 -> do
        Connection -> Request -> (OutputStream Builder -> IO ()) -> IO ()
forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
Client.sendRequest Connection
conn Request
req' OutputStream Builder -> IO ()
body
        Connection -> (Response -> InputStream ByteString -> IO b) -> IO b
forall β.
Connection -> (Response -> InputStream ByteString -> IO β) -> IO β
Client.receiveResponseRaw Connection
conn ((Response -> InputStream ByteString -> IO b) -> IO b)
-> (Response -> InputStream ByteString -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Response
res' InputStream ByteString
body' -> do
            -- check status code
            let status :: Status
status = Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status) -> Int -> Status
forall a b. (a -> b) -> a -> b
$ Response -> Int
Client.getStatusCode Response
res'
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Status -> Bool
statusIsSuccessful Status
status) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ByteString
lbs <- [ByteString] -> ByteString
BSL.fromChunks ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputStream ByteString -> IO [ByteString]
forall a. InputStream a -> IO [a]
Streams.toList InputStream ByteString
body'
                ClientError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ClientError -> IO ()) -> ClientError -> IO ()
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Request -> Response -> ClientError
mkFailureResponse BaseUrl
burl Request
req (Response -> ByteString -> Response
forall body. Response -> body -> ResponseF body
clientResponseToResponse Response
res' ByteString
lbs)

            a
x <- StreamingResponse -> IO a
k (Response -> SourceIO ByteString -> StreamingResponse
forall body. Response -> body -> ResponseF body
clientResponseToResponse Response
res' (InputStream ByteString -> SourceIO ByteString
forall b. InputStream b -> SourceT IO b
fromInputStream InputStream ByteString
body'))
            a -> IO b
k1 a
x

mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
mkFailureResponse :: BaseUrl -> Request -> Response -> ClientError
mkFailureResponse BaseUrl
burl Request
request =
    RequestF () (BaseUrl, ByteString) -> Response -> ClientError
FailureResponse ((RequestBody -> ())
-> (Builder -> (BaseUrl, ByteString))
-> Request
-> RequestF () (BaseUrl, ByteString)
forall a b c d.
(a -> b) -> (c -> d) -> RequestF a c -> RequestF b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (() -> RequestBody -> ()
forall a b. a -> b -> a
const ()) Builder -> (BaseUrl, ByteString)
f Request
request)
  where
    f :: Builder -> (BaseUrl, ByteString)
f Builder
b = (BaseUrl
burl, ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
b)

clientResponseToResponse :: Client.Response -> body -> ResponseF body
clientResponseToResponse :: forall body. Response -> body -> ResponseF body
clientResponseToResponse Response
r body
body = Response
    { $sel:responseStatusCode:Response :: Status
responseStatusCode  = Int -> ByteString -> Status
Status (Response -> Int
Client.getStatusCode Response
r) (Response -> ByteString
Client.getStatusMessage Response
r)
    , $sel:responseBody:Response :: body
responseBody        = body
body
    , $sel:responseHeaders:Response :: Seq Header
responseHeaders     = [Header] -> Seq Header
forall a. [a] -> Seq a
fromList ([Header] -> Seq Header) -> [Header] -> Seq Header
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> Header)
-> [(ByteString, ByteString)] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> HeaderName) -> (ByteString, ByteString) -> Header
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk) ([(ByteString, ByteString)] -> [Header])
-> [(ByteString, ByteString)] -> [Header]
forall a b. (a -> b) -> a -> b
$ Headers -> [(ByteString, ByteString)]
Client.retrieveHeaders (Headers -> [(ByteString, ByteString)])
-> Headers -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Response -> Headers
forall τ. HttpType τ => τ -> Headers
Client.getHeaders Response
r
    , $sel:responseHttpVersion:Response :: HttpVersion
responseHttpVersion = HttpVersion
http11 -- guess
    }

requestToClientRequest :: BaseUrl -> Request -> (Client.Request, Streams.OutputStream B.Builder -> IO ())
requestToClientRequest :: BaseUrl -> Request -> (Request, OutputStream Builder -> IO ())
requestToClientRequest BaseUrl
burl Request
r = (Request
request, OutputStream Builder -> IO ()
body)
  where
    request :: Request
request = RequestBuilder () -> Request
forall α. RequestBuilder α -> Request
Client.buildRequest1 (RequestBuilder () -> Request) -> RequestBuilder () -> Request
forall a b. (a -> b) -> a -> b
$ do
        Method -> ByteString -> RequestBuilder ()
Client.http (ByteString -> Method
Client.Method (ByteString -> Method) -> ByteString -> Method
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
forall body path. RequestF body path -> ByteString
requestMethod Request
r)
            (ByteString -> RequestBuilder ())
-> ByteString -> RequestBuilder ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (BaseUrl -> String
baseUrlPath BaseUrl
burl)
            ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BSL.toStrict (Builder -> ByteString
toLazyByteString (Request -> Builder
forall body path. RequestF body path -> path
requestPath Request
r))
            ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Bool -> Query -> ByteString
renderQuery Bool
True (Seq QueryItem -> Query
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Request -> Seq QueryItem
forall body path. RequestF body path -> Seq QueryItem
requestQueryString Request
r))
        -- We are connected, but we still need to know what we try to query
        ByteString -> Port -> RequestBuilder ()
Client.setHostname (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ BaseUrl -> String
baseUrlHost BaseUrl
burl) (Int -> Port
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Port) -> Int -> Port
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Int
baseUrlPort BaseUrl
burl)
        [Header] -> (Header -> RequestBuilder ()) -> RequestBuilder ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Maybe Header -> [Header]
forall a. Maybe a -> [a]
maybeToList Maybe Header
acceptHdr [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ Maybe Header -> [Header]
forall a. Maybe a -> [a]
maybeToList Maybe Header
contentTypeHdr [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header]
headers) ((Header -> RequestBuilder ()) -> RequestBuilder ())
-> (Header -> RequestBuilder ()) -> RequestBuilder ()
forall a b. (a -> b) -> a -> b
$ \(HeaderName
hn, ByteString
hv) ->
            ByteString -> ByteString -> RequestBuilder ()
Client.setHeader (HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
hn) ByteString
hv

        -- body is always chunked
        RequestBuilder ()
Client.setTransferEncoding

    -- Content-Type and Accept are specified by requestBody and requestAccept
    headers :: [Header]
headers = (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
h, ByteString
_) -> HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
"Accept" Bool -> Bool -> Bool
&& HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
"Content-Type") ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$
        Seq Header -> [Header]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Header -> [Header]) -> Seq Header -> [Header]
forall a b. (a -> b) -> a -> b
$ Request -> Seq Header
forall body path. RequestF body path -> Seq Header
requestHeaders Request
r

    acceptHdr :: Maybe Header
acceptHdr
        | [MediaType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MediaType]
hs   = Maybe Header
forall a. Maybe a
Nothing
        | Bool
otherwise = Header -> Maybe Header
forall a. a -> Maybe a
Just (HeaderName
"Accept", [MediaType] -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader [MediaType]
hs)
      where
        hs :: [MediaType]
hs = Seq MediaType -> [MediaType]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq MediaType -> [MediaType]) -> Seq MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ Request -> Seq MediaType
forall body path. RequestF body path -> Seq MediaType
requestAccept Request
r

    convertBody :: RequestBody -> OutputStream Builder -> IO ()
convertBody RequestBody
bd OutputStream Builder
os = case RequestBody
bd of
        RequestBodyLBS ByteString
body' ->
            OutputStream Builder -> Maybe Builder -> IO ()
forall a. OutputStream a -> Maybe a -> IO ()
Streams.writeTo OutputStream Builder
os (Builder -> Maybe Builder
forall a. a -> Maybe a
Just (ByteString -> Builder
B.lazyByteString ByteString
body'))
        RequestBodyBS ByteString
body' ->
            OutputStream Builder -> Maybe Builder -> IO ()
forall a. OutputStream a -> Maybe a -> IO ()
Streams.writeTo OutputStream Builder
os (Builder -> Maybe Builder
forall a. a -> Maybe a
Just (ByteString -> Builder
B.byteString ByteString
body'))
        RequestBodySource SourceIO ByteString
sourceIO ->
            SourceIO ByteString -> OutputStream Builder -> IO ()
toOutputStream SourceIO ByteString
sourceIO OutputStream Builder
os

    (OutputStream Builder -> IO ()
body, Maybe Header
contentTypeHdr) = case Request -> Maybe (RequestBody, MediaType)
forall body path. RequestF body path -> Maybe (body, MediaType)
requestBody Request
r of
        Maybe (RequestBody, MediaType)
Nothing           -> (OutputStream Builder -> IO ()
Client.emptyBody, Maybe Header
forall a. Maybe a
Nothing)
        Just (RequestBody
body', MediaType
typ) -> (RequestBody -> OutputStream Builder -> IO ()
convertBody RequestBody
body', Header -> Maybe Header
forall a. a -> Maybe a
Just (HeaderName
hContentType, MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader MediaType
typ))

catchConnectionError :: IO a -> IO (Either ClientError a)
catchConnectionError :: forall a. IO a -> IO (Either ClientError a)
catchConnectionError IO a
action =
  IO (Either ClientError a)
-> (IOException -> IO (Either ClientError a))
-> IO (Either ClientError a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (a -> Either ClientError a
forall a b. b -> Either a b
Right (a -> Either ClientError a) -> IO a -> IO (Either ClientError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action) ((IOException -> IO (Either ClientError a))
 -> IO (Either ClientError a))
-> (IOException -> IO (Either ClientError a))
-> IO (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ \IOException
e ->
    Either ClientError a -> IO (Either ClientError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ClientError a -> IO (Either ClientError a))
-> (SomeException -> Either ClientError a)
-> SomeException
-> IO (Either ClientError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientError -> Either ClientError a
forall a b. a -> Either a b
Left (ClientError -> Either ClientError a)
-> (SomeException -> ClientError)
-> SomeException
-> Either ClientError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ClientError
ConnectionError (SomeException -> IO (Either ClientError a))
-> SomeException -> IO (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ IOException -> SomeException
forall e. Exception e => e -> SomeException
SomeException (IOException
e :: IOException)

fromInputStream :: Streams.InputStream b -> S.SourceT IO b
fromInputStream :: forall b. InputStream b -> SourceT IO b
fromInputStream InputStream b
is = (forall b. (StepT IO b -> IO b) -> IO b) -> SourceT IO b
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
S.SourceT ((forall b. (StepT IO b -> IO b) -> IO b) -> SourceT IO b)
-> (forall b. (StepT IO b -> IO b) -> IO b) -> SourceT IO b
forall a b. (a -> b) -> a -> b
$ \StepT IO b -> IO b
k -> StepT IO b -> IO b
k StepT IO b
loop where
    loop :: StepT IO b
loop = IO (StepT IO b) -> StepT IO b
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
S.Effect (IO (StepT IO b) -> StepT IO b) -> IO (StepT IO b) -> StepT IO b
forall a b. (a -> b) -> a -> b
$ StepT IO b -> (b -> StepT IO b) -> Maybe b -> StepT IO b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StepT IO b
forall (m :: * -> *) a. StepT m a
S.Stop ((b -> StepT IO b -> StepT IO b) -> StepT IO b -> b -> StepT IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> StepT IO b -> StepT IO b
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
S.Yield StepT IO b
loop) (Maybe b -> StepT IO b) -> IO (Maybe b) -> IO (StepT IO b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputStream b -> IO (Maybe b)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream b
is

toOutputStream :: S.SourceT IO BSL.ByteString -> Streams.OutputStream B.Builder -> IO ()
toOutputStream :: SourceIO ByteString -> OutputStream Builder -> IO ()
toOutputStream (S.SourceT forall b. (StepT IO ByteString -> IO b) -> IO b
k) OutputStream Builder
os = (StepT IO ByteString -> IO ()) -> IO ()
forall b. (StepT IO ByteString -> IO b) -> IO b
k StepT IO ByteString -> IO ()
loop where
    loop :: StepT IO ByteString -> IO ()
loop StepT IO ByteString
S.Stop        = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    loop (S.Error String
err) = String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    loop (S.Skip StepT IO ByteString
s)    = StepT IO ByteString -> IO ()
loop StepT IO ByteString
s
    loop (S.Effect IO (StepT IO ByteString)
mx) = IO (StepT IO ByteString)
mx IO (StepT IO ByteString) -> (StepT IO ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StepT IO ByteString -> IO ()
loop
    loop (S.Yield ByteString
x StepT IO ByteString
s) = Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just (ByteString -> Builder
B.lazyByteString ByteString
x)) OutputStream Builder
os IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StepT IO ByteString -> IO ()
loop StepT IO ByteString
s