{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Bilge.IO
  ( -- * Convenience API
    HttpT (..),
    Http,
    MonadHttp (..),
    handleRequest,
    Debug (..),
    runHttpT,
    http,
    httpLbs,
    httpDebug,
    get,
    get',
    put,
    put',
    post,
    post',
    head,
    head',
    delete,
    delete',
    options,
    options',
    trace,
    trace',
    patch,
    patch',
    consumeBody,

    -- * Re-exports
    ManagerSettings (..),
    withResponse,
    Manager,
    newManager,
    withManager,
    defaultManagerSettings,
    BodyReader,
    brRead,
    brConsume,
    HttpException (..),
  )
where

-- It's impossible to create a Response body without using internals :'(

import Bilge.Request
import Bilge.Response
import Bilge.TestSession
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Trans.Control
import Data.ByteString.Lazy qualified as LBS
import Data.CaseInsensitive (CI)
import Imports hiding (head)
import Network.HTTP.Client as Client hiding (httpLbs, method)
import Network.HTTP.Client qualified as Client (method)
import Network.HTTP.Client.Internal qualified as Client (Response (..), ResponseClose (..))
import Network.HTTP.Types
import Network.Wai qualified as Wai
import Network.Wai.Test qualified as WaiTest

-- | Debug settings may cause debug information to be printed to stdout.
data Debug
  = -- | Print HTTP request/response header.
    Head
  | -- | Like 'Head' but also print the response body.
    Full
  deriving (Debug -> Debug -> Bool
(Debug -> Debug -> Bool) -> (Debug -> Debug -> Bool) -> Eq Debug
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Debug -> Debug -> Bool
== :: Debug -> Debug -> Bool
$c/= :: Debug -> Debug -> Bool
/= :: Debug -> Debug -> Bool
Eq, Eq Debug
Eq Debug =>
(Debug -> Debug -> Ordering)
-> (Debug -> Debug -> Bool)
-> (Debug -> Debug -> Bool)
-> (Debug -> Debug -> Bool)
-> (Debug -> Debug -> Bool)
-> (Debug -> Debug -> Debug)
-> (Debug -> Debug -> Debug)
-> Ord Debug
Debug -> Debug -> Bool
Debug -> Debug -> Ordering
Debug -> Debug -> Debug
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Debug -> Debug -> Ordering
compare :: Debug -> Debug -> Ordering
$c< :: Debug -> Debug -> Bool
< :: Debug -> Debug -> Bool
$c<= :: Debug -> Debug -> Bool
<= :: Debug -> Debug -> Bool
$c> :: Debug -> Debug -> Bool
> :: Debug -> Debug -> Bool
$c>= :: Debug -> Debug -> Bool
>= :: Debug -> Debug -> Bool
$cmax :: Debug -> Debug -> Debug
max :: Debug -> Debug -> Debug
$cmin :: Debug -> Debug -> Debug
min :: Debug -> Debug -> Debug
Ord, Int -> Debug -> ShowS
[Debug] -> ShowS
Debug -> String
(Int -> Debug -> ShowS)
-> (Debug -> String) -> ([Debug] -> ShowS) -> Show Debug
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Debug -> ShowS
showsPrec :: Int -> Debug -> ShowS
$cshow :: Debug -> String
show :: Debug -> String
$cshowList :: [Debug] -> ShowS
showList :: [Debug] -> ShowS
Show, Int -> Debug
Debug -> Int
Debug -> [Debug]
Debug -> Debug
Debug -> Debug -> [Debug]
Debug -> Debug -> Debug -> [Debug]
(Debug -> Debug)
-> (Debug -> Debug)
-> (Int -> Debug)
-> (Debug -> Int)
-> (Debug -> [Debug])
-> (Debug -> Debug -> [Debug])
-> (Debug -> Debug -> [Debug])
-> (Debug -> Debug -> Debug -> [Debug])
-> Enum Debug
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Debug -> Debug
succ :: Debug -> Debug
$cpred :: Debug -> Debug
pred :: Debug -> Debug
$ctoEnum :: Int -> Debug
toEnum :: Int -> Debug
$cfromEnum :: Debug -> Int
fromEnum :: Debug -> Int
$cenumFrom :: Debug -> [Debug]
enumFrom :: Debug -> [Debug]
$cenumFromThen :: Debug -> Debug -> [Debug]
enumFromThen :: Debug -> Debug -> [Debug]
$cenumFromTo :: Debug -> Debug -> [Debug]
enumFromTo :: Debug -> Debug -> [Debug]
$cenumFromThenTo :: Debug -> Debug -> Debug -> [Debug]
enumFromThenTo :: Debug -> Debug -> Debug -> [Debug]
Enum)

type Http = HttpT IO

newtype HttpT m a = HttpT
  { forall (m :: * -> *) a. HttpT m a -> ReaderT Manager m a
unwrap :: ReaderT Manager m a
  }
  deriving
    ( (forall a b. (a -> b) -> HttpT m a -> HttpT m b)
-> (forall a b. a -> HttpT m b -> HttpT m a) -> Functor (HttpT m)
forall a b. a -> HttpT m b -> HttpT m a
forall a b. (a -> b) -> HttpT m a -> HttpT m b
forall (m :: * -> *) a b. Functor m => a -> HttpT m b -> HttpT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> HttpT m a -> HttpT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> HttpT m a -> HttpT m b
fmap :: forall a b. (a -> b) -> HttpT m a -> HttpT m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> HttpT m b -> HttpT m a
<$ :: forall a b. a -> HttpT m b -> HttpT m a
Functor,
      Functor (HttpT m)
Functor (HttpT m) =>
(forall a. a -> HttpT m a)
-> (forall a b. HttpT m (a -> b) -> HttpT m a -> HttpT m b)
-> (forall a b c.
    (a -> b -> c) -> HttpT m a -> HttpT m b -> HttpT m c)
-> (forall a b. HttpT m a -> HttpT m b -> HttpT m b)
-> (forall a b. HttpT m a -> HttpT m b -> HttpT m a)
-> Applicative (HttpT m)
forall a. a -> HttpT m a
forall a b. HttpT m a -> HttpT m b -> HttpT m a
forall a b. HttpT m a -> HttpT m b -> HttpT m b
forall a b. HttpT m (a -> b) -> HttpT m a -> HttpT m b
forall a b c. (a -> b -> c) -> HttpT m a -> HttpT m b -> HttpT m 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
forall (m :: * -> *). Applicative m => Functor (HttpT m)
forall (m :: * -> *) a. Applicative m => a -> HttpT m a
forall (m :: * -> *) a b.
Applicative m =>
HttpT m a -> HttpT m b -> HttpT m a
forall (m :: * -> *) a b.
Applicative m =>
HttpT m a -> HttpT m b -> HttpT m b
forall (m :: * -> *) a b.
Applicative m =>
HttpT m (a -> b) -> HttpT m a -> HttpT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> HttpT m a -> HttpT m b -> HttpT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> HttpT m a
pure :: forall a. a -> HttpT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
HttpT m (a -> b) -> HttpT m a -> HttpT m b
<*> :: forall a b. HttpT m (a -> b) -> HttpT m a -> HttpT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> HttpT m a -> HttpT m b -> HttpT m c
liftA2 :: forall a b c. (a -> b -> c) -> HttpT m a -> HttpT m b -> HttpT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
HttpT m a -> HttpT m b -> HttpT m b
*> :: forall a b. HttpT m a -> HttpT m b -> HttpT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
HttpT m a -> HttpT m b -> HttpT m a
<* :: forall a b. HttpT m a -> HttpT m b -> HttpT m a
Applicative,
      Applicative (HttpT m)
Applicative (HttpT m) =>
(forall a b. HttpT m a -> (a -> HttpT m b) -> HttpT m b)
-> (forall a b. HttpT m a -> HttpT m b -> HttpT m b)
-> (forall a. a -> HttpT m a)
-> Monad (HttpT m)
forall a. a -> HttpT m a
forall a b. HttpT m a -> HttpT m b -> HttpT m b
forall a b. HttpT m a -> (a -> HttpT m b) -> HttpT m b
forall (m :: * -> *). Monad m => Applicative (HttpT m)
forall (m :: * -> *) a. Monad m => a -> HttpT m a
forall (m :: * -> *) a b.
Monad m =>
HttpT m a -> HttpT m b -> HttpT m b
forall (m :: * -> *) a b.
Monad m =>
HttpT m a -> (a -> HttpT m b) -> HttpT m 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 (m :: * -> *) a b.
Monad m =>
HttpT m a -> (a -> HttpT m b) -> HttpT m b
>>= :: forall a b. HttpT m a -> (a -> HttpT m b) -> HttpT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
HttpT m a -> HttpT m b -> HttpT m b
>> :: forall a b. HttpT m a -> HttpT m b -> HttpT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> HttpT m a
return :: forall a. a -> HttpT m a
Monad,
      Monad (HttpT m)
Monad (HttpT m) =>
(forall a. IO a -> HttpT m a) -> MonadIO (HttpT m)
forall a. IO a -> HttpT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (HttpT m)
forall (m :: * -> *) a. MonadIO m => IO a -> HttpT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> HttpT m a
liftIO :: forall a. IO a -> HttpT m a
MonadIO,
      Monad (HttpT m)
Monad (HttpT m) =>
(forall e a. (HasCallStack, Exception e) => e -> HttpT m a)
-> MonadThrow (HttpT m)
forall e a. (HasCallStack, Exception e) => e -> HttpT m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (HttpT m)
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> HttpT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> HttpT m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> HttpT m a
MonadThrow,
      MonadThrow (HttpT m)
MonadThrow (HttpT m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 HttpT m a -> (e -> HttpT m a) -> HttpT m a)
-> MonadCatch (HttpT m)
forall e a.
(HasCallStack, Exception e) =>
HttpT m a -> (e -> HttpT m a) -> HttpT m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
forall (m :: * -> *). MonadCatch m => MonadThrow (HttpT m)
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
HttpT m a -> (e -> HttpT m a) -> HttpT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
HttpT m a -> (e -> HttpT m a) -> HttpT m a
catch :: forall e a.
(HasCallStack, Exception e) =>
HttpT m a -> (e -> HttpT m a) -> HttpT m a
MonadCatch,
      MonadCatch (HttpT m)
MonadCatch (HttpT m) =>
(forall b.
 HasCallStack =>
 ((forall a. HttpT m a -> HttpT m a) -> HttpT m b) -> HttpT m b)
-> (forall b.
    HasCallStack =>
    ((forall a. HttpT m a -> HttpT m a) -> HttpT m b) -> HttpT m b)
-> (forall a b c.
    HasCallStack =>
    HttpT m a
    -> (a -> ExitCase b -> HttpT m c)
    -> (a -> HttpT m b)
    -> HttpT m (b, c))
-> MonadMask (HttpT m)
forall b.
HasCallStack =>
((forall a. HttpT m a -> HttpT m a) -> HttpT m b) -> HttpT m b
forall a b c.
HasCallStack =>
HttpT m a
-> (a -> ExitCase b -> HttpT m c)
-> (a -> HttpT m b)
-> HttpT m (b, c)
forall (m :: * -> *). MonadMask m => MonadCatch (HttpT m)
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. HttpT m a -> HttpT m a) -> HttpT m b) -> HttpT m b
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
HttpT m a
-> (a -> ExitCase b -> HttpT m c)
-> (a -> HttpT m b)
-> HttpT m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. HttpT m a -> HttpT m a) -> HttpT m b) -> HttpT m b
mask :: forall b.
HasCallStack =>
((forall a. HttpT m a -> HttpT m a) -> HttpT m b) -> HttpT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. HttpT m a -> HttpT m a) -> HttpT m b) -> HttpT m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. HttpT m a -> HttpT m a) -> HttpT m b) -> HttpT m b
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
HttpT m a
-> (a -> ExitCase b -> HttpT m c)
-> (a -> HttpT m b)
-> HttpT m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
HttpT m a
-> (a -> ExitCase b -> HttpT m c)
-> (a -> HttpT m b)
-> HttpT m (b, c)
MonadMask,
      (forall (m :: * -> *). Monad m => Monad (HttpT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> HttpT m a)
-> MonadTrans HttpT
forall (m :: * -> *). Monad m => Monad (HttpT m)
forall (m :: * -> *) a. Monad m => m a -> HttpT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> HttpT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> HttpT m a
MonadTrans,
      MonadReader Manager,
      Monad (HttpT m)
Monad (HttpT m) =>
(forall a. String -> HttpT m a) -> MonadFail (HttpT m)
forall a. String -> HttpT m a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
forall (m :: * -> *). MonadFail m => Monad (HttpT m)
forall (m :: * -> *) a. MonadFail m => String -> HttpT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> HttpT m a
fail :: forall a. String -> HttpT m a
MonadFail
    )

