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