{-# 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
, applyBearerAuth
, urlEncodedBody
, needsGunzip
, requestBuilder
, setRequestIgnoreStatus
, setRequestCheckStatus
, setQueryString
#if MIN_VERSION_http_types(0,12,1)
, setQueryStringPartialEscape
#endif
, streamFile
, observedStreamFile
, extractBasicAuthInfo
, throwErrorStatusCodes
, addProxySecureWithoutConnect
) where
import Data.Int (Int64)
import Data.Maybe (fromMaybe, 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 qualified Data.Set as Set
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.ByteString.Base64 as B64
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 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 Request
req Response BodyReader
res = do
let W.Status Int
sci ByteString
_ = Response BodyReader -> Status
forall body. Response body -> Status
responseStatus Response BodyReader
res
if Int
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
< Int
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) Int
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 String
s' =
case String -> Maybe URI
parseURI (String -> String
encode String
s) of
Just 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)
Maybe 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 String
"Invalid URL"
where
encode :: String -> String
encode = (Char -> Bool) -> String -> String
escapeURIString Char -> Bool
isAllowedInURI
(Maybe String
mmethod, 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
== Char
' ') String
s' of
(String
x, Char
' ':String
y) | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char
'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
<= Char
'Z') String
x -> (String -> Maybe String
forall a. a -> Maybe a
Just String
x, String
y)
(String, String)
_ -> (Maybe String
forall a. Maybe a
Nothing, String
s')
setMethod :: Request -> Request
setMethod Request
req =
case Maybe String
mmethod of
Maybe String
Nothing -> Request
req
Just 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 Request
req 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 Request
req = URI :: String -> Maybe URIAuth -> String -> String -> String -> URI
URI
{ uriScheme :: String
uriScheme = if Request -> Bool
secure Request
req
then String
"https:"
else String
"http:"
, uriAuthority :: Maybe URIAuth
uriAuthority = URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just URIAuth :: String -> String -> String -> URIAuth
URIAuth
{ uriUserInfo :: String
uriUserInfo = String
""
, 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 (Char
c, ByteString
_) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'?' -> Char
'?' 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)
Maybe (Char, ByteString)
_ -> ByteString -> String
S8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req
, uriFragment :: String
uriFragment = String
""
}
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
== Int
443 = String
""
| 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
== Int
80 = String
""
| Bool
otherwise = Char
':' 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 Request
req =
case URI -> Maybe (ByteString, ByteString)
extractBasicAuthInfo URI
uri of
Just (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
Maybe (ByteString, ByteString)
Nothing -> Request
req
extractBasicAuthInfo :: URI -> Maybe (S8.ByteString, S8.ByteString)
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
':' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
userInfo)
let (String
username, Char
':':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
==Char
':') (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
/=Char
'@') (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 Request
req 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 Request
req 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 String
"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 String
"/"
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
String
"http:" -> Bool -> Either a Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
String
"https:" -> Bool -> Either a Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
String
_ -> a -> Either a Bool
forall a b. a -> Either a b
Left a
"Invalid scheme"
parsePort :: Bool -> URIAuth -> Either a Int
parsePort Bool
sec URIAuth{uriPort :: URIAuth -> String
uriPort = String
portStr} =
case String
portStr of
Char
':':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 a
"Invalid port")
Int -> Either a Int
forall (m :: * -> *) a. Monad m => a -> m a
return
(String -> Maybe Int
readPositiveInt String
rest)
String
_ -> case Bool
sec of
Bool
False -> Int -> Either a Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
80
Bool
True -> Int -> Either a Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
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)
-> ProxySecureMode
-> Set HeaderName
-> Request
Request
{ host :: ByteString
host = ByteString
"localhost"
, port :: Int
port = Int
80
, secure :: Bool
secure = Bool
False
, requestHeaders :: RequestHeaders
requestHeaders = []
, path :: ByteString
path = ByteString
"/"
, queryString :: ByteString
queryString = ByteString
S8.empty
, requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
L.empty
, method :: ByteString
method = ByteString
"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 = Int
10
, checkResponse :: Request -> Response BodyReader -> IO ()
checkResponse = \Request
_ Response BodyReader
_ -> () -> 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 = \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 ()
Maybe IOException
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
, proxySecureMode :: ProxySecureMode
proxySecureMode = ProxySecureMode
ProxySecureWithConnect
, redactHeaders :: Set HeaderName
redactHeaders = HeaderName -> Set HeaderName
forall a. a -> Set a
Set.singleton HeaderName
"Authorization"
}
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
/= ByteString
"application/x-tar")
buildBasicAuth ::
S8.ByteString
-> S8.ByteString
-> S8.ByteString
buildBasicAuth :: ByteString -> ByteString -> ByteString
buildBasicAuth ByteString
user ByteString
passwd =
ByteString -> ByteString -> ByteString
S8.append ByteString
"Basic " (ByteString -> ByteString
B64.encode ([ByteString] -> ByteString
S8.concat [ ByteString
user, ByteString
":", ByteString
passwd ]))
applyBasicAuth :: S.ByteString -> S.ByteString -> Request -> Request
applyBasicAuth :: ByteString -> ByteString -> Request -> Request
applyBasicAuth ByteString
user ByteString
passwd 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 ByteString
"Authorization", ByteString -> ByteString -> ByteString
buildBasicAuth ByteString
user ByteString
passwd)
buildBearerAuth ::
S8.ByteString
-> S8.ByteString
buildBearerAuth :: ByteString -> ByteString
buildBearerAuth ByteString
token =
ByteString -> ByteString -> ByteString
S8.append ByteString
"Bearer " ByteString
token
applyBearerAuth :: S.ByteString -> Request -> Request
applyBearerAuth :: ByteString -> Request -> Request
applyBearerAuth ByteString
bearerToken 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 ByteString
"Authorization", ByteString -> ByteString
buildBearerAuth ByteString
bearerToken)
addProxy :: S.ByteString -> Int -> Request -> Request
addProxy :: ByteString -> Int -> Request -> Request
addProxy ByteString
hst Int
prt 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 }
addProxySecureWithoutConnect :: Request -> Request
addProxySecureWithoutConnect :: Request -> Request
addProxySecureWithoutConnect Request
req = Request
req { proxySecureMode :: ProxySecureMode
proxySecureMode = ProxySecureMode
ProxySecureWithoutConnect }
applyBasicProxyAuth :: S.ByteString -> S.ByteString -> Request -> Request
applyBasicProxyAuth :: ByteString -> ByteString -> Request -> Request
applyBasicProxyAuth ByteString
user ByteString
passwd 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 ByteString
"Proxy-Authorization", ByteString -> ByteString -> ByteString
buildBasicAuth ByteString
user ByteString
passwd)
urlEncodedBody :: [(S.ByteString, S.ByteString)] -> Request -> Request
urlEncodedBody :: [(ByteString, ByteString)] -> Request -> Request
urlEncodedBody [(ByteString, ByteString)]
headers Request
req = Request
req
{ requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
body
, method :: ByteString
method = ByteString
"POST"
, requestHeaders :: RequestHeaders
requestHeaders =
(HeaderName
ct, ByteString
"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 (\(HeaderName
x, ByteString
_) -> HeaderName
x HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
ct) (Request -> RequestHeaders
requestHeaders Request
req)
}
where
ct :: HeaderName
ct = HeaderName
"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 Request
req RequestHeaders
hs' =
Bool -> Bool
not (Request -> Bool
rawBody Request
req)
Bool -> Bool -> Bool
&& (HeaderName
"content-encoding", ByteString
"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 ByteString
"" (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 HeaderName
"content-type" RequestHeaders
hs')
data EncapsulatedPopperException = EncapsulatedPopperException E.SomeException
deriving (Int -> EncapsulatedPopperException -> String -> String
[EncapsulatedPopperException] -> String -> String
EncapsulatedPopperException -> String
(Int -> EncapsulatedPopperException -> String -> String)
-> (EncapsulatedPopperException -> String)
-> ([EncapsulatedPopperException] -> String -> String)
-> Show EncapsulatedPopperException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [EncapsulatedPopperException] -> String -> String
$cshowList :: [EncapsulatedPopperException] -> String -> String
show :: EncapsulatedPopperException -> String
$cshow :: EncapsulatedPopperException -> String
showsPrec :: Int -> EncapsulatedPopperException -> String -> String
$cshowsPrec :: Int -> EncapsulatedPopperException -> String -> String
Show)
instance E.Exception EncapsulatedPopperException
encapsulatePopperException :: IO a -> IO a
encapsulatePopperException :: IO a -> IO a
encapsulatePopperException IO a
action =
IO a
action IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\(SomeException
ex :: E.SomeException) -> EncapsulatedPopperException -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (SomeException -> EncapsulatedPopperException
EncapsulatedPopperException SomeException
ex))
requestBuilder :: Request -> Connection -> IO (Maybe (IO ()))
requestBuilder :: Request -> Connection -> IO (Maybe (IO ()))
requestBuilder Request
req Connection {IO ()
BodyReader
ByteString -> IO ()
connectionClose :: Connection -> IO ()
connectionWrite :: Connection -> ByteString -> IO ()
connectionUnread :: Connection -> ByteString -> IO ()
connectionRead :: Connection -> BodyReader
connectionClose :: IO ()
connectionWrite :: ByteString -> IO ()
connectionUnread :: ByteString -> IO ()
connectionRead :: BodyReader
..} = do
(Maybe Int64
contentLength, IO ()
sendNow, 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 ByteString
"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 HeaderName
"Expect" (Request -> RequestHeaders
requestHeaders Request
req)
checkBadSend :: IO () -> IO ()
checkBadSend IO ()
f = IO ()
f IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
`E.catches` [
(EncapsulatedPopperException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler (\(EncapsulatedPopperException SomeException
ex) -> SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
ex)
, (SomeException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler (Request -> SomeException -> IO ()
onRequestBodyException Request
req)
]
writeBuilder :: Builder -> IO ()
writeBuilder = (ByteString -> IO ()) -> Builder -> IO ()
toByteStringIO ByteString -> IO ()
connectionWrite
writeHeadersWith :: Maybe Int64 -> Builder -> IO ()
writeHeadersWith 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 Maybe Int64
contentLength = Maybe Int64 -> Builder -> IO ()
writeHeadersWith Maybe Int64
contentLength Builder
flush
toTriple :: RequestBody -> IO (Maybe Int64, IO (), IO ())
toTriple (RequestBodyLBS 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 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 Int64
len 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 Int64
len 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 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 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 Maybe Int
mlen (BodyReader -> IO ()) -> t
withStream =
(BodyReader -> IO ()) -> t
withStream (Int -> BodyReader -> IO ()
loop Int
0)
where
loop :: Int -> BodyReader -> IO ()
loop !Int
n BodyReader
stream = do
ByteString
bs <- BodyReader -> BodyReader
forall a. IO a -> IO a
encapsulatePopperException BodyReader
stream
if ByteString -> Bool
S.null ByteString
bs
then case Maybe Int
mlen of
Maybe Int
Nothing -> ByteString -> IO ()
connectionWrite ByteString
"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) String
"\r\n"
, ByteString
bs
, ByteString
"\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
== Int
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
== Int
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
':' 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 ByteString
"https://"
| Bool
otherwise = ByteString -> Builder
fromByteString ByteString
"http://"
requestHostname :: Request -> Builder
requestHostname (Request { proxy :: Request -> Maybe Proxy
proxy = Maybe Proxy
Nothing }) = Builder
forall a. Monoid a => a
mempty
requestHostname (Request { proxy :: Request -> Maybe Proxy
proxy = Just Proxy
_,
secure :: Request -> Bool
secure = Bool
False }) =
Builder
requestProtocol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
hh
requestHostname (Request { proxy :: Request -> Maybe Proxy
proxy = Just Proxy
_,
secure :: Request -> Bool
secure = Bool
True,
proxySecureMode :: Request -> ProxySecureMode
proxySecureMode = ProxySecureMode
ProxySecureWithConnect }) = Builder
forall a. Monoid a => a
mempty
requestHostname (Request { proxy :: Request -> Maybe Proxy
proxy = Just Proxy
_,
secure :: Request -> Bool
secure = Bool
True,
proxySecureMode :: Request -> ProxySecureMode
proxySecureMode = ProxySecureMode
ProxySecureWithoutConnect }) =
Builder
requestProtocol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
hh
contentLengthHeader :: Maybe a -> [(a, ByteString)] -> [(a, ByteString)]
contentLengthHeader (Just a
contentLength') =
if Request -> ByteString
method Request
req ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"GET", ByteString
"HEAD"] Bool -> Bool -> Bool
&& a
contentLength' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
then [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> a
id
else (:) (a
"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 Maybe a
Nothing = (:) (a
"Transfer-Encoding", ByteString
"chunked")
acceptEncodingHeader :: RequestHeaders -> RequestHeaders
acceptEncodingHeader =
case HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Accept-Encoding" (RequestHeaders -> Maybe ByteString)
-> RequestHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req of
Maybe ByteString
Nothing -> ((HeaderName
"Accept-Encoding", ByteString
"gzip")(HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:)
Just ByteString
"" -> ((HeaderName, ByteString) -> Bool)
-> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
k, ByteString
_) -> HeaderName
k HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
"Accept-Encoding")
Just ByteString
_ -> RequestHeaders -> RequestHeaders
forall a. a -> a
id
hostHeader :: [(a, ByteString)] -> [(a, ByteString)]
hostHeader [(a, ByteString)]
x =
case a -> [(a, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"Host" [(a, ByteString)]
x of
Maybe ByteString
Nothing -> (a
"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 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 Maybe Int64
contentLength =
ByteString -> Builder
fromByteString (Request -> ByteString
method Request
req)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
" "
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Request -> Builder
requestHostname 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
path Request
req of
Just (Char
'/', ByteString
_) -> ByteString -> Builder
fromByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
path Request
req
Maybe (Char, ByteString)
_ -> Char -> Builder
fromChar Char
'/' 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
Maybe (Char, ByteString)
Nothing -> Builder
forall a. Monoid a => a
mempty
Just (Char
'?', ByteString
_) -> ByteString -> Builder
fromByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req
Maybe (Char, ByteString)
_ -> Char -> Builder
fromChar Char
'?' 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 Int
1 Int
1 -> ByteString -> Builder
fromByteString ByteString
" HTTP/1.1\r\n"
W.HttpVersion Int
1 Int
0 -> ByteString -> Builder
fromByteString ByteString
" HTTP/1.0\r\n"
HttpVersion
version ->
Char -> Builder
fromChar Char
' ' 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 ByteString
"\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
(\(HeaderName, ByteString)
a Builder
b -> (HeaderName, ByteString) -> Builder
headerPairToBuilder (HeaderName, ByteString)
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b)
(ByteString -> Builder
fromByteString ByteString
"\r\n")
(Maybe Int64 -> RequestHeaders
headerPairs Maybe Int64
contentLength)
headerPairToBuilder :: (HeaderName, ByteString) -> Builder
headerPairToBuilder (HeaderName
k, 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 ByteString
": "
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 ByteString
"\r\n"
setRequestIgnoreStatus :: Request -> Request
setRequestIgnoreStatus :: Request -> Request
setRequestIgnoreStatus Request
req = Request
req { checkResponse :: Request -> Response BodyReader -> IO ()
checkResponse = \Request
_ Response BodyReader
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
setRequestCheckStatus :: Request -> Request
setRequestCheckStatus :: Request -> Request
setRequestCheckStatus 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 [(ByteString, Maybe ByteString)]
qs 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 [(ByteString, [EscapeItem])]
qs 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 (\StreamFileStatus
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
observedStreamFile :: (StreamFileStatus -> IO ()) -> FilePath -> IO RequestBody
observedStreamFile :: (StreamFileStatus -> IO ()) -> String -> IO RequestBody
observedStreamFile StreamFileStatus -> IO ()
obs 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 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 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
$ \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