class MonadHttp m where
  handleRequestWithCont :: Request -> (Response BodyReader -> IO a) -> m a
  {-# MINIMAL handleRequestWithCont #-}

handleRequest :: (MonadHttp m) => Request -> m (Response (Maybe LByteString))
handleRequest :: forall (m :: * -> *).
MonadHttp m =>
Request -> m (Response (Maybe LByteString))
handleRequest Request
req = Request
-> (Response BodyReader -> IO (Response (Maybe LByteString)))
-> m (Response (Maybe LByteString))
forall a. Request -> (Response BodyReader -> IO a) -> m a
forall (m :: * -> *) a.
MonadHttp m =>
Request -> (Response BodyReader -> IO a) -> m a
handleRequestWithCont Request
req Response BodyReader -> IO (Response (Maybe LByteString))
consumeBody

instance (MonadIO m) => MonadHttp (HttpT m) where
  handleRequestWithCont :: Request -> (Response BodyReader -> IO a) -> HttpT m a
  handleRequestWithCont :: forall a. Request -> (Response BodyReader -> IO a) -> HttpT m a
handleRequestWithCont Request
req Response BodyReader -> IO a
h = do
    Manager
m <- HttpT m Manager
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO a -> HttpT m a
forall a. IO a -> HttpT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> HttpT m a) -> IO a -> HttpT m a
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> (Response BodyReader -> IO a) -> IO a
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
m Response BodyReader -> IO a
h

