1{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE RecordWildCards #-} 3{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE CPP #-} 5{-# LANGUAGE ScopedTypeVariables #-} 6{-# LANGUAGE BangPatterns #-} 7{-# OPTIONS_GHC -fno-warn-orphans #-} 8 9module Network.HTTP.Client.Request 10 ( parseUrl 11 , parseUrlThrow 12 , parseRequest 13 , parseRequest_ 14 , requestFromURI 15 , requestFromURI_ 16 , defaultRequest 17 , setUriRelative 18 , getUri 19 , setUri 20 , setUriEither 21 , browserDecompress 22 , alwaysDecompress 23 , addProxy 24 , applyBasicAuth 25 , applyBasicProxyAuth 26 , urlEncodedBody 27 , needsGunzip 28 , requestBuilder 29 , setRequestIgnoreStatus 30 , setRequestCheckStatus 31 , setQueryString 32#if MIN_VERSION_http_types(0,12,1) 33 , setQueryStringPartialEscape 34#endif 35 , streamFile 36 , observedStreamFile 37 , extractBasicAuthInfo 38 , throwErrorStatusCodes 39 ) where 40 41import Data.Int (Int64) 42import Data.Maybe (fromMaybe, isJust, isNothing) 43import Data.Monoid (mempty, mappend, (<>)) 44import Data.String (IsString(..)) 45import Data.Char (toLower) 46import Control.Applicative as A ((<$>)) 47import Control.Monad (unless, guard) 48import Control.Monad.IO.Class (MonadIO, liftIO) 49import Numeric (showHex) 50 51import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteStringIO, flush) 52import Blaze.ByteString.Builder.Char8 (fromChar, fromShow) 53 54import qualified Data.ByteString as S 55import qualified Data.ByteString.Char8 as S8 56import qualified Data.ByteString.Lazy as L 57import Data.ByteString.Lazy.Internal (defaultChunkSize) 58 59import qualified Network.HTTP.Types as W 60import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, unEscapeString, isAllowedInURI) 61 62import Control.Exception (throw, throwIO, IOException) 63import qualified Control.Exception as E 64import qualified Data.CaseInsensitive as CI 65import qualified Data.ByteArray.Encoding as BAE 66 67import Network.HTTP.Client.Body 68import Network.HTTP.Client.Types 69import Network.HTTP.Client.Util 70 71import Control.Monad.Catch (MonadThrow, throwM) 72 73import System.IO (withBinaryFile, hTell, hFileSize, Handle, IOMode (ReadMode)) 74import Control.Monad (liftM) 75 76-- | Deprecated synonym for 'parseUrlThrow'. You probably want 77-- 'parseRequest' or 'parseRequest_' instead. 78-- 79-- @since 0.1.0 80parseUrl :: MonadThrow m => String -> m Request 81parseUrl = parseUrlThrow 82{-# DEPRECATED parseUrl "Please use parseUrlThrow, parseRequest, or parseRequest_ instead" #-} 83 84-- | Same as 'parseRequest', except will throw an 'HttpException' in the 85-- event of a non-2XX response. This uses 'throwErrorStatusCodes' to 86-- implement 'checkResponse'. 87-- 88-- @since 0.4.30 89parseUrlThrow :: MonadThrow m => String -> m Request 90parseUrlThrow = 91 liftM yesThrow . parseRequest 92 where 93 yesThrow req = req { checkResponse = throwErrorStatusCodes } 94 95-- | Throws a 'StatusCodeException' wrapped in 'HttpExceptionRequest', 96-- if the response's status code indicates an error (if it isn't 2xx). 97-- This can be used to implement 'checkResponse'. 98-- 99-- @since 0.5.13 100throwErrorStatusCodes :: MonadIO m => Request -> Response BodyReader -> m () 101throwErrorStatusCodes req res = do 102 let W.Status sci _ = responseStatus res 103 if 200 <= sci && sci < 300 104 then return () 105 else liftIO $ do 106 chunk <- brReadSome (responseBody res) 1024 107 let res' = fmap (const ()) res 108 let ex = StatusCodeException res' (L.toStrict chunk) 109 throwIO $ HttpExceptionRequest req ex 110 111-- | Convert a URL into a 'Request'. 112-- 113-- This function defaults some of the values in 'Request', such as setting 'method' to 114-- @"GET"@ and 'requestHeaders' to @[]@. 115-- 116-- Since this function uses 'MonadThrow', the return monad can be anything that is 117-- an instance of 'MonadThrow', such as 'IO' or 'Maybe'. 118-- 119-- You can place the request method at the beginning of the URL separated by a 120-- space, e.g.: 121-- 122-- @@@ 123-- parseRequest "POST http://httpbin.org/post" 124-- @@@ 125-- 126-- Note that the request method must be provided as all capital letters. 127-- 128-- A 'Request' created by this function won't cause exceptions on non-2XX 129-- response status codes. 130-- 131-- To create a request which throws on non-2XX status codes, see 'parseUrlThrow' 132-- 133-- @since 0.4.30 134parseRequest :: MonadThrow m => String -> m Request 135parseRequest s' = 136 case parseURI (encode s) of 137 Just uri -> liftM setMethod (setUri defaultRequest uri) 138 Nothing -> throwM $ InvalidUrlException s "Invalid URL" 139 where 140 encode = escapeURIString isAllowedInURI 141 (mmethod, s) = 142 case break (== ' ') s' of 143 (x, ' ':y) | all (\c -> 'A' <= c && c <= 'Z') x -> (Just x, y) 144 _ -> (Nothing, s') 145 146 setMethod req = 147 case mmethod of 148 Nothing -> req 149 Just m -> req { method = S8.pack m } 150 151-- | Same as 'parseRequest', but parse errors cause an impure exception. 152-- Mostly useful for static strings which are known to be correctly 153-- formatted. 154parseRequest_ :: String -> Request 155parseRequest_ = either throw id . parseRequest 156 157-- | Convert a 'URI' into a 'Request'. 158-- 159-- This can fail if the given 'URI' is not absolute, or if the 160-- 'URI' scheme is not @"http"@ or @"https"@. In these cases the function 161-- will throw an error via 'MonadThrow'. 162-- 163-- This function defaults some of the values in 'Request', such as setting 'method' to 164-- @"GET"@ and 'requestHeaders' to @[]@. 165-- 166-- A 'Request' created by this function won't cause exceptions on non-2XX 167-- response status codes. 168-- 169-- @since 0.5.12 170requestFromURI :: MonadThrow m => URI -> m Request 171requestFromURI = setUri defaultRequest 172 173-- | Same as 'requestFromURI', but if the conversion would fail, 174-- throws an impure exception. 175-- 176-- @since 0.5.12 177requestFromURI_ :: URI -> Request 178requestFromURI_ = either throw id . requestFromURI 179 180-- | Add a 'URI' to the request. If it is absolute (includes a host name), add 181-- it as per 'setUri'; if it is relative, merge it with the existing request. 182setUriRelative :: MonadThrow m => Request -> URI -> m Request 183setUriRelative req uri = setUri req $ uri `relativeTo` getUri req 184 185-- | Extract a 'URI' from the request. 186-- 187-- Since 0.1.0 188getUri :: Request -> URI 189getUri req = URI 190 { uriScheme = if secure req 191 then "https:" 192 else "http:" 193 , uriAuthority = Just URIAuth 194 { uriUserInfo = "" 195 , uriRegName = S8.unpack $ host req 196 , uriPort = port' 197 } 198 , uriPath = S8.unpack $ path req 199 , uriQuery = 200 case S8.uncons $ queryString req of 201 Just (c, _) | c /= '?' -> '?' : (S8.unpack $ queryString req) 202 _ -> S8.unpack $ queryString req 203 , uriFragment = "" 204 } 205 where 206 port' 207 | secure req && (port req) == 443 = "" 208 | not (secure req) && (port req) == 80 = "" 209 | otherwise = ':' : show (port req) 210 211applyAnyUriBasedAuth :: URI -> Request -> Request 212applyAnyUriBasedAuth uri req = 213 case extractBasicAuthInfo uri of 214 Just auth -> uncurry applyBasicAuth auth req 215 Nothing -> req 216 217-- | Extract basic access authentication info in URI. 218-- Return Nothing when there is no auth info in URI. 219extractBasicAuthInfo :: URI -> Maybe (S8.ByteString, S8.ByteString) 220extractBasicAuthInfo uri = do 221 userInfo <- uriUserInfo A.<$> uriAuthority uri 222 guard (':' `elem` userInfo) 223 let (username, ':':password) = break (==':') . takeWhile (/='@') $ userInfo 224 return (toLiteral username, toLiteral password) 225 where 226 toLiteral = S8.pack . unEscapeString 227 228-- | Validate a 'URI', then add it to the request. 229setUri :: MonadThrow m => Request -> URI -> m Request 230setUri req uri = either throwInvalidUrlException return (setUriEither req uri) 231 where 232 throwInvalidUrlException = throwM . InvalidUrlException (show uri) 233 234-- | A variant of `setUri` that returns an error message on validation errors, 235-- instead of propagating them with `throwM`. 236-- 237-- @since 0.6.1 238setUriEither :: Request -> URI -> Either String Request 239setUriEither req uri = do 240 sec <- parseScheme uri 241 auth <- maybe (Left "URL must be absolute") return $ uriAuthority uri 242 port' <- parsePort sec auth 243 return $ applyAnyUriBasedAuth uri req 244 { host = S8.pack $ uriRegName auth 245 , port = port' 246 , secure = sec 247 , path = S8.pack $ 248 if null $ uriPath uri 249 then "/" 250 else uriPath uri 251 , queryString = S8.pack $ uriQuery uri 252 } 253 where 254 parseScheme URI{uriScheme = scheme} = 255 case map toLower scheme of 256 "http:" -> return False 257 "https:" -> return True 258 _ -> Left "Invalid scheme" 259 260 parsePort sec URIAuth{uriPort = portStr} = 261 case portStr of 262 -- If the user specifies a port, then use it 263 ':':rest -> maybe 264 (Left "Invalid port") 265 return 266 (readPositiveInt rest) 267 -- Otherwise, use the default port 268 _ -> case sec of 269 False {- HTTP -} -> return 80 270 True {- HTTPS -} -> return 443 271 272-- | A default request value, a GET request of localhost/:80, with an 273-- empty request body. 274-- 275-- Note that the default 'checkResponse' does nothing. 276-- 277-- @since 0.4.30 278defaultRequest :: Request 279defaultRequest = Request 280 { host = "localhost" 281 , port = 80 282 , secure = False 283 , requestHeaders = [] 284 , path = "/" 285 , queryString = S8.empty 286 , requestBody = RequestBodyLBS L.empty 287 , method = "GET" 288 , proxy = Nothing 289 , hostAddress = Nothing 290 , rawBody = False 291 , decompress = browserDecompress 292 , redirectCount = 10 293 , checkResponse = \_ _ -> return () 294 , responseTimeout = ResponseTimeoutDefault 295 , cookieJar = Just Data.Monoid.mempty 296 , requestVersion = W.http11 297 , onRequestBodyException = \se -> 298 case E.fromException se of 299 Just (_ :: IOException) -> return () 300 Nothing -> throwIO se 301 , requestManagerOverride = Nothing 302 , shouldStripHeaderOnRedirect = const False 303 } 304 305-- | Parses a URL via 'parseRequest_' 306-- 307-- /NOTE/: Prior to version 0.5.0, this instance used 'parseUrlThrow' 308-- instead. 309instance IsString Request where 310 fromString = parseRequest_ 311 {-# INLINE fromString #-} 312 313-- | Always decompress a compressed stream. 314alwaysDecompress :: S.ByteString -> Bool 315alwaysDecompress = const True 316 317-- | Decompress a compressed stream unless the content-type is 'application/x-tar'. 318browserDecompress :: S.ByteString -> Bool 319browserDecompress = (/= "application/x-tar") 320 321-- | Build a basic-auth header value 322buildBasicAuth :: 323 S8.ByteString -- ^ Username 324 -> S8.ByteString -- ^ Password 325 -> S8.ByteString 326buildBasicAuth user passwd = 327 S8.append "Basic " (BAE.convertToBase BAE.Base64 (S8.concat [ user, ":", passwd ])) 328 329-- | Add a Basic Auth header (with the specified user name and password) to the 330-- given Request. Ignore error handling: 331-- 332-- > applyBasicAuth "user" "pass" $ parseRequest_ url 333-- 334-- NOTE: The function @applyDigestAuth@ is provided by the @http-client-tls@ 335-- package instead of this package due to extra dependencies. Please use that 336-- package if you need to use digest authentication. 337-- 338-- Since 0.1.0 339applyBasicAuth :: S.ByteString -> S.ByteString -> Request -> Request 340applyBasicAuth user passwd req = 341 req { requestHeaders = authHeader : requestHeaders req } 342 where 343 authHeader = (CI.mk "Authorization", buildBasicAuth user passwd) 344 345-- | Add a proxy to the Request so that the Request when executed will use 346-- the provided proxy. 347-- 348-- Since 0.1.0 349addProxy :: S.ByteString -> Int -> Request -> Request 350addProxy hst prt req = 351 req { proxy = Just $ Proxy hst prt } 352 353-- | Add a Proxy-Authorization header (with the specified username and 354-- password) to the given 'Request'. Ignore error handling: 355-- 356-- > applyBasicProxyAuth "user" "pass" <$> parseRequest "http://example.org" 357-- 358-- Since 0.3.4 359 360applyBasicProxyAuth :: S.ByteString -> S.ByteString -> Request -> Request 361applyBasicProxyAuth user passwd req = 362 req { requestHeaders = authHeader : requestHeaders req } 363 where 364 authHeader = (CI.mk "Proxy-Authorization", buildBasicAuth user passwd) 365 366-- | Add url-encoded parameters to the 'Request'. 367-- 368-- This sets a new 'requestBody', adds a content-type request header and 369-- changes the 'method' to POST. 370-- 371-- Since 0.1.0 372urlEncodedBody :: [(S.ByteString, S.ByteString)] -> Request -> Request 373urlEncodedBody headers req = req 374 { requestBody = RequestBodyLBS body 375 , method = "POST" 376 , requestHeaders = 377 (ct, "application/x-www-form-urlencoded") 378 : filter (\(x, _) -> x /= ct) (requestHeaders req) 379 } 380 where 381 ct = "Content-Type" 382 body = L.fromChunks . return $ W.renderSimpleQuery False headers 383 384needsGunzip :: Request 385 -> [W.Header] -- ^ response headers 386 -> Bool 387needsGunzip req hs' = 388 not (rawBody req) 389 && ("content-encoding", "gzip") `elem` hs' 390 && decompress req (fromMaybe "" $ lookup "content-type" hs') 391 392requestBuilder :: Request -> Connection -> IO (Maybe (IO ())) 393requestBuilder req Connection {..} = do 394 (contentLength, sendNow, sendLater) <- toTriple (requestBody req) 395 if expectContinue 396 then flushHeaders contentLength >> return (Just (checkBadSend sendLater)) 397 else sendNow >> return Nothing 398 where 399 expectContinue = Just "100-continue" == lookup "Expect" (requestHeaders req) 400 checkBadSend f = f `E.catch` onRequestBodyException req 401 writeBuilder = toByteStringIO connectionWrite 402 writeHeadersWith contentLength = writeBuilder . (builder contentLength `Data.Monoid.mappend`) 403 flushHeaders contentLength = writeHeadersWith contentLength flush 404 405 toTriple (RequestBodyLBS lbs) = do 406 let body = fromLazyByteString lbs 407 len = Just $ L.length lbs 408 now = checkBadSend $ writeHeadersWith len body 409 later = writeBuilder body 410 return (len, now, later) 411 toTriple (RequestBodyBS bs) = do 412 let body = fromByteString bs 413 len = Just $ fromIntegral $ S.length bs 414 now = checkBadSend $ writeHeadersWith len body 415 later = writeBuilder body 416 return (len, now, later) 417 toTriple (RequestBodyBuilder len body) = do 418 let now = checkBadSend $ writeHeadersWith (Just len) body 419 later = writeBuilder body 420 return (Just len, now, later) 421 toTriple (RequestBodyStream len stream) = do 422 -- See https://github.com/snoyberg/http-client/issues/74 for usage 423 -- of flush here. 424 let body = writeStream (Just . fromIntegral $ len) stream 425 -- Don't check for a bad send on the headers themselves. 426 -- Ideally, we'd do the same thing for the other request body 427 -- types, but it would also introduce a performance hit since 428 -- we couldn't merge request headers and bodies together. 429 now = flushHeaders (Just len) >> checkBadSend body 430 return (Just len, now, body) 431 toTriple (RequestBodyStreamChunked stream) = do 432 let body = writeStream Nothing stream 433 now = flushHeaders Nothing >> checkBadSend body 434 return (Nothing, now, body) 435 toTriple (RequestBodyIO mbody) = mbody >>= toTriple 436 437 writeStream mlen withStream = 438 withStream (loop 0) 439 where 440 loop !n stream = do 441 bs <- stream 442 if S.null bs 443 then case mlen of 444 -- If stream is chunked, no length argument 445 Nothing -> connectionWrite "0\r\n\r\n" 446 -- Not chunked - validate length argument 447 Just len -> unless (len == n) $ throwHttp $ WrongRequestBodyStreamSize (fromIntegral len) (fromIntegral n) 448 else do 449 connectionWrite $ 450 if (isNothing mlen) -- Chunked 451 then S.concat 452 [ S8.pack $ showHex (S.length bs) "\r\n" 453 , bs 454 , "\r\n" 455 ] 456 else bs 457 loop (n + (S.length bs)) stream 458 459 hh 460 | port req == 80 && not (secure req) = host req 461 | port req == 443 && secure req = host req 462 | otherwise = host req <> S8.pack (':' : show (port req)) 463 464 requestProtocol 465 | secure req = fromByteString "https://" 466 | otherwise = fromByteString "http://" 467 468 requestHostname 469 | isJust (proxy req) && not (secure req) 470 = requestProtocol <> fromByteString hh 471 | otherwise = mempty 472 473 contentLengthHeader (Just contentLength') = 474 if method req `elem` ["GET", "HEAD"] && contentLength' == 0 475 then id 476 else (:) ("Content-Length", S8.pack $ show contentLength') 477 contentLengthHeader Nothing = (:) ("Transfer-Encoding", "chunked") 478 479 acceptEncodingHeader = 480 case lookup "Accept-Encoding" $ requestHeaders req of 481 Nothing -> (("Accept-Encoding", "gzip"):) 482 Just "" -> filter (\(k, _) -> k /= "Accept-Encoding") 483 Just _ -> id 484 485 hostHeader x = 486 case lookup "Host" x of 487 Nothing -> ("Host", hh) : x 488 Just{} -> x 489 490 headerPairs :: Maybe Int64 -> W.RequestHeaders 491 headerPairs contentLength 492 = hostHeader 493 $ acceptEncodingHeader 494 $ contentLengthHeader contentLength 495 $ requestHeaders req 496 497 builder :: Maybe Int64 -> Builder 498 builder contentLength = 499 fromByteString (method req) 500 <> fromByteString " " 501 <> requestHostname 502 <> (case S8.uncons $ path req of 503 Just ('/', _) -> fromByteString $ path req 504 _ -> fromChar '/' <> fromByteString (path req)) 505 <> (case S8.uncons $ queryString req of 506 Nothing -> mempty 507 Just ('?', _) -> fromByteString $ queryString req 508 _ -> fromChar '?' <> fromByteString (queryString req)) 509 <> (case requestVersion req of 510 W.HttpVersion 1 1 -> fromByteString " HTTP/1.1\r\n" 511 W.HttpVersion 1 0 -> fromByteString " HTTP/1.0\r\n" 512 version -> 513 fromChar ' ' <> 514 fromShow version <> 515 fromByteString "\r\n") 516 <> foldr 517 (\a b -> headerPairToBuilder a <> b) 518 (fromByteString "\r\n") 519 (headerPairs contentLength) 520 521 headerPairToBuilder (k, v) = 522 fromByteString (CI.original k) 523 <> fromByteString ": " 524 <> fromByteString v 525 <> fromByteString "\r\n" 526 527-- | Modify the request so that non-2XX status codes do not generate a runtime 528-- 'StatusCodeException'. 529-- 530-- @since 0.4.29 531setRequestIgnoreStatus :: Request -> Request 532setRequestIgnoreStatus req = req { checkResponse = \_ _ -> return () } 533 534-- | Modify the request so that non-2XX status codes generate a runtime 535-- 'StatusCodeException', by using 'throwErrorStatusCodes' 536-- 537-- @since 0.5.13 538setRequestCheckStatus :: Request -> Request 539setRequestCheckStatus req = req { checkResponse = throwErrorStatusCodes } 540 541-- | Set the query string to the given key/value pairs. 542-- 543-- Since 0.3.6 544setQueryString :: [(S.ByteString, Maybe S.ByteString)] -> Request -> Request 545setQueryString qs req = req { queryString = W.renderQuery True qs } 546 547#if MIN_VERSION_http_types(0,12,1) 548-- | Set the query string to the given key/value pairs. 549-- 550-- @since 0.5.10 551setQueryStringPartialEscape :: [(S.ByteString, [W.EscapeItem])] -> Request -> Request 552setQueryStringPartialEscape qs req = req { queryString = W.renderQueryPartialEscape True qs } 553#endif 554 555-- | Send a file as the request body. 556-- 557-- It is expected that the file size does not change between calling 558-- `streamFile` and making any requests using this request body. 559-- 560-- Since 0.4.9 561streamFile :: FilePath -> IO RequestBody 562streamFile = observedStreamFile (\_ -> return ()) 563 564-- | Send a file as the request body, while observing streaming progress via 565-- a `PopObserver`. Observations are made between reading and sending a chunk. 566-- 567-- It is expected that the file size does not change between calling 568-- `observedStreamFile` and making any requests using this request body. 569-- 570-- Since 0.4.9 571observedStreamFile :: (StreamFileStatus -> IO ()) -> FilePath -> IO RequestBody 572observedStreamFile obs path = do 573 size <- fromIntegral <$> withBinaryFile path ReadMode hFileSize 574 575 let filePopper :: Handle -> Popper 576 filePopper h = do 577 bs <- S.hGetSome h defaultChunkSize 578 currentPosition <- fromIntegral <$> hTell h 579 obs $ StreamFileStatus 580 { fileSize = size 581 , readSoFar = currentPosition 582 , thisChunkSize = S.length bs 583 } 584 return bs 585 586 givesFilePopper :: GivesPopper () 587 givesFilePopper k = withBinaryFile path ReadMode $ \h -> do 588 k (filePopper h) 589 590 return $ RequestBodyStream size givesFilePopper 591