{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Network.HTTP.Client.Request
( parseUrl
, parseUrlThrow
, parseRequest
, parseRequest_
, requestFromURI
, requestFromURI_
, defaultRequest
, setUriRelative
, getUri
, setUri
, setUriEither
, browserDecompress
, alwaysDecompress
, addProxy
, applyBasicAuth
, applyBasicProxyAuth
, urlEncodedBody
, needsGunzip
, requestBuilder
, setRequestIgnoreStatus
, setRequestCheckStatus
, setQueryString
#if MIN_VERSION_http_types(0,12,1)
, setQueryStringPartialEscape
#endif
, streamFile
, observedStreamFile
, extractBasicAuthInfo
, throwErrorStatusCodes
) where
import Data.Int (Int64)
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Monoid (mempty, mappend, (<>))
import Data.String (IsString(..))
import Data.Char (toLower)
import Control.Applicative as A ((<$>))
import Control.Monad (unless, guard)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Numeric (showHex)
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteStringIO, flush)
import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Lazy.Internal (defaultChunkSize)
import qualified Network.HTTP.Types as W
import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, unEscapeString, isAllowedInURI)
import Control.Exception (throw, throwIO, IOException)
import qualified Control.Exception as E
import qualified Data.CaseInsensitive as CI
import qualified Data.ByteArray.Encoding as BAE
import Network.HTTP.Client.Body
import Network.HTTP.Client.Types
import Network.HTTP.Client.Util
import Control.Monad.Catch (MonadThrow, throwM)
import System.IO (withBinaryFile, hTell, hFileSize, Handle, IOMode (ReadMode))
import Control.Monad (liftM)
parseUrl :: MonadThrow m => String -> m Request
parseUrl :: String -> m Request
parseUrl = String -> m Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow
{-# DEPRECATED parseUrl "Please use parseUrlThrow, parseRequest, or parseRequest_ instead" #-}
parseUrlThrow :: MonadThrow m => String -> m Request
parseUrlThrow :: String -> m Request
parseUrlThrow =
(Request -> Request) -> m Request -> m Request
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> Request
yesThrow (m Request -> m Request)
-> (String -> m Request) -> String -> m Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest
where
yesThrow :: Request -> Request
yesThrow req :: Request
req = Request
req { checkResponse :: Request -> Response BodyReader -> IO ()
checkResponse = Request -> Response BodyReader -> IO ()
forall (m :: * -> *).
MonadIO m =>
Request -> Response BodyReader -> m ()
throwErrorStatusCodes }
throwErrorStatusCodes :: MonadIO m => Request -> Response BodyReader -> m ()
throwErrorStatusCodes :: Request -> Response BodyReader -> m ()
throwErrorStatusCodes req :: Request
req res :: Response BodyReader
res = do
let W.Status sci :: Int
sci _ = Response BodyReader -> Status
forall body. Response body -> Status
responseStatus Response BodyReader
res
if 200 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
sci Bool -> Bool -> Bool
&& Int
sci Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 300
then () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ByteString
chunk <- BodyReader -> Int -> IO ByteString
brReadSome (Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
res) 1024
let res' :: Response ()
res' = (BodyReader -> ()) -> Response BodyReader -> Response ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> BodyReader -> ()
forall a b. a -> b -> a
const ()) Response BodyReader
res
let ex :: HttpExceptionContent
ex = Response () -> ByteString -> HttpExceptionContent
StatusCodeException Response ()
res' (ByteString -> ByteString
L.toStrict ByteString
chunk)
HttpException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (HttpException -> IO ()) -> HttpException -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HttpExceptionRequest Request
req HttpExceptionContent
ex
parseRequest :: MonadThrow m => String -> m Request
parseRequest :: String -> m Request
parseRequest s' :: String
s' =
case String -> Maybe URI
parseURI (String -> String
encode String
s) of
Just uri :: URI
uri -> (Request -> Request) -> m Request -> m Request
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> Request
setMethod (Request -> URI -> m Request
forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
setUri Request
defaultRequest URI
uri)
Nothing -> HttpException -> m Request
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HttpException -> m Request) -> HttpException -> m Request
forall a b. (a -> b) -> a -> b
$ String -> String -> HttpException
InvalidUrlException String
s "Invalid URL"
where
encode :: String -> String
encode = (Char -> Bool) -> String -> String
escapeURIString Char -> Bool
isAllowedInURI
(mmethod :: Maybe String
mmethod, s :: String
s) =
case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') String
s' of
(x :: String
x, ' ':y :: String
y) | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\c :: Char
c -> 'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= 'Z') String
x -> (String -> Maybe String
forall a. a -> Maybe a
Just String
x, String
y)
_ -> (Maybe String
forall a. Maybe a
Nothing, String
s')
setMethod :: Request -> Request
setMethod req :: Request
req =
case Maybe String
mmethod of
Nothing -> Request
req
Just m :: String
m -> Request
req { method :: ByteString
method = String -> ByteString
S8.pack String
m }
parseRequest_ :: String -> Request
parseRequest_ :: String -> Request
parseRequest_ = (SomeException -> Request)
-> (Request -> Request) -> Either SomeException Request -> Request
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Request
forall a e. Exception e => e -> a
throw Request -> Request
forall a. a -> a
id (Either SomeException Request -> Request)
-> (String -> Either SomeException Request) -> String -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either SomeException Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest
requestFromURI :: MonadThrow m => URI -> m Request
requestFromURI :: URI -> m Request
requestFromURI = Request -> URI -> m Request
forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
setUri Request
defaultRequest
requestFromURI_ :: URI -> Request
requestFromURI_ :: URI -> Request
requestFromURI_ = (SomeException -> Request)
-> (Request -> Request) -> Either SomeException Request -> Request
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Request
forall a e. Exception e => e -> a
throw Request -> Request
forall a. a -> a
id (Either SomeException Request -> Request)
-> (URI -> Either SomeException Request) -> URI -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Either SomeException Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI
setUriRelative :: MonadThrow m => Request -> URI -> m Request
setUriRelative :: Request -> URI -> m Request
setUriRelative req :: Request
req uri :: URI
uri = Request -> URI -> m Request
forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
setUri Request
req (URI -> m Request) -> URI -> m Request
forall a b. (a -> b) -> a -> b
$ URI
uri URI -> URI -> URI
`relativeTo` Request -> URI
getUri Request
req
getUri :: Request -> URI
getUri :: Request -> URI
getUri req :: Request
req = URI :: String -> Maybe URIAuth -> String -> String -> String -> URI
URI
{ uriScheme :: String
uriScheme = if Request -> Bool
secure Request
req
then "https:"
else "http:"
, uriAuthority :: Maybe URIAuth
uriAuthority = URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just URIAuth :: String -> String -> String -> URIAuth
URIAuth
{ uriUserInfo :: String
uriUserInfo = ""
, uriRegName :: String
uriRegName = ByteString -> String
S8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
host Request
req
, uriPort :: String
uriPort = String
port'
}
, uriPath :: String
uriPath = ByteString -> String
S8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
path Request
req
, uriQuery :: String
uriQuery =
case ByteString -> Maybe (Char, ByteString)
S8.uncons (ByteString -> Maybe (Char, ByteString))
-> ByteString -> Maybe (Char, ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req of
Just (c :: Char
c, _) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '?' -> '?' Char -> String -> String
forall a. a -> [a] -> [a]
: (ByteString -> String
S8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req)
_ -> ByteString -> String
S8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req
, uriFragment :: String
uriFragment = ""
}
where
port' :: String
port'
| Request -> Bool
secure Request
req Bool -> Bool -> Bool
&& (Request -> Int
port Request
req) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 443 = ""
| Bool -> Bool
not (Request -> Bool
secure Request
req) Bool -> Bool -> Bool
&& (Request -> Int
port Request
req) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 80 = ""
| Bool
otherwise = ':' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show (Request -> Int
port Request
req)
applyAnyUriBasedAuth :: URI -> Request -> Request
applyAnyUriBasedAuth :: URI -> Request -> Request
applyAnyUriBasedAuth uri :: URI
uri req :: Request
req =
case URI -> Maybe (ByteString, ByteString)
extractBasicAuthInfo URI
uri of
Just auth :: (ByteString, ByteString)
auth -> (ByteString -> ByteString -> Request -> Request)
-> (ByteString, ByteString) -> Request -> Request
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Request -> Request
applyBasicAuth (ByteString, ByteString)
auth Request
req
Nothing -> Request
req
extractBasicAuthInfo :: URI -> Maybe (S8.ByteString, S8.ByteString)
uri :: URI
uri = do
String
userInfo <- URIAuth -> String
uriUserInfo (URIAuth -> String) -> Maybe URIAuth -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> URI -> Maybe URIAuth
uriAuthority URI
uri
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (':' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
userInfo)
let (username :: String
username, ':':password :: String
password) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==':') (String -> (String, String))
-> (String -> String) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='@') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String
userInfo
(ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ByteString
toLiteral String
username, String -> ByteString
toLiteral String
password)
where
toLiteral :: String -> ByteString
toLiteral = String -> ByteString
S8.pack (String -> ByteString)
-> (String -> String) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
unEscapeString
setUri :: MonadThrow m => Request -> URI -> m Request
setUri :: Request -> URI -> m Request
setUri req :: Request
req uri :: URI
uri = (String -> m Request)
-> (Request -> m Request) -> Either String Request -> m Request
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m Request
forall a. String -> m a
throwInvalidUrlException Request -> m Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> URI -> Either String Request
setUriEither Request
req URI
uri)
where
throwInvalidUrlException :: String -> m a
throwInvalidUrlException = HttpException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HttpException -> m a)
-> (String -> HttpException) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> HttpException
InvalidUrlException (URI -> String
forall a. Show a => a -> String
show URI
uri)
setUriEither :: Request -> URI -> Either String Request
setUriEither :: Request -> URI -> Either String Request
setUriEither req :: Request
req uri :: URI
uri = do
Bool
sec <- URI -> Either String Bool
forall a. IsString a => URI -> Either a Bool
parseScheme URI
uri
URIAuth
auth <- Either String URIAuth
-> (URIAuth -> Either String URIAuth)
-> Maybe URIAuth
-> Either String URIAuth
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String URIAuth
forall a b. a -> Either a b
Left "URL must be absolute") URIAuth -> Either String URIAuth
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URIAuth -> Either String URIAuth)
-> Maybe URIAuth -> Either String URIAuth
forall a b. (a -> b) -> a -> b
$ URI -> Maybe URIAuth
uriAuthority URI
uri
Int
port' <- Bool -> URIAuth -> Either String Int
forall a. IsString a => Bool -> URIAuth -> Either a Int
parsePort Bool
sec URIAuth
auth
Request -> Either String Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> Either String Request)
-> Request -> Either String Request
forall a b. (a -> b) -> a -> b
$ URI -> Request -> Request
applyAnyUriBasedAuth URI
uri Request
req
{ host :: ByteString
host = String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ URIAuth -> String
uriRegName URIAuth
auth
, port :: Int
port = Int
port'
, secure :: Bool
secure = Bool
sec
, path :: ByteString
path = String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$
if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ URI -> String
uriPath URI
uri
then "/"
else URI -> String
uriPath URI
uri
, queryString :: ByteString
queryString = String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ URI -> String
uriQuery URI
uri
}
where
parseScheme :: URI -> Either a Bool
parseScheme URI{uriScheme :: URI -> String
uriScheme = String
scheme} =
case (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
scheme of
"http:" -> Bool -> Either a Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
"https:" -> Bool -> Either a Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
_ -> a -> Either a Bool
forall a b. a -> Either a b
Left "Invalid scheme"
parsePort :: Bool -> URIAuth -> Either a Int
parsePort sec :: Bool
sec URIAuth{uriPort :: URIAuth -> String
uriPort = String
portStr} =
case String
portStr of
':':rest :: String
rest -> Either a Int -> (Int -> Either a Int) -> Maybe Int -> Either a Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(a -> Either a Int
forall a b. a -> Either a b
Left "Invalid port")
Int -> Either a Int
forall (m :: * -> *) a. Monad m => a -> m a
return
(String -> Maybe Int
readPositiveInt String
rest)
_ -> case Bool
sec of
False -> Int -> Either a Int
forall (m :: * -> *) a. Monad m => a -> m a
return 80
True -> Int -> Either a Int
forall (m :: * -> *) a. Monad m => a -> m a
return 443
defaultRequest :: Request
defaultRequest :: Request
defaultRequest = Request :: ByteString
-> Bool
-> ByteString
-> Int
-> ByteString
-> ByteString
-> RequestHeaders
-> RequestBody
-> Maybe Proxy
-> Maybe HostAddress
-> Bool
-> (ByteString -> Bool)
-> Int
-> (Request -> Response BodyReader -> IO ())
-> ResponseTimeout
-> Maybe CookieJar
-> HttpVersion
-> (SomeException -> IO ())
-> Maybe Manager
-> (HeaderName -> Bool)
-> Request
Request
{ host :: ByteString
host = "localhost"
, port :: Int
port = 80
, secure :: Bool
secure = Bool
False
, requestHeaders :: RequestHeaders
requestHeaders = []
, path :: ByteString
path = "/"
, queryString :: ByteString
queryString = ByteString
S8.empty
, requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
L.empty
, method :: ByteString
method = "GET"
, proxy :: Maybe Proxy
proxy = Maybe Proxy
forall a. Maybe a
Nothing
, hostAddress :: Maybe HostAddress
hostAddress = Maybe HostAddress
forall a. Maybe a
Nothing
, rawBody :: Bool
rawBody = Bool
False
, decompress :: ByteString -> Bool
decompress = ByteString -> Bool
browserDecompress
, redirectCount :: Int
redirectCount = 10
, checkResponse :: Request -> Response BodyReader -> IO ()
checkResponse = \_ _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, responseTimeout :: ResponseTimeout
responseTimeout = ResponseTimeout
ResponseTimeoutDefault
, cookieJar :: Maybe CookieJar
cookieJar = CookieJar -> Maybe CookieJar
forall a. a -> Maybe a
Just CookieJar
forall a. Monoid a => a
Data.Monoid.mempty
, requestVersion :: HttpVersion
requestVersion = HttpVersion
W.http11
, onRequestBodyException :: SomeException -> IO ()
onRequestBodyException = \se :: SomeException
se ->
case SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se of
Just (IOException
_ :: IOException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Nothing -> SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
se
, requestManagerOverride :: Maybe Manager
requestManagerOverride = Maybe Manager
forall a. Maybe a
Nothing
, shouldStripHeaderOnRedirect :: HeaderName -> Bool
shouldStripHeaderOnRedirect = Bool -> HeaderName -> Bool
forall a b. a -> b -> a
const Bool
False
}
instance IsString Request where
fromString :: String -> Request
fromString = String -> Request
parseRequest_
{-# INLINE fromString #-}
alwaysDecompress :: S.ByteString -> Bool
alwaysDecompress :: ByteString -> Bool
alwaysDecompress = Bool -> ByteString -> Bool
forall a b. a -> b -> a
const Bool
True
browserDecompress :: S.ByteString -> Bool
browserDecompress :: ByteString -> Bool
browserDecompress = (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= "application/x-tar")
buildBasicAuth ::
S8.ByteString
-> S8.ByteString
-> S8.ByteString
buildBasicAuth :: ByteString -> ByteString -> ByteString
buildBasicAuth user :: ByteString
user passwd :: ByteString
passwd =
ByteString -> ByteString -> ByteString
S8.append "Basic " (Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
BAE.convertToBase Base
BAE.Base64 ([ByteString] -> ByteString
S8.concat [ ByteString
user, ":", ByteString
passwd ]))
applyBasicAuth :: S.ByteString -> S.ByteString -> Request -> Request
applyBasicAuth :: ByteString -> ByteString -> Request -> Request
applyBasicAuth user :: ByteString
user passwd :: ByteString
passwd req :: Request
req =
Request
req { requestHeaders :: RequestHeaders
requestHeaders = (HeaderName, ByteString)
authHeader (HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: Request -> RequestHeaders
requestHeaders Request
req }
where
authHeader :: (HeaderName, ByteString)
authHeader = (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk "Authorization", ByteString -> ByteString -> ByteString
buildBasicAuth ByteString
user ByteString
passwd)
addProxy :: S.ByteString -> Int -> Request -> Request
addProxy :: ByteString -> Int -> Request -> Request
addProxy hst :: ByteString
hst prt :: Int
prt req :: Request
req =
Request
req { proxy :: Maybe Proxy
proxy = Proxy -> Maybe Proxy
forall a. a -> Maybe a
Just (Proxy -> Maybe Proxy) -> Proxy -> Maybe Proxy
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> Proxy
Proxy ByteString
hst Int
prt }
applyBasicProxyAuth :: S.ByteString -> S.ByteString -> Request -> Request
applyBasicProxyAuth :: ByteString -> ByteString -> Request -> Request
applyBasicProxyAuth user :: ByteString
user passwd :: ByteString
passwd req :: Request
req =
Request
req { requestHeaders :: RequestHeaders
requestHeaders = (HeaderName, ByteString)
authHeader (HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: Request -> RequestHeaders
requestHeaders Request
req }
where
authHeader :: (HeaderName, ByteString)
authHeader = (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk "Proxy-Authorization", ByteString -> ByteString -> ByteString
buildBasicAuth ByteString
user ByteString
passwd)
urlEncodedBody :: [(S.ByteString, S.ByteString)] -> Request -> Request
urlEncodedBody :: [(ByteString, ByteString)] -> Request -> Request
urlEncodedBody headers :: [(ByteString, ByteString)]
headers req :: Request
req = Request
req
{ requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
body
, method :: ByteString
method = "POST"
, requestHeaders :: RequestHeaders
requestHeaders =
(HeaderName
ct, "application/x-www-form-urlencoded")
(HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: ((HeaderName, ByteString) -> Bool)
-> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(x :: HeaderName
x, _) -> HeaderName
x HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
ct) (Request -> RequestHeaders
requestHeaders Request
req)
}
where
ct :: HeaderName
ct = "Content-Type"
body :: ByteString
body = [ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> [(ByteString, ByteString)] -> ByteString
W.renderSimpleQuery Bool
False [(ByteString, ByteString)]
headers
needsGunzip :: Request
-> [W.Header]
-> Bool
needsGunzip :: Request -> RequestHeaders -> Bool
needsGunzip req :: Request
req hs' :: RequestHeaders
hs' =
Bool -> Bool
not (Request -> Bool
rawBody Request
req)
Bool -> Bool -> Bool
&& ("content-encoding", "gzip") (HeaderName, ByteString) -> RequestHeaders -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` RequestHeaders
hs'
Bool -> Bool -> Bool
&& Request -> ByteString -> Bool
decompress Request
req (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "content-type" RequestHeaders
hs')
requestBuilder :: Request -> Connection -> IO (Maybe (IO ()))
requestBuilder :: Request -> Connection -> IO (Maybe (IO ()))
requestBuilder req :: Request
req Connection {..} = do
(contentLength :: Maybe Int64
contentLength, sendNow :: IO ()
sendNow, sendLater :: IO ()
sendLater) <- RequestBody -> IO (Maybe Int64, IO (), IO ())
toTriple (Request -> RequestBody
requestBody Request
req)
if Bool
expectContinue
then Maybe Int64 -> IO ()
flushHeaders Maybe Int64
contentLength IO () -> IO (Maybe (IO ())) -> IO (Maybe (IO ()))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (IO ()) -> IO (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> IO ()
checkBadSend IO ()
sendLater))
else IO ()
sendNow IO () -> IO (Maybe (IO ())) -> IO (Maybe (IO ()))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (IO ()) -> IO (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
forall a. Maybe a
Nothing
where
expectContinue :: Bool
expectContinue = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just "100-continue" Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "Expect" (Request -> RequestHeaders
requestHeaders Request
req)
checkBadSend :: IO () -> IO ()
checkBadSend f :: IO ()
f = IO ()
f IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` Request -> SomeException -> IO ()
onRequestBodyException Request
req
writeBuilder :: Builder -> IO ()
writeBuilder = (ByteString -> IO ()) -> Builder -> IO ()
toByteStringIO ByteString -> IO ()
connectionWrite
writeHeadersWith :: Maybe Int64 -> Builder -> IO ()
writeHeadersWith contentLength :: Maybe Int64
contentLength = Builder -> IO ()
writeBuilder (Builder -> IO ()) -> (Builder -> Builder) -> Builder -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Int64 -> Builder
builder Maybe Int64
contentLength Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`Data.Monoid.mappend`)
flushHeaders :: Maybe Int64 -> IO ()
flushHeaders contentLength :: Maybe Int64
contentLength = Maybe Int64 -> Builder -> IO ()
writeHeadersWith Maybe Int64
contentLength Builder
flush
toTriple :: RequestBody -> IO (Maybe Int64, IO (), IO ())
toTriple (RequestBodyLBS lbs :: ByteString
lbs) = do
let body :: Builder
body = ByteString -> Builder
fromLazyByteString ByteString
lbs
len :: Maybe Int64
len = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64) -> Int64 -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
lbs
now :: IO ()
now = IO () -> IO ()
checkBadSend (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Int64 -> Builder -> IO ()
writeHeadersWith Maybe Int64
len Builder
body
later :: IO ()
later = Builder -> IO ()
writeBuilder Builder
body
(Maybe Int64, IO (), IO ()) -> IO (Maybe Int64, IO (), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int64
len, IO ()
now, IO ()
later)
toTriple (RequestBodyBS bs :: ByteString
bs) = do
let body :: Builder
body = ByteString -> Builder
fromByteString ByteString
bs
len :: Maybe Int64
len = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64) -> Int64 -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
bs
now :: IO ()
now = IO () -> IO ()
checkBadSend (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Int64 -> Builder -> IO ()
writeHeadersWith Maybe Int64
len Builder
body
later :: IO ()
later = Builder -> IO ()
writeBuilder Builder
body
(Maybe Int64, IO (), IO ()) -> IO (Maybe Int64, IO (), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int64
len, IO ()
now, IO ()
later)
toTriple (RequestBodyBuilder len :: Int64
len body :: Builder
body) = do
let now :: IO ()
now = IO () -> IO ()
checkBadSend (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Int64 -> Builder -> IO ()
writeHeadersWith (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
len) Builder
body
later :: IO ()
later = Builder -> IO ()
writeBuilder Builder
body
(Maybe Int64, IO (), IO ()) -> IO (Maybe Int64, IO (), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
len, IO ()
now, IO ()
later)
toTriple (RequestBodyStream len :: Int64
len stream :: GivesPopper ()
stream) = do
let body :: IO ()
body = Maybe Int -> GivesPopper () -> IO ()
forall t. Maybe Int -> ((BodyReader -> IO ()) -> t) -> t
writeStream (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int64 -> Int) -> Int64 -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Maybe Int) -> Int64 -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int64
len) GivesPopper ()
stream
now :: IO ()
now = Maybe Int64 -> IO ()
flushHeaders (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
len) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO ()
checkBadSend IO ()
body
(Maybe Int64, IO (), IO ()) -> IO (Maybe Int64, IO (), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
len, IO ()
now, IO ()
body)
toTriple (RequestBodyStreamChunked stream :: GivesPopper ()
stream) = do
let body :: IO ()
body = Maybe Int -> GivesPopper () -> IO ()
forall t. Maybe Int -> ((BodyReader -> IO ()) -> t) -> t
writeStream Maybe Int
forall a. Maybe a
Nothing GivesPopper ()
stream
now :: IO ()
now = Maybe Int64 -> IO ()
flushHeaders Maybe Int64
forall a. Maybe a
Nothing IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO ()
checkBadSend IO ()
body
(Maybe Int64, IO (), IO ()) -> IO (Maybe Int64, IO (), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int64
forall a. Maybe a
Nothing, IO ()
now, IO ()
body)
toTriple (RequestBodyIO mbody :: IO RequestBody
mbody) = IO RequestBody
mbody IO RequestBody
-> (RequestBody -> IO (Maybe Int64, IO (), IO ()))
-> IO (Maybe Int64, IO (), IO ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RequestBody -> IO (Maybe Int64, IO (), IO ())
toTriple
writeStream :: Maybe Int -> ((BodyReader -> IO ()) -> t) -> t
writeStream mlen :: Maybe Int
mlen withStream :: (BodyReader -> IO ()) -> t
withStream =
(BodyReader -> IO ()) -> t
withStream (Int -> BodyReader -> IO ()
loop 0)
where
loop :: Int -> BodyReader -> IO ()
loop !Int
n stream :: BodyReader
stream = do
ByteString
bs <- BodyReader
stream
if ByteString -> Bool
S.null ByteString
bs
then case Maybe Int
mlen of
Nothing -> ByteString -> IO ()
connectionWrite "0\r\n\r\n"
Just len -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> IO ()
forall a. HttpExceptionContent -> IO a
throwHttp (HttpExceptionContent -> IO ()) -> HttpExceptionContent -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> HttpExceptionContent
WrongRequestBodyStreamSize (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
else do
ByteString -> IO ()
connectionWrite (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
if (Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
mlen)
then [ByteString] -> ByteString
S.concat
[ String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex (ByteString -> Int
S.length ByteString
bs) "\r\n"
, ByteString
bs
, "\r\n"
]
else ByteString
bs
Int -> BodyReader -> IO ()
loop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (ByteString -> Int
S.length ByteString
bs)) BodyReader
stream
hh :: ByteString
hh
| Request -> Int
port Request
req Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 80 Bool -> Bool -> Bool
&& Bool -> Bool
not (Request -> Bool
secure Request
req) = Request -> ByteString
host Request
req
| Request -> Int
port Request
req Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 443 Bool -> Bool -> Bool
&& Request -> Bool
secure Request
req = Request -> ByteString
host Request
req
| Bool
otherwise = Request -> ByteString
host Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
S8.pack (':' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show (Request -> Int
port Request
req))
requestProtocol :: Builder
requestProtocol
| Request -> Bool
secure Request
req = ByteString -> Builder
fromByteString "https://"
| Bool
otherwise = ByteString -> Builder
fromByteString "http://"
requestHostname :: Builder
requestHostname
| Maybe Proxy -> Bool
forall a. Maybe a -> Bool
isJust (Request -> Maybe Proxy
proxy Request
req) Bool -> Bool -> Bool
&& Bool -> Bool
not (Request -> Bool
secure Request
req)
= Builder
requestProtocol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
hh
| Bool
otherwise = Builder
forall a. Monoid a => a
mempty
contentLengthHeader :: Maybe a -> [(a, ByteString)] -> [(a, ByteString)]
contentLengthHeader (Just contentLength' :: a
contentLength') =
if Request -> ByteString
method Request
req ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["GET", "HEAD"] Bool -> Bool -> Bool
&& a
contentLength' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> a
id
else (:) ("Content-Length", String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
contentLength')
contentLengthHeader Nothing = (:) ("Transfer-Encoding", "chunked")
acceptEncodingHeader :: RequestHeaders -> RequestHeaders
acceptEncodingHeader =
case HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "Accept-Encoding" (RequestHeaders -> Maybe ByteString)
-> RequestHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req of
Nothing -> (("Accept-Encoding", "gzip")(HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:)
Just "" -> ((HeaderName, ByteString) -> Bool)
-> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(k :: HeaderName
k, _) -> HeaderName
k HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= "Accept-Encoding")
Just _ -> RequestHeaders -> RequestHeaders
forall a. a -> a
id
hostHeader :: [(a, ByteString)] -> [(a, ByteString)]
hostHeader x :: [(a, ByteString)]
x =
case a -> [(a, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "Host" [(a, ByteString)]
x of
Nothing -> ("Host", ByteString
hh) (a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> [a] -> [a]
: [(a, ByteString)]
x
Just{} -> [(a, ByteString)]
x
headerPairs :: Maybe Int64 -> W.RequestHeaders
headerPairs :: Maybe Int64 -> RequestHeaders
headerPairs contentLength :: Maybe Int64
contentLength
= RequestHeaders -> RequestHeaders
forall a.
(Eq a, IsString a) =>
[(a, ByteString)] -> [(a, ByteString)]
hostHeader
(RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> RequestHeaders
acceptEncodingHeader
(RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ Maybe Int64 -> RequestHeaders -> RequestHeaders
forall a a.
(Eq a, Num a, IsString a, Show a) =>
Maybe a -> [(a, ByteString)] -> [(a, ByteString)]
contentLengthHeader Maybe Int64
contentLength
(RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req
builder :: Maybe Int64 -> Builder
builder :: Maybe Int64 -> Builder
builder contentLength :: Maybe Int64
contentLength =
ByteString -> Builder
fromByteString (Request -> ByteString
method Request
req)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString " "
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
requestHostname
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (case ByteString -> Maybe (Char, ByteString)
S8.uncons (ByteString -> Maybe (Char, ByteString))
-> ByteString -> Maybe (Char, ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
path Request
req of
Just ('/', _) -> ByteString -> Builder
fromByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
path Request
req
_ -> Char -> Builder
fromChar '/' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (Request -> ByteString
path Request
req))
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (case ByteString -> Maybe (Char, ByteString)
S8.uncons (ByteString -> Maybe (Char, ByteString))
-> ByteString -> Maybe (Char, ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req of
Nothing -> Builder
forall a. Monoid a => a
mempty
Just ('?', _) -> ByteString -> Builder
fromByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req
_ -> Char -> Builder
fromChar '?' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (Request -> ByteString
queryString Request
req))
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (case Request -> HttpVersion
requestVersion Request
req of
W.HttpVersion 1 1 -> ByteString -> Builder
fromByteString " HTTP/1.1\r\n"
W.HttpVersion 1 0 -> ByteString -> Builder
fromByteString " HTTP/1.0\r\n"
version :: HttpVersion
version ->
Char -> Builder
fromChar ' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
HttpVersion -> Builder
forall a. Show a => a -> Builder
fromShow HttpVersion
version Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
ByteString -> Builder
fromByteString "\r\n")
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ((HeaderName, ByteString) -> Builder -> Builder)
-> Builder -> RequestHeaders -> Builder
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\a :: (HeaderName, ByteString)
a b :: Builder
b -> (HeaderName, ByteString) -> Builder
headerPairToBuilder (HeaderName, ByteString)
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b)
(ByteString -> Builder
fromByteString "\r\n")
(Maybe Int64 -> RequestHeaders
headerPairs Maybe Int64
contentLength)
headerPairToBuilder :: (HeaderName, ByteString) -> Builder
headerPairToBuilder (k :: HeaderName
k, v :: ByteString
v) =
ByteString -> Builder
fromByteString (HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
k)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ": "
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
v
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString "\r\n"
setRequestIgnoreStatus :: Request -> Request
setRequestIgnoreStatus :: Request -> Request
setRequestIgnoreStatus req :: Request
req = Request
req { checkResponse :: Request -> Response BodyReader -> IO ()
checkResponse = \_ _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
setRequestCheckStatus :: Request -> Request
setRequestCheckStatus :: Request -> Request
setRequestCheckStatus req :: Request
req = Request
req { checkResponse :: Request -> Response BodyReader -> IO ()
checkResponse = Request -> Response BodyReader -> IO ()
forall (m :: * -> *).
MonadIO m =>
Request -> Response BodyReader -> m ()
throwErrorStatusCodes }
setQueryString :: [(S.ByteString, Maybe S.ByteString)] -> Request -> Request
setQueryString :: [(ByteString, Maybe ByteString)] -> Request -> Request
setQueryString qs :: [(ByteString, Maybe ByteString)]
qs req :: Request
req = Request
req { queryString :: ByteString
queryString = Bool -> [(ByteString, Maybe ByteString)] -> ByteString
W.renderQuery Bool
True [(ByteString, Maybe ByteString)]
qs }
#if MIN_VERSION_http_types(0,12,1)
setQueryStringPartialEscape :: [(S.ByteString, [W.EscapeItem])] -> Request -> Request
setQueryStringPartialEscape :: [(ByteString, [EscapeItem])] -> Request -> Request
setQueryStringPartialEscape qs :: [(ByteString, [EscapeItem])]
qs req :: Request
req = Request
req { queryString :: ByteString
queryString = Bool -> [(ByteString, [EscapeItem])] -> ByteString
W.renderQueryPartialEscape Bool
True [(ByteString, [EscapeItem])]
qs }
#endif
streamFile :: FilePath -> IO RequestBody
streamFile :: String -> IO RequestBody
streamFile = (StreamFileStatus -> IO ()) -> String -> IO RequestBody
observedStreamFile (\_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
observedStreamFile :: (StreamFileStatus -> IO ()) -> FilePath -> IO RequestBody
observedStreamFile :: (StreamFileStatus -> IO ()) -> String -> IO RequestBody
observedStreamFile obs :: StreamFileStatus -> IO ()
obs path :: String
path = do
Int64
size <- Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int64) -> IO Integer -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IOMode -> (Handle -> IO Integer) -> IO Integer
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path IOMode
ReadMode Handle -> IO Integer
hFileSize
let filePopper :: Handle -> Popper
filePopper :: Handle -> BodyReader
filePopper h :: Handle
h = do
ByteString
bs <- Handle -> Int -> BodyReader
S.hGetSome Handle
h Int
defaultChunkSize
Int64
currentPosition <- Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int64) -> IO Integer -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Integer
hTell Handle
h
StreamFileStatus -> IO ()
obs (StreamFileStatus -> IO ()) -> StreamFileStatus -> IO ()
forall a b. (a -> b) -> a -> b
$ StreamFileStatus :: Int64 -> Int64 -> Int -> StreamFileStatus
StreamFileStatus
{ fileSize :: Int64
fileSize = Int64
size
, readSoFar :: Int64
readSoFar = Int64
currentPosition
, thisChunkSize :: Int
thisChunkSize = ByteString -> Int
S.length ByteString
bs
}
ByteString -> BodyReader
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
givesFilePopper :: GivesPopper ()
givesFilePopper :: GivesPopper ()
givesFilePopper k :: BodyReader -> IO ()
k = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
BodyReader -> IO ()
k (Handle -> BodyReader
filePopper Handle
h)
RequestBody -> IO RequestBody
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestBody -> IO RequestBody) -> RequestBody -> IO RequestBody
forall a b. (a -> b) -> a -> b
$ Int64 -> GivesPopper () -> RequestBody
RequestBodyStream Int64
size GivesPopper ()
givesFilePopper