-- | Returns the entire ByteString immediately on first read
-- then empty ByteString on all subsequent reads.
-- This is used for back-compatability on MonadHttp so that we can write an instance for
-- MonadHttp of Wai.Session while maintaining compatability with the previous interface.
trivialBodyReader :: ByteString -> IO BodyReader
trivialBodyReader :: ByteString -> IO BodyReader
trivialBodyReader ByteString
bodyBytes = do
  TVar ByteString
bodyVar <- ByteString -> IO (TVar ByteString)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ByteString
bodyBytes
  BodyReader -> IO BodyReader
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BodyReader -> IO BodyReader) -> BodyReader -> IO BodyReader
forall a b. (a -> b) -> a -> b
$ TVar ByteString -> BodyReader
mkBodyReader TVar ByteString
bodyVar
  where
    mkBodyReader :: TVar ByteString -> BodyReader
    mkBodyReader :: TVar ByteString -> BodyReader
mkBodyReader TVar ByteString
bodyVar = do
      STM ByteString -> BodyReader
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ByteString -> BodyReader) -> STM ByteString -> BodyReader
forall a b. (a -> b) -> a -> b
$ TVar ByteString -> ByteString -> STM ByteString
forall a. TVar a -> a -> STM a
swapTVar TVar ByteString
bodyVar ByteString
""

