module Network.HTTP.Conduit.Request
( Request (..)
, RequestBody (..)
, ContentType
, Proxy (..)
, parseUrl
, browserDecompress
, HttpException (..)
, alwaysDecompress
, addProxy
, applyBasicAuth
, urlEncodedBody
, needsGunzip
, requestBuilder
) where
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty, mappend)
import Data.Typeable (Typeable)
import Data.Default (Default (def))
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
import Blaze.ByteString.Builder.Char8 (fromChar)
import qualified Blaze.ByteString.Builder as Blaze
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Network.HTTP.Types as W
import Network.Socks5 (SocksConf)
import Control.Exception (Exception, SomeException, toException)
import Control.Failure (Failure (failure))
import Codec.Binary.UTF8.String (encodeString)
import qualified Data.CaseInsensitive as CI
import qualified Data.ByteString.Base64 as B64
import Network.HTTP.Conduit.Chunk (chunkIt)
import Network.HTTP.Conduit.Util (readDec, (<>))
type ContentType = S.ByteString
data Request m = Request
{ method :: W.Method
, secure :: Bool
, host :: W.Ascii
, port :: Int
, path :: W.Ascii
, queryString :: W.Ascii
, requestHeaders :: W.RequestHeaders
, requestBody :: RequestBody m
, proxy :: Maybe Proxy
, socksProxy :: Maybe SocksConf
, rawBody :: Bool
, decompress :: ContentType -> Bool
, redirectCount :: Int
, checkStatus :: W.Status -> W.ResponseHeaders -> Maybe SomeException
}
data RequestBody m
= RequestBodyLBS L.ByteString
| RequestBodyBS S.ByteString
| RequestBodyBuilder Int64 Blaze.Builder
| RequestBodySource Int64 (C.Source m Blaze.Builder)
| RequestBodySourceChunked (C.Source m Blaze.Builder)
data Proxy = Proxy
{ proxyHost :: W.Ascii
, proxyPort :: Int
}
encodeUrlCharPI :: Char -> String
encodeUrlCharPI '/' = "/"
encodeUrlCharPI '%' = "%"
encodeUrlCharPI c = encodeUrlChar c
encodeUrlChar :: Char -> String
encodeUrlChar c
| 'A' <= c && c <= 'Z' = [c]
| 'a' <= c && c <= 'z' = [c]
| '0' <= c && c <= '9' = [c]
encodeUrlChar c@'-' = [c]
encodeUrlChar c@'_' = [c]
encodeUrlChar c@'.' = [c]
encodeUrlChar c@'~' = [c]
encodeUrlChar y =
let (a, c) = fromEnum y `divMod` 16
b = a `mod` 16
showHex' x
| x < 10 = toEnum $ x + (fromEnum '0')
| x < 16 = toEnum $ x 10 + (fromEnum 'A')
| otherwise = error $ "Invalid argument to showHex: " ++ show x
in ['%', showHex' b, showHex' c]
parseUrl :: Failure HttpException m => String -> m (Request m')
parseUrl s@('h':'t':'t':'p':':':'/':'/':rest) = parseUrl1 s False rest
parseUrl s@('h':'t':'t':'p':'s':':':'/':'/':rest) = parseUrl1 s True rest
parseUrl x = failure $ InvalidUrlException x "Invalid scheme"
parseUrl1 :: Failure HttpException m
=> String -> Bool -> String -> m (Request m')
parseUrl1 full sec s =
parseUrl2 full sec s'
where
s' = encodeString s
instance Default (Request m) where
def = Request
{ host = "localhost"
, port = 80
, secure = False
, requestHeaders = []
, path = "/"
, queryString = S8.empty
, requestBody = RequestBodyLBS L.empty
, method = "GET"
, proxy = Nothing
, socksProxy = Nothing
, rawBody = False
, decompress = browserDecompress
, redirectCount = 10
, checkStatus = \s@(W.Status sci _) hs ->
if 200 <= sci && sci < 300
then Nothing
else Just $ toException $ StatusCodeException s hs
}
parseUrl2 :: Failure HttpException m
=> String -> Bool -> String -> m (Request m')
parseUrl2 full sec s = do
port' <- mport
return def
{ host = S8.pack hostname
, port = port'
, secure = sec
, path = S8.pack
$ if null path''
then "/"
else concatMap encodeUrlCharPI path''
, queryString = S8.pack qstring
}
where
(beforeSlash, afterSlash) = break (== '/') s
(hostname, portStr) = break (== ':') beforeSlash
(path', qstring') = break (== '?') afterSlash
path'' = path'
qstring'' = case qstring' of
'?':x -> x
_ -> qstring'
qstring = takeWhile (/= '#') qstring''
mport =
case (portStr, sec) of
("", False) -> return 80
("", True) -> return 443
(':':rest, _) -> maybe
(failure $ InvalidUrlException full "Invalid port")
return
(readDec rest)
x -> error $ "parseUrl1: this should never happen: " ++ show x
data HttpException = StatusCodeException W.Status W.ResponseHeaders
| InvalidUrlException String String
| TooManyRedirects
| UnparseableRedirect
| TooManyRetries
| HttpParserException String
| HandshakeFailed
| OverlongHeaders
deriving (Show, Typeable)
instance Exception HttpException
alwaysDecompress :: ContentType -> Bool
alwaysDecompress = const True
browserDecompress :: ContentType -> Bool
browserDecompress = (/= "application/x-tar")
applyBasicAuth :: S.ByteString -> S.ByteString -> Request m -> Request m
applyBasicAuth user passwd req =
req { requestHeaders = authHeader : requestHeaders req }
where
authHeader = (CI.mk "Authorization", basic)
basic = S8.append "Basic " (B64.encode $ S8.concat [ user, ":", passwd ])
addProxy :: S.ByteString -> Int -> Request m -> Request m
addProxy hst prt req =
req { proxy = Just $ Proxy hst prt }
urlEncodedBody :: Monad m => [(S.ByteString, S.ByteString)] -> Request m' -> Request m
urlEncodedBody headers req = req
{ requestBody = RequestBodyLBS body
, method = "POST"
, requestHeaders =
(ct, "application/x-www-form-urlencoded")
: filter (\(x, _) -> x /= ct) (requestHeaders req)
}
where
ct = "Content-Type"
body = L.fromChunks . return $ W.renderSimpleQuery False headers
needsGunzip :: Request m
-> [W.Header]
-> Bool
needsGunzip req hs' =
not (rawBody req)
&& ("content-encoding", "gzip") `elem` hs'
&& decompress req (fromMaybe "" $ lookup "content-type" hs')
requestBuilder
:: Monad m
=> Request m
-> C.Source m Builder
requestBuilder req =
CL.sourceList [builder] `mappend` bodySource
where
sourceSingle = CL.sourceList . return
(contentLength, bodySource) =
case requestBody req of
RequestBodyLBS lbs -> (Just $ L.length lbs, sourceSingle $ fromLazyByteString lbs)
RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, sourceSingle $ fromByteString bs)
RequestBodyBuilder i b -> (Just $ i, sourceSingle b)
RequestBodySource i source -> (Just i, source)
RequestBodySourceChunked source -> (Nothing, source C.$= chunkIt)
hh
| port req == 80 && not (secure req) = host req
| port req == 443 && secure req = host req
| otherwise = host req <> S8.pack (':' : show (port req))
contentLengthHeader (Just contentLength') =
if method req `elem` ["GET", "HEAD"] && contentLength' == 0
then id
else (:) ("Content-Length", S8.pack $ show contentLength')
contentLengthHeader Nothing = (:) ("Transfer-Encoding", "chunked")
headerPairs :: W.RequestHeaders
headerPairs
= ("Host", hh)
: ("Accept-Encoding", "gzip")
: (contentLengthHeader contentLength)
(requestHeaders req)
builder :: Builder
builder =
fromByteString (method req)
<> fromByteString " "
<> (case S8.uncons $ path req of
Just ('/', _) -> fromByteString $ path req
_ -> fromByteString "/" <> fromByteString (path req))
<> (if S8.null (queryString req)
then mempty
else fromChar '?' <> fromByteString (queryString req))
<> fromByteString " HTTP/1.1\r\n"
<> foldr
(\a b -> headerPairToBuilder a <> b)
(fromByteString "\r\n")
headerPairs
headerPairToBuilder (k, v) =
fromByteString (CI.original k)
<> fromByteString ": "
<> fromByteString v
<> fromByteString "\r\n"