{-# 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.Semigroup
                 ((<>))
import           Data.Sequence
                 (fromList)
import           Data.String
                 (fromString)
import           GHC.Generics
import           Network.HTTP.Media
                 (renderHeader)
import           Network.HTTP.Types
                 (Status (..), hContentType, http11, renderQuery)
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 :: 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 = Hostname -> Port -> IO Connection
Client.openConnection (String -> Hostname
forall a. IsString a => String -> a
fromString (String -> Hostname) -> String -> Hostname
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 :: 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 :: 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
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
    { ClientM a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a }
  deriving ( a -> ClientM b -> ClientM a
(a -> b) -> ClientM a -> ClientM b
(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
<$ :: a -> ClientM b -> ClientM a
$c<$ :: forall a b. a -> ClientM b -> ClientM a
fmap :: (a -> b) -> ClientM a -> ClientM b
$cfmap :: forall a b. (a -> b) -> ClientM a -> ClientM b
Functor, Functor ClientM
a -> ClientM a
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
ClientM a -> ClientM b -> ClientM b
ClientM a -> ClientM b -> ClientM a
ClientM (a -> b) -> ClientM a -> ClientM b
(a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
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
<* :: ClientM a -> ClientM b -> ClientM a
$c<* :: forall a b. ClientM a -> ClientM b -> ClientM a
*> :: ClientM a -> ClientM b -> ClientM b
$c*> :: forall a b. ClientM a -> ClientM b -> ClientM b
liftA2 :: (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
$cliftA2 :: forall a b c. (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
<*> :: ClientM (a -> b) -> ClientM a -> ClientM b
$c<*> :: forall a b. ClientM (a -> b) -> ClientM a -> ClientM b
pure :: a -> ClientM a
$cpure :: forall a. a -> ClientM a
$cp1Applicative :: Functor ClientM
Applicative, Applicative ClientM
a -> ClientM a
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
ClientM a -> (a -> ClientM b) -> ClientM b
ClientM a -> ClientM b -> ClientM b
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
return :: a -> ClientM a
$creturn :: forall a. a -> ClientM a
>> :: ClientM a -> ClientM b -> ClientM b
$c>> :: forall a b. ClientM a -> ClientM b -> ClientM b
>>= :: ClientM a -> (a -> ClientM b) -> ClientM b
$c>>= :: forall a b. ClientM a -> (a -> ClientM b) -> ClientM b
$cp1Monad :: Applicative ClientM
Monad, Monad ClientM
Monad ClientM -> (forall a. IO a -> ClientM a) -> MonadIO ClientM
IO a -> ClientM a
forall a. IO a -> ClientM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> ClientM a
$cliftIO :: forall a. IO a -> ClientM a
$cp1MonadIO :: Monad ClientM
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
$cto :: forall a x. Rep (ClientM a) x -> ClientM a
$cfrom :: forall a x. ClientM a -> Rep (ClientM a) x
Generic
           , MonadReader ClientEnv, MonadError ClientError)

instance MonadBase IO ClientM where
    liftBase :: IO α -> ClientM α
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Try clients in order, last error is preserved.
instance Alt ClientM where
    ClientM a
a <!> :: ClientM a -> ClientM a -> ClientM a
<!> ClientM a
b = ClientM a
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 :: ClientError -> ClientM a
throwClientError = ClientError -> ClientM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

instance RunStreamingClient ClientM where
    withStreamingRequest :: 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 :: 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 :: 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 (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 (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 Hostname -> IO b) -> IO b
forall β.
Connection -> (Response -> InputStream Hostname -> IO β) -> IO β
Client.receiveResponse Connection
conn ((Response -> InputStream Hostname -> IO b) -> IO b)
-> (Response -> InputStream Hostname -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Response
res' InputStream Hostname
body' -> do
            let sc :: Int
sc = Response -> Int
Client.getStatusCode Response
res'
            ByteString
lbs <- [Hostname] -> ByteString
BSL.fromChunks ([Hostname] -> ByteString) -> IO [Hostname] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputStream Hostname -> IO [Hostname]
forall a. InputStream a -> IO [a]
Streams.toList InputStream Hostname
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 -> Int
sc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
sc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300
                  Just [Status]
good -> Int
sc Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Status -> Int
statusCode (Status -> Int) -> [Status] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError Response -> ClientM Response
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ClientError Response
x

performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
performWithStreamingRequest :: 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 (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 (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 Hostname -> IO b) -> IO b
forall β.
Connection -> (Response -> InputStream Hostname -> IO β) -> IO β
Client.receiveResponseRaw Connection
conn ((Response -> InputStream Hostname -> IO b) -> IO b)
-> (Response -> InputStream Hostname -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Response
res' InputStream Hostname
body' -> do
            -- check status code
            let sc :: Int
sc = Response -> Int
Client.getStatusCode Response
res'
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
sc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
sc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ByteString
lbs <- [Hostname] -> ByteString
BSL.fromChunks ([Hostname] -> ByteString) -> IO [Hostname] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputStream Hostname -> IO [Hostname]
forall a. InputStream a -> IO [a]
Streams.toList InputStream Hostname
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 -> SourceT IO Hostname -> StreamingResponse
forall body. Response -> body -> ResponseF body
clientResponseToResponse Response
res' (InputStream Hostname -> SourceT IO Hostname
forall b. InputStream b -> SourceT IO b
fromInputStream InputStream Hostname
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, Hostname) -> Response -> ClientError
FailureResponse ((RequestBody -> ())
-> (Builder -> (BaseUrl, Hostname))
-> Request
-> RequestF () (BaseUrl, Hostname)
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, Hostname)
f Request
request)
  where
    f :: Builder -> (BaseUrl, Hostname)
f Builder
b = (BaseUrl
burl, ByteString -> Hostname
BSL.toStrict (ByteString -> Hostname) -> ByteString -> Hostname
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
b)

clientResponseToResponse :: Client.Response -> body -> ResponseF body
clientResponseToResponse :: Response -> body -> ResponseF body
clientResponseToResponse Response
r body
body = Response :: forall a. Status -> Seq Header -> HttpVersion -> a -> ResponseF a
Response
    { responseStatusCode :: Status
responseStatusCode  = Int -> Hostname -> Status
Status (Response -> Int
Client.getStatusCode Response
r) (Response -> Hostname
Client.getStatusMessage Response
r)
    , responseBody :: body
responseBody        = body
body
    , responseHeaders :: 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
$ ((Hostname, Hostname) -> Header)
-> [(Hostname, Hostname)] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map ((Hostname -> CI Hostname) -> (Hostname, Hostname) -> Header
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Hostname -> CI Hostname
forall s. FoldCase s => s -> CI s
CI.mk) ([(Hostname, Hostname)] -> [Header])
-> [(Hostname, Hostname)] -> [Header]
forall a b. (a -> b) -> a -> b
$ Headers -> [(Hostname, Hostname)]
Client.retrieveHeaders (Headers -> [(Hostname, Hostname)])
-> Headers -> [(Hostname, Hostname)]
forall a b. (a -> b) -> a -> b
$ Response -> Headers
forall τ. HttpType τ => τ -> Headers
Client.getHeaders Response
r
    , responseHttpVersion :: 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 -> Hostname -> RequestBuilder ()
Client.http (Hostname -> Method
Client.Method (Hostname -> Method) -> Hostname -> Method
forall a b. (a -> b) -> a -> b
$ Request -> Hostname
forall body path. RequestF body path -> Hostname
requestMethod Request
r)
            (Hostname -> RequestBuilder ()) -> Hostname -> RequestBuilder ()
forall a b. (a -> b) -> a -> b
$ String -> Hostname
forall a. IsString a => String -> a
fromString (BaseUrl -> String
baseUrlPath BaseUrl
burl)
            Hostname -> Hostname -> Hostname
forall a. Semigroup a => a -> a -> a
<> ByteString -> Hostname
BSL.toStrict (Builder -> ByteString
toLazyByteString (Request -> Builder
forall body path. RequestF body path -> path
requestPath Request
r))
            Hostname -> Hostname -> Hostname
forall a. Semigroup a => a -> a -> a
<> Bool -> Query -> Hostname
renderQuery Bool
True (Seq QueryItem -> Query
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
        Hostname -> Port -> RequestBuilder ()
Client.setHostname (String -> Hostname
forall a. IsString a => String -> a
fromString (String -> Hostname) -> String -> Hostname
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
$ \(CI Hostname
hn, Hostname
hv) ->
            Hostname -> Hostname -> RequestBuilder ()
Client.setHeader (CI Hostname -> Hostname
forall s. CI s -> s
CI.original CI Hostname
hn) Hostname
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 (\(CI Hostname
h, Hostname
_) -> CI Hostname
h CI Hostname -> CI Hostname -> Bool
forall a. Eq a => a -> a -> Bool
/= CI Hostname
"Accept" Bool -> Bool -> Bool
&& CI Hostname
h CI Hostname -> CI Hostname -> Bool
forall a. Eq a => a -> a -> Bool
/= CI Hostname
"Content-Type") ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$
        Seq Header -> [Header]
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 (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 (CI Hostname
"Accept", [MediaType] -> Hostname
forall h. RenderHeader h => h -> Hostname
renderHeader [MediaType]
hs)
      where
        hs :: [MediaType]
hs = Seq MediaType -> [MediaType]
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 Hostname
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 (Hostname -> Builder
B.byteString Hostname
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 (CI Hostname
hContentType, MediaType -> Hostname
forall h. RenderHeader h => h -> Hostname
renderHeader MediaType
typ))

catchConnectionError :: IO a -> IO (Either ClientError a)
catchConnectionError :: 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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return ()
    loop (S.Error String
err) = String -> IO ()
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StepT IO ByteString -> IO ()
loop StepT IO ByteString
s