instance MonadHttp WaiTest.Session where
  handleRequestWithCont :: forall a. Request -> (Response BodyReader -> IO a) -> Session a
handleRequestWithCont Request
req Response BodyReader -> IO a
cont = SessionT IO a -> ReaderT Application (StateT ClientState IO) a
forall (m :: * -> *) a.
SessionT m a -> ReaderT Application (StateT ClientState m) a
unSessionT (SessionT IO a -> ReaderT Application (StateT ClientState IO) a)
-> SessionT IO a -> ReaderT Application (StateT ClientState IO) a
forall a b. (a -> b) -> a -> b
$ Request -> (Response BodyReader -> IO a) -> SessionT IO a
forall a. Request -> (Response BodyReader -> IO a) -> SessionT IO a
forall (m :: * -> *) a.
MonadHttp m =>
Request -> (Response BodyReader -> IO a) -> m a
handleRequestWithCont Request
req Response BodyReader -> IO a
cont

instance (MonadIO m) => MonadHttp (SessionT m) where
  handleRequestWithCont :: forall a. Request -> (Response BodyReader -> IO a) -> SessionT m a
handleRequestWithCont Request
req Response BodyReader -> IO a
cont = do
    LByteString
reqBody <- IO LByteString -> SessionT m LByteString
forall a. IO a -> SessionT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LByteString -> SessionT m LByteString)
-> IO LByteString -> SessionT m LByteString
forall a b. (a -> b) -> a -> b
$ HasCallStack => RequestBody -> IO LByteString
RequestBody -> IO LByteString
getHttpClientRequestBody (Request -> RequestBody
Client.requestBody Request
req)
    -- `srequest` sets the requestBody for us
    SResponse
wResponse :: WaiTest.SResponse <- Session SResponse -> SessionT m SResponse
forall (m :: * -> *) a. MonadIO m => Session a -> SessionT m a
liftSession (Session SResponse -> SessionT m SResponse)
-> Session SResponse -> SessionT m SResponse
forall a b. (a -> b) -> a -> b
$ SRequest -> Session SResponse
WaiTest.srequest (Request -> LByteString -> SRequest
WaiTest.SRequest Request
wRequest LByteString
reqBody)
    BodyReader
