{-# 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 :: forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrl = forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow
{-# DEPRECATED parseUrl "Please use parseUrlThrow, parseRequest, or parseRequest_ instead" #-}
parseUrlThrow :: MonadThrow m => String -> m Request
parseUrlThrow :: forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow =
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> Request
yesThrow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest
where
yesThrow :: Request -> Request
yesThrow Request
req = Request
req { checkResponse :: Request -> Response BodyReader -> IO ()
checkResponse = forall (m :: * -> *).
MonadIO m =>
Request -> Response BodyReader -> m ()
throwErrorStatusCodes }
throwErrorStatusCodes :: MonadIO m => Request -> Response BodyReader -> m ()
throwErrorStatusCodes :: forall (m :: * -> *).
MonadIO m =>
Request -> Response BodyReader -> m ()
throwErrorStatusCodes Request
req Response BodyReader
res = do
let W.Status Int
sci ByteString
_ = forall body. Response body -> Status
responseStatus Response BodyReader
res
if Int
200 forall a. Ord a => a -> a -> Bool
<= Int
sci Bool -> Bool -> Bool
&& Int
sci forall a. Ord a => a -> a -> Bool
< Int
300
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
ByteString
chunk <- BodyReader -> Int -> IO ByteString
brReadSome (forall body. Response body -> body
responseBody Response BodyReader
res) Int
1024
let res' :: Response ()
res' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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)
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HttpExceptionRequest Request
req HttpExceptionContent
ex
parseRequest :: MonadThrow m => String -> m Request
parseRequest :: forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
s' =
case String -> Maybe URI
parseURI (String -> String
encode String
s) of
Just URI
uri -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> Request
setMethod (forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
setUri Request
defaultRequest URI
uri)
Maybe URI
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM 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 forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
' ') String
s' of
(String
x, Char
' ':String
y) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char
'A' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'Z') String
x -> (forall a. a -> Maybe a
Just String
x, String
y)
(String, 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_ = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest
requestFromURI :: MonadThrow m => URI -> m Request
requestFromURI :: forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI = forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
setUri Request
defaultRequest
requestFromURI_ :: URI -> Request
requestFromURI_ :: URI -> Request
requestFromURI_ = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI
setUriRelative :: MonadThrow m => Request -> URI -> m Request
setUriRelative :: forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
setUriRelative Request
req URI
uri = forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
setUri Request
req 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
{ uriScheme :: String
uriScheme = if Request -> Bool
secure Request
req
then String
"https:"
else String
"http:"
, uriAuthority :: Maybe URIAuth
uriAuthority = forall a. a -> Maybe a
Just URIAuth
{ uriUserInfo :: String
uriUserInfo = String
""
, uriRegName :: String
uriRegName = ByteString -> String
S8.unpack forall a b. (a -> b) -> a -> b
$ Request -> ByteString
host Request
req
, uriPort :: String
uriPort = String
port'
}
, uriPath :: String
uriPath = ByteString -> String
S8.unpack forall a b. (a -> b) -> a -> b
$ Request -> ByteString
path Request
req
, uriQuery :: String
uriQuery =
case ByteString -> Maybe (Char, ByteString)
S8.uncons forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req of
Just (Char
c, ByteString
_) | Char
c forall a. Eq a => a -> a -> Bool
/= Char
'?' -> Char
'?' forall a. a -> [a] -> [a]
: (ByteString -> String
S8.unpack forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req)
Maybe (Char, ByteString)
_ -> ByteString -> String
S8.unpack 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) 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) forall a. Eq a => a -> a -> Bool
== Int
80 = String
""
| Bool
otherwise = Char
':' forall a. a -> [a] -> [a]
: 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 -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> URI -> Maybe URIAuth
uriAuthority URI
uri
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char
':' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
userInfo)
let (String
username, Char
':':String
password) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Char
':') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
'@') forall a b. (a -> b) -> a -> b
$ String
userInfo
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
unEscapeString
setUri :: MonadThrow m => Request -> URI -> m Request
setUri :: forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
setUri Request
req URI
uri = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a}. String -> m a
throwInvalidUrlException 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 = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> HttpException
InvalidUrlException (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 <- forall {a}. IsString a => URI -> Either a Bool
parseScheme URI
uri
URIAuth
auth <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left String
"URL must be absolute") forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ URI -> Maybe URIAuth
uriAuthority URI
uri
Int
port' <- forall {a}. IsString a => Bool -> URIAuth -> Either a Int
parsePort Bool
sec URIAuth
auth
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ URI -> Request -> Request
applyAnyUriBasedAuth URI
uri Request
req
{ host :: ByteString
host = String -> ByteString
S8.pack 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 forall a b. (a -> b) -> a -> b
$
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null 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 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 forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
scheme of
String
"http:" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
String
"https:" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
String
_ -> 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 -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall a b. a -> Either a b
Left a
"Invalid port")
forall (m :: * -> *) a. Monad m => a -> m a
return
(String -> Maybe Int
readPositiveInt String
rest)
String
_ -> case Bool
sec of
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
80
Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
443
defaultRequest :: Request
defaultRequest :: Request
defaultRequest = 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 = forall a. Maybe a
Nothing
, hostAddress :: Maybe HostAddress
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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
, responseTimeout :: ResponseTimeout
responseTimeout = ResponseTimeout
ResponseTimeoutDefault
, cookieJar :: Maybe CookieJar
cookieJar = forall a. a -> Maybe a
Just forall a. Monoid a => a
Data.Monoid.mempty
, requestVersion :: HttpVersion
requestVersion = HttpVersion
W.http11
, onRequestBodyException :: SomeException -> IO ()
onRequestBodyException = \SomeException
se ->
case forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se of
Just (IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe IOException
Nothing -> forall e a. Exception e => e -> IO a
throwIO SomeException
se
, requestManagerOverride :: Maybe Manager
requestManagerOverride = forall a. Maybe a
Nothing
, shouldStripHeaderOnRedirect :: HeaderName -> Bool
shouldStripHeaderOnRedirect = forall a b. a -> b -> a
const Bool
False
, shouldStripHeaderOnRedirectIfOnDifferentHostOnly :: Bool
shouldStripHeaderOnRedirectIfOnDifferentHostOnly = Bool
False
, proxySecureMode :: ProxySecureMode
proxySecureMode = ProxySecureMode
ProxySecureWithConnect
, redactHeaders :: Set HeaderName
redactHeaders = 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 = forall a b. a -> b -> a
const Bool
True
browserDecompress :: S.ByteString -> Bool
browserDecompress :: ByteString -> Bool
browserDecompress = (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 forall a. a -> [a] -> [a]
: Request -> RequestHeaders
requestHeaders Request
req }
where
authHeader :: (HeaderName, ByteString)
authHeader = (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 forall a. a -> [a] -> [a]
: Request -> RequestHeaders
requestHeaders Request
req }
where
authHeader :: (HeaderName, ByteString)
authHeader = (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 = forall a. a -> Maybe a
Just 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 forall a. a -> [a] -> [a]
: Request -> RequestHeaders
requestHeaders Request
req }
where
authHeader :: (HeaderName, ByteString)
authHeader = (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")
forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
x, ByteString
_) -> HeaderName
x 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return 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") forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` RequestHeaders
hs'
Bool -> Bool -> Bool
&& Request -> ByteString -> Bool
decompress Request
req (forall a. a -> Maybe a -> a
fromMaybe ByteString
"" forall a b. (a -> b) -> a -> b
$ 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
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 :: forall a. IO a -> IO a
encapsulatePopperException IO a
action =
IO a
action forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\(SomeException
ex :: E.SomeException) -> 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (IO () -> IO ()
checkBadSend IO ()
sendLater))
else IO ()
sendNow forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
where
expectContinue :: Bool
expectContinue = forall a. a -> Maybe a
Just ByteString
"100-continue" forall a. Eq a => a -> a -> Bool
== 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 forall a. IO a -> [Handler a] -> IO a
`E.catches` [
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler (\(EncapsulatedPopperException SomeException
ex) -> forall e a. Exception e => e -> IO a
throwIO SomeException
ex)
, 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Int64 -> Builder
builder Maybe Int64
contentLength 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
lbs
now :: IO ()
now = IO () -> IO ()
checkBadSend 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
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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
bs
now :: IO ()
now = IO () -> IO ()
checkBadSend 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
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 forall a b. (a -> b) -> a -> b
$ Maybe Int64 -> Builder -> IO ()
writeHeadersWith (forall a. a -> Maybe a
Just Int64
len) Builder
body
later :: IO ()
later = Builder -> IO ()
writeBuilder Builder
body
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Int64
len, IO ()
now, IO ()
later)
toTriple (RequestBodyStream Int64
len GivesPopper ()
stream) = do
let body :: IO ()
body = forall {t}. Maybe Int -> ((BodyReader -> IO ()) -> t) -> t
writeStream (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int64
len) GivesPopper ()
stream
now :: IO ()
now = Maybe Int64 -> IO ()
flushHeaders (forall a. a -> Maybe a
Just Int64
len) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO ()
checkBadSend IO ()
body
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Int64
len, IO ()
now, IO ()
body)
toTriple (RequestBodyStreamChunked GivesPopper ()
stream) = do
let body :: IO ()
body = forall {t}. Maybe Int -> ((BodyReader -> IO ()) -> t) -> t
writeStream forall a. Maybe a
Nothing GivesPopper ()
stream
now :: IO ()
now = Maybe Int64 -> IO ()
flushHeaders forall a. Maybe a
Nothing forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO ()
checkBadSend IO ()
body
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, IO ()
now, IO ()
body)
toTriple (RequestBodyIO IO RequestBody
mbody) = IO RequestBody
mbody 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 <- 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 Int
len -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
len forall a. Eq a => a -> a -> Bool
== Int
n) forall a b. (a -> b) -> a -> b
$ forall a. HttpExceptionContent -> IO a
throwHttp forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> HttpExceptionContent
WrongRequestBodyStreamSize (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
else do
ByteString -> IO ()
connectionWrite forall a b. (a -> b) -> a -> b
$
if (forall a. Maybe a -> Bool
isNothing Maybe Int
mlen)
then [ByteString] -> ByteString
S.concat
[ String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ 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 forall a. Num a => a -> a -> a
+ (ByteString -> Int
S.length ByteString
bs)) BodyReader
stream
hh :: ByteString
hh
| Request -> Int
port Request
req 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 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 forall a. Semigroup a => a -> a -> a
<> String -> ByteString
S8.pack (Char
':' forall a. a -> [a] -> [a]
: 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 }) = forall a. Monoid a => a
mempty
requestHostname (Request { proxy :: Request -> Maybe Proxy
proxy = Just Proxy
_,
secure :: Request -> Bool
secure = Bool
False }) =
Builder
requestProtocol 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 }) = 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 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"GET", ByteString
"HEAD"] Bool -> Bool -> Bool
&& a
contentLength' forall a. Eq a => a -> a -> Bool
== a
0
then forall a. a -> a
id
else (:) (a
"Content-Length", String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
contentLength')
contentLengthHeader Maybe a
Nothing = (:) (a
"Transfer-Encoding", ByteString
"chunked")
acceptEncodingHeader :: RequestHeaders -> RequestHeaders
acceptEncodingHeader =
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Accept-Encoding" forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req of
Maybe ByteString
Nothing -> ((HeaderName
"Accept-Encoding", ByteString
"gzip")forall a. a -> [a] -> [a]
:)
Just ByteString
"" -> forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
k, ByteString
_) -> HeaderName
k forall a. Eq a => a -> a -> Bool
/= HeaderName
"Accept-Encoding")
Just ByteString
_ -> forall a. a -> a
id
hostHeader :: [(a, ByteString)] -> [(a, ByteString)]
hostHeader [(a, ByteString)]
x =
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"Host" [(a, ByteString)]
x of
Maybe ByteString
Nothing -> (a
"Host", ByteString
hh) 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
= forall {a}.
(Eq a, IsString a) =>
[(a, ByteString)] -> [(a, ByteString)]
hostHeader
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> RequestHeaders
acceptEncodingHeader
forall a b. (a -> b) -> a -> b
$ forall {a} {a}.
(Eq a, Num a, IsString a, Show a) =>
Maybe a -> [(a, ByteString)] -> [(a, ByteString)]
contentLengthHeader Maybe Int64
contentLength
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)
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
" "
forall a. Semigroup a => a -> a -> a
<> Request -> Builder
requestHostname Request
req
forall a. Semigroup a => a -> a -> a
<> (case ByteString -> Maybe (Char, ByteString)
S8.uncons forall a b. (a -> b) -> a -> b
$ Request -> ByteString
path Request
req of
Just (Char
'/', ByteString
_) -> ByteString -> Builder
fromByteString forall a b. (a -> b) -> a -> b
$ Request -> ByteString
path Request
req
Maybe (Char, ByteString)
_ -> Char -> Builder
fromChar Char
'/' forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (Request -> ByteString
path Request
req))
forall a. Semigroup a => a -> a -> a
<> (case ByteString -> Maybe (Char, ByteString)
S8.uncons forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req of
Maybe (Char, ByteString)
Nothing -> forall a. Monoid a => a
mempty
Just (Char
'?', ByteString
_) -> ByteString -> Builder
fromByteString forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req
Maybe (Char, ByteString)
_ -> Char -> Builder
fromChar Char
'?' forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (Request -> ByteString
queryString Request
req))
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
' ' forall a. Semigroup a => a -> a -> a
<>
forall a. Show a => a -> Builder
fromShow HttpVersion
version forall a. Semigroup a => a -> a -> a
<>
ByteString -> Builder
fromByteString ByteString
"\r\n")
forall a. Semigroup a => a -> a -> a
<> 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 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 (forall s. CI s -> s
CI.original HeaderName
k)
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
": "
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
v
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
_ -> 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 = 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
_ -> 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 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Integer
hTell Handle
h
StreamFileStatus -> IO ()
obs forall a b. (a -> b) -> a -> b
$ StreamFileStatus
{ fileSize :: Int64
fileSize = Int64
size
, readSoFar :: Int64
readSoFar = Int64
currentPosition
, thisChunkSize :: Int
thisChunkSize = ByteString -> Int
S.length ByteString
bs
}
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
givesFilePopper :: GivesPopper ()
givesFilePopper :: GivesPopper ()
givesFilePopper BodyReader -> IO ()
k = forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
BodyReader -> IO ()
k (Handle -> BodyReader
filePopper Handle
h)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int64 -> GivesPopper () -> RequestBody
RequestBodyStream Int64
size GivesPopper ()
givesFilePopper