bodyReader <- IO BodyReader -> SessionT m BodyReader
forall a. IO a -> SessionT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BodyReader -> SessionT m BodyReader)
-> IO BodyReader -> SessionT m BodyReader
forall a b. (a -> b) -> a -> b
$ ByteString -> IO BodyReader
trivialBodyReader (ByteString -> IO BodyReader) -> ByteString -> IO BodyReader
forall a b. (a -> b) -> a -> b
$ LByteString -> ByteString
LBS.toStrict (LByteString -> ByteString) -> LByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SResponse -> LByteString
WaiTest.simpleBody SResponse
wResponse
    let bilgeResponse :: Response BodyReader
        bilgeResponse :: Response BodyReader
bilgeResponse = BodyReader -> SResponse -> Request -> Response BodyReader
toBilgeResponse BodyReader
bodyReader SResponse
wResponse Request
req

    IO a -> SessionT m a
forall a. IO a -> SessionT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> SessionT m a) -> IO a -> SessionT m a
forall a b. (a -> b) -> a -> b
$ Response BodyReader -> IO a
cont Response BodyReader
bilgeResponse
    where
      wRequest :: Wai.Request
      wRequest :: Request
wRequest =
        (Request -> ByteString -> Request)
-> ByteString -> Request -> Request
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> ByteString -> Request
WaiTest.setPath (Request -> ByteString
Client.path Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Client.queryString Request
req) (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$
          Request
Wai.defaultRequest
            { Wai.requestMethod = Client.method req,
              Wai.httpVersion = Client.requestVersion req,
              Wai.requestHeaders = Client.requestHeaders req,
              Wai.isSecure = Client.secure req,
              Wai.requestHeaderHost = lookupHeader "HOST" req,
              Wai.requestHeaderRange = lookupHeader "RANGE" req,
              Wai.requestHeaderReferer = lookupHeader "REFERER" req,
              Wai.requestHeaderUserAgent = lookupHeader "USER-AGENT" req
            }
      toBilgeResponse :: BodyReader -> WaiTest.SResponse -> Client.Request -> Response BodyReader
      toBilgeResponse :: BodyReader -> SResponse -> Request -> Response BodyReader
toBilgeResponse BodyReader
bodyReader WaiTest.SResponse {Status
simpleStatus :: Status
simpleStatus :: SResponse -> Status
WaiTest.simpleStatus, RequestHeaders
simpleHeaders :: RequestHeaders
simpleHeaders :: SResponse -> RequestHeaders
WaiTest.simpleHeaders} Request
originalReq =
        Client.Response
          { responseStatus :: Status
responseStatus = Status
simpleStatus,
            -- I just picked an arbitrary version; shouldn't matter.
            responseVersion :: HttpVersion
responseVersion = HttpVersion
http11,
            responseHeaders :: RequestHeaders
responseHeaders = RequestHeaders
simpleHeaders,
            responseBody :: BodyReader
responseBody = BodyReader
bodyReader,
            responseOriginalRequest :: Request
responseOriginalRequest = Request
originalReq,
            responseEarlyHints :: RequestHeaders
responseEarlyHints = [],
            responseCookieJar :: CookieJar
Client.responseCookieJar = CookieJar
forall a. Monoid a => a
mempty,
            responseClose' :: ResponseClose
Client.responseClose' = IO () -> ResponseClose
Client.ResponseClose (IO () -> ResponseClose) -> IO () -> ResponseClose
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          }
      lookupHeader :: CI ByteString -> Client.Request -> Maybe ByteString
      lookupHeader :: CI ByteString -> Request -> Maybe ByteString
lookupHeader CI ByteString
headerName Request
r = CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
headerName (Request -> RequestHeaders
Client.requestHeaders Request
r)

-- | Does not support all constructors, but so far we only use 'RequestBodyLBS'.
-- The other ones are slightly less straight-forward, so we can implement them later if needed.
getHttpClientRequestBody :: (HasCallStack) => Client.RequestBody -> IO LByteString
getHttpClientRequestBody :: HasCallStack => RequestBody -> IO LByteString
getHttpClientRequestBody = \case
  Client.RequestBodyLBS LByteString
lbs -> LByteString -> IO LByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LByteString
lbs
  Client.RequestBodyBS ByteString
bs -> LByteString -> IO LByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> LByteString
LBS.fromStrict ByteString
bs)
  Client.RequestBodyBuilder Int64
_ Builder
_ -> String -> IO LByteString
forall {a}. String -> a
notImplemented String
"RequestBodyBuilder"
  Client.RequestBodyStream Int64
_ GivesPopper ()
_ -> String -> IO LByteString
forall {a}. String -> a
notImplemented String
"RequestBodyStream"
  Client.RequestBodyStreamChunked GivesPopper ()
_ -> String -> IO LByteString
forall {a}. String -> a
notImplemented String
"RequestBodyStreamChunked"
  Client.RequestBodyIO IO RequestBody
_ -> String -> IO LByteString
forall {a}. String -> a
notImplemented String
"RequestBodyIO"
  where
    notImplemented :: String -> a
notImplemented String
x = String -> a
forall a. HasCallStack => String -> a
error (String
"getHttpClientRequestBody: not implemented: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
x)

instance {-# OVERLAPPABLE #-} (MonadTrans t, MonadHttp m, Monad m) => MonadHttp (t m) where
  handleRequestWithCont :: forall a. Request -> (Response BodyReader -> IO a) -> t m a
handleRequestWithCont Request
req Response BodyReader -> IO a
cont = m a -> t m a
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> t m a) -> m a -> t m a
forall a b. (a -> b) -> a -> b
$ Request -> (Response BodyReader -> IO a) -> m a
forall a. Request -> (Response BodyReader -> IO a) -> m a
forall (m :: * -> *) a.
MonadHttp m =>
Request -> (Response BodyReader -> IO a) -> m a
handleRequestWithCont Request
req Response BodyReader -> IO a
cont

instance MonadBase IO (HttpT IO) where
  liftBase :: forall α. IO α -> HttpT IO α
liftBase = IO α -> HttpT IO α
forall α. IO α -> HttpT IO α
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance MonadTransControl HttpT where
  type StT HttpT a = StT (ReaderT Manager) a
  liftWith :: forall (m :: * -> *) a. Monad m => (Run HttpT -> m a) -> HttpT m a
liftWith = (forall b. ReaderT Manager m b -> HttpT m b)
-> (forall (m :: * -> *) a. HttpT m a -> ReaderT Manager m a)
-> (RunDefault HttpT (ReaderT Manager) -> m a)
-> HttpT m a
forall (m :: * -> *) (n :: (* -> *) -> * -> *)
       (t :: (* -> *) -> * -> *) a.
(Monad m, MonadTransControl n) =>
(forall b. n m b -> t m b)
-> (forall (o :: * -> *) b. t o b -> n o b)
-> (RunDefault t n -> m a)
-> t m a
defaultLiftWith ReaderT Manager m b -> HttpT m b
forall b. ReaderT Manager m b -> HttpT m b
forall (m :: * -> *) a. ReaderT Manager m a -> HttpT m a
HttpT HttpT o b -> ReaderT Manager o b
forall (m :: * -> *) a. HttpT m a -> ReaderT Manager m a
unwrap
  restoreT :: forall (m :: * -> *) a. Monad m => m (StT HttpT a) -> HttpT m a
restoreT = (ReaderT Manager m a -> HttpT m a)
-> m (StT (ReaderT Manager) a) -> HttpT m a
forall (m :: * -> *) (n :: (* -> *) -> * -> *) a
       (t :: (* -> *) -> * -> *).
(Monad m, MonadTransControl n) =>
(n m a -> t m a) -> m (StT n a) -> t m a
defaultRestoreT ReaderT Manager m a -> HttpT m a
forall (m :: * -> *) a. ReaderT Manager m a -> HttpT m a
HttpT

instance MonadBaseControl IO (HttpT IO) where
  type StM (HttpT IO) a = ComposeSt HttpT IO a
  liftBaseWith :: forall a. (RunInBase (HttpT IO) IO -> IO a) -> HttpT IO a
liftBaseWith = (RunInBaseDefault HttpT IO IO -> IO a) -> HttpT IO a
(RunInBase (HttpT IO) IO -> IO a) -> HttpT IO a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. StM (HttpT IO) a -> HttpT IO a
restoreM = ComposeSt HttpT IO a -> HttpT IO a
StM (HttpT IO) a -> HttpT IO a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
defaultRestoreM

instance (MonadUnliftIO m) => MonadUnliftIO (HttpT m) where
  withRunInIO :: forall b. ((forall a. HttpT m a -> IO a) -> IO b) -> HttpT m b
withRunInIO (forall a. HttpT m a -> IO a) -> IO b
inner =
    ReaderT Manager m b -> HttpT m b
forall (m :: * -> *) a. ReaderT Manager m a -> HttpT m a
HttpT (ReaderT Manager m b -> HttpT m b)
-> ((Manager -> m b) -> ReaderT Manager m b)
-> (Manager -> m b)
-> HttpT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Manager -> m b) -> ReaderT Manager m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Manager -> m b) -> HttpT m b) -> (Manager -> m b) -> HttpT m b
forall a b. (a -> b) -> a -> b
$ \Manager
r ->
      ((forall a. m a -> IO a) -> IO b) -> m b
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
        (forall a. HttpT m a -> IO a) -> IO b
inner (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> (HttpT m a -> m a) -> HttpT m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Manager -> HttpT m a -> m a
forall (m :: * -> *) a. Manager -> HttpT m a -> m a
runHttpT Manager
r)

runHttpT :: Manager -> HttpT m a -> m a
runHttpT :: forall (m :: * -> *) a. Manager -> HttpT m a -> m a
runHttpT Manager
m HttpT m a
h = ReaderT Manager m a -> Manager -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (HttpT m a -> ReaderT Manager m a
forall (m :: * -> *) a. HttpT m a -> ReaderT Manager m a
unwrap HttpT m a
h) Manager
m

-- | Given a 'Request' builder function, perform an actual HTTP request using the
-- respective method and return the response, fully consuming the response body
-- as a lazy 'ByteString'.
get,
  post,
  put,
  head,
  delete,
  options,
  trace,
  patch ::
    (MonadHttp m) =>
    (Request -> Request) ->
    m (Response (Maybe LByteString))
get :: forall (m :: * -> *).
MonadHttp m =>
(Request -> Request) -> m (Response (Maybe LByteString))
get Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
empty (StdMethod -> Request -> Request
method StdMethod
GET (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
post :: forall (m :: * -> *).
MonadHttp m =>
(Request -> Request) -> m (Response (Maybe LByteString))
post Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
empty (StdMethod -> Request -> Request
method StdMethod
POST (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
put :: forall (m :: * -> *).
MonadHttp m =>
(Request -> Request) -> m (Response (Maybe LByteString))
put Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
empty (StdMethod -> Request -> Request
method StdMethod
PUT (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
head :: forall (m :: * -> *).
MonadHttp m =>
(Request -> Request) -> m (Response (Maybe LByteString))
head Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
empty (StdMethod -> Request -> Request
method StdMethod
HEAD (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
delete :: forall (m :: * -> *).
MonadHttp m =>
(Request -> Request) -> m (Response (Maybe LByteString))
delete Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
empty (StdMethod -> Request -> Request
method StdMethod
DELETE (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
options :: forall (m :: * -> *).
MonadHttp m =>
(Request -> Request) -> m (Response (Maybe LByteString))
options Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
empty (StdMethod -> Request -> Request
method StdMethod
OPTIONS (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
trace :: forall (m :: * -> *).
MonadHttp m =>
(Request -> Request) -> m (Response (Maybe LByteString))
trace Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
empty (StdMethod -> Request -> Request
method StdMethod
TRACE (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
patch :: forall (m :: * -> *).
MonadHttp m =>
(Request -> Request) -> m (Response (Maybe LByteString))
patch Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
empty (StdMethod -> Request -> Request
method StdMethod
PATCH (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)

get',
  post',
  put',
  head',
  delete',
  options',
  trace',
  patch' ::
    (MonadHttp m) =>
    Request ->
    (Request -> Request) ->
    m (Response (Maybe LByteString))
get' :: forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
get' Request
r Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
r (StdMethod -> Request -> Request
method StdMethod
GET (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
post' :: forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
post' Request
r Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
r (StdMethod -> Request -> Request
method StdMethod
POST (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
put' :: forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
put' Request
r Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
r (StdMethod -> Request -> Request
method StdMethod
PUT (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
head' :: forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
head' Request
r Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
r (StdMethod -> Request -> Request
method StdMethod
HEAD (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
delete' :: forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
delete' Request
r Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
r (StdMethod -> Request -> Request
method StdMethod
DELETE (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
options' :: forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
options' Request
r Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
r (StdMethod -> Request -> Request
method StdMethod
OPTIONS (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
trace' :: forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
trace' Request
r Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
r (StdMethod -> Request -> Request
method StdMethod
TRACE (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)
patch' :: forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
patch' Request
r Request -> Request
f = Request -> (Request -> Request) -> m (Response (Maybe LByteString))
forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
r (StdMethod -> Request -> Request
method StdMethod
PATCH (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
f)

httpLbs ::
  (MonadHttp m) =>
  Request ->
  (Request -> Request) ->
  m (Response (Maybe LByteString))
httpLbs :: forall (m :: * -> *).
MonadHttp m =>
Request -> (Request -> Request) -> m (Response (Maybe LByteString))
httpLbs Request
r Request -> Request
f = Request
-> (Request -> Request)
-> (Response BodyReader -> IO (Response (Maybe LByteString)))
-> m (Response (Maybe LByteString))
forall (m :: * -> *) a.
MonadHttp m =>
Request
-> (Request -> Request) -> (Response BodyReader -> IO a) -> m a
http Request
r Request -> Request
f Response BodyReader -> IO (Response (Maybe LByteString))
consumeBody

http ::
  (MonadHttp m) =>
  Request ->
  (Request -> Request) ->
  (Response BodyReader -> IO a) ->
  m a
http :: forall (m :: * -> *) a.
MonadHttp m =>
Request
-> (Request -> Request) -> (Response BodyReader -> IO a) -> m a
http Request
r Request -> Request
f = Request -> (Response BodyReader -> IO a) -> m a
forall a. Request -> (Response BodyReader -> IO a) -> m a
forall (m :: * -> *) a.
MonadHttp m =>
Request -> (Response BodyReader -> IO a) -> m a
handleRequestWithCont (Request -> Request
f Request
r)

httpDebug ::
  (MonadIO m, MonadHttp m) =>
  Debug ->
  Request ->
  (Request -> Request) ->
  (Response (Maybe LByteString) -> IO a) ->
  m a
httpDebug :: forall (m :: * -> *) a.
(MonadIO m, MonadHttp m) =>
Debug
-> Request
-> (Request -> Request)
-> (Response (Maybe LByteString) -> IO a)
-> m a
httpDebug Debug
debug Request
r Request -> Request
f Response (Maybe LByteString) -> IO a
h = do
  let rq :: Request
rq = Request -> Request
f Request
r
  if Debug
debug Debug -> Debug -> Bool
forall a. Ord a => a -> a -> Bool
> Debug
Head
    then String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (Request -> String
showRequest Request
rq)
    else String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (Request -> String
showRequest (Request
rq {requestBody = RequestBodyLBS ""}))
  String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn String
"-"
  Request -> (Response BodyReader -> IO a) -> m a
forall a. Request -> (Response BodyReader -> IO a) -> m a
forall (m :: * -> *) a.
MonadHttp m =>
Request -> (Response BodyReader -> IO a) -> m a
handleRequestWithCont Request
rq ((Response BodyReader -> IO a) -> m a)
-> (Response BodyReader -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$
    Response BodyReader -> IO (Response (Maybe LByteString))
consumeBody (Response BodyReader -> IO (Response (Maybe LByteString)))
-> (Response (Maybe LByteString) -> IO a)
-> Response BodyReader
-> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \Response (Maybe LByteString)
rsp -> do
      if Debug
debug Debug -> Debug -> Bool
forall a. Ord a => a -> a -> Bool
> Debug
Head
        then String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (Response (Maybe LByteString) -> String
forall a. Show a => Response a -> String
showResponse Response (Maybe LByteString)
rsp)
        else String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (Response String -> String
forall a. Show a => Response a -> String
showResponse (Response String -> String) -> Response String -> String
forall a b. (a -> b) -> a -> b
$ Response (Maybe LByteString)
rsp {responseBody = "" :: String})
      String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn String
"--"
      Response (Maybe LByteString) -> IO a
h Response (Maybe LByteString)
rsp

consumeBody :: Response BodyReader -> IO (Response (Maybe LBS.ByteString))
consumeBody :: Response BodyReader -> IO (Response (Maybe LByteString))
consumeBody Response BodyReader
r = do
  [ByteString]
chunks <- BodyReader -> IO [ByteString]
brConsume (Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
r)
  let bdy :: Maybe LByteString
bdy =
        if [ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
chunks
          then Maybe LByteString
forall a. Maybe a
Nothing
          else LByteString -> Maybe LByteString
forall a. a -> Maybe a
Just ([ByteString] -> LByteString
LBS.fromChunks [ByteString]
chunks)
  Response (Maybe LByteString) -> IO (Response (Maybe LByteString))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response (Maybe LByteString) -> IO (Response (Maybe LByteString)))
-> Response (Maybe LByteString)
-> IO (Response (Maybe LByteString))
forall a b. (a -> b) -> a -> b
$ Response BodyReader
r {responseBody = bdy}