http-client 0.1.0.0 → 0.2.0.0
raw patch · 27 files changed
+2469/−2149 lines, 27 filesdep ~base
Dependency ranges changed: base
Files
- Network/HTTP/Client.hs +118/−0
- Network/HTTP/Client/Body.hs +201/−0
- Network/HTTP/Client/Connection.hs +135/−0
- Network/HTTP/Client/Cookies.hs +250/−0
- Network/HTTP/Client/Core.hs +214/−0
- Network/HTTP/Client/Headers.hs +86/−0
- Network/HTTP/Client/Internal.hs +39/−0
- Network/HTTP/Client/Manager.hs +319/−0
- Network/HTTP/Client/Request.hs +352/−0
- Network/HTTP/Client/Response.hs +139/−0
- Network/HTTP/Client/Types.hs +502/−0
- Network/HTTP/Client/Util.hs +84/−0
- http-client.cabal +21/−22
- src/Network/HTTP/Client.hs +0/−199
- src/Network/HTTP/Client/Body.hs +0/−194
- src/Network/HTTP/Client/Connection.hs +0/−132
- src/Network/HTTP/Client/Cookies.hs +0/−246
- src/Network/HTTP/Client/Headers.hs +0/−75
- src/Network/HTTP/Client/Manager.hs +0/−371
- src/Network/HTTP/Client/Request.hs +0/−343
- src/Network/HTTP/Client/Response.hs +0/−140
- src/Network/HTTP/Client/Types.hs +0/−327
- src/Network/HTTP/Client/Util.hs +0/−84
- test/Network/HTTP/Client/BodySpec.hs +2/−2
- test/Network/HTTP/Client/HeadersSpec.hs +2/−3
- test/Network/HTTP/Client/ResponseSpec.hs +2/−4
- test/Network/HTTP/ClientSpec.hs +3/−7
+ Network/HTTP/Client.hs view
@@ -0,0 +1,118 @@+-- | This is the main entry point for using http-client. Used by itself, this+-- module provides low-level access for streaming request and response bodies,+-- and only non-secure HTTP connections. Helper packages such as http-conduit+-- provided higher level streaming approaches, while other helper packages like+-- http-client-tls provide secure connections.+--+-- There are three core components to be understood here: requests, responses,+-- and managers. A @Manager@ keeps track of open connections to various hosts,+-- and when requested, will provide either an existing open connection or+-- create a new connection on demand. A @Manager@ also automatically reaps+-- connections which have been unused for a certain period of time. A @Manager@+-- allows for more efficient HTTP usage by allowing for keep-alive connections.+-- Secure HTTP connections can be allowed by modifying the settings used for+-- creating a manager. The simplest way to create a @Manager@ is with:+--+-- > 'newManager' 'defaultManagerSettings'+--+-- The next core component is a @Request@, which represents a single HTTP+-- request to be sent to a specific server. @Request@s allow for many settings+-- to control exact how they function, but usually the simplest approach for+-- creating a @Request@ is to use 'parseUrl'.+--+-- Finally, a @Response@ is the result of sending a single @Request@ to a+-- server, over a connection which was acquired from a @Manager@. Note that you+-- must close the response when you're done with it to ensure that the+-- connection is recycled to the @Manager@ to either be used by another+-- request, or to be reaped. Usage of @withResponse@ will ensure that this+-- happens automatically.+--+-- Helper packages may provide replacements for various recommendations listed+-- above. For example, if using http-client-tls, instead of using+-- 'defaultManagerSettings', you would want to use @tlsManagerSettings@. Be+-- sure to read the relevant helper library documentation for more information.+--+-- A note on exceptions: for the most part, all actions that perform I/O should+-- be assumed to throw an @HttpException@ in the event of some problem, and all+-- pure functions will be total. For example, @withResponse@, @httpLbs@, and+-- @brRead@ can all throw exceptions. Functions like @responseStatus@ and+-- @applyBasicAuth@ are guaranteed to be total (or there\'s a bug in the+-- library).+--+-- One thing to be cautioned about: the type of @parseUrl@ allows it to work in+-- different monads. If used in the @IO@ monad, it will throw an exception in+-- the case of an invalid URI. In addition, if you leverage the @IsString@+-- instance of the @Request@ value via @OverloadedStrings@, an invalid URI will+-- result in a partial value. Caveat emptor!+module Network.HTTP.Client+ ( -- * Performing requests+ withResponse+ , httpLbs+ , responseOpen+ , responseClose+ -- * Connection manager+ , Manager+ , newManager+ , closeManager+ -- ** Connection manager settings+ , ManagerSettings+ , defaultManagerSettings+ , managerConnCount+ , managerRawConnection+ , managerTlsConnection+ , managerResponseTimeout+ , managerRetryableException+ , managerWrapIOException+ -- * Request+ , parseUrl+ , applyBasicAuth+ , urlEncodedBody+ , getUri+ -- ** Request type and fields+ , Request+ , method+ , secure+ , host+ , port+ , path+ , queryString+ , requestHeaders+ , requestBody+ , proxy+ , decompress+ , redirectCount+ , checkStatus+ , responseTimeout+ , cookieJar+ -- ** Request body+ , RequestBody (..)+ , Popper+ , NeedsPopper+ , GivesPopper+ -- * Response+ , Response+ , responseStatus+ , responseVersion+ , responseHeaders+ , responseBody+ , responseCookieJar+ -- ** Response body+ , BodyReader+ , brRead+ , brConsume+ -- * Misc+ , HttpException (..)+ , Cookie (..)+ , CookieJar+ , Proxy (..)+ -- * Cookies+ , module Network.HTTP.Client.Cookies+ ) where++import Network.HTTP.Client.Body+import Network.HTTP.Client.Cookies+import Network.HTTP.Client.Core+import Network.HTTP.Client.Manager+import Network.HTTP.Client.Request+import Network.HTTP.Client.Response+import Network.HTTP.Client.Types
+ Network/HTTP/Client/Body.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.HTTP.Client.Body+ ( makeChunkedReader+ , makeLengthReader+ , makeGzipReader+ , makeUnlimitedReader+ , brConsume+ , brEmpty+ , brAddCleanup+ , brReadSome+ ) where++import Network.HTTP.Client.Connection+import Network.HTTP.Client.Types+import Control.Exception (throwIO, assert)+import Data.ByteString (ByteString, empty, uncons)+import Data.IORef+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Control.Monad (unless, when)+import qualified Codec.Zlib as Z++brReadSome :: BodyReader -> Int -> IO L.ByteString+brReadSome BodyReader {..} =+ loop id+ where+ loop front rem+ | rem <= 0 = return $ L.fromChunks $ front []+ | otherwise = do+ bs <- brRead+ if S.null bs+ then return $ L.fromChunks $ front []+ else loop (front . (bs:)) (rem - S.length bs)++brEmpty :: BodyReader+brEmpty = BodyReader+ { brRead = return S.empty+ , brComplete = return True+ }++brAddCleanup :: IO () -> BodyReader -> BodyReader+brAddCleanup cleanup br = BodyReader+ { brRead = do+ bs <- brRead br+ when (S.null bs) cleanup+ return bs+ , brComplete = brComplete br+ }++-- | Strictly consume all remaining chunks of data from the stream.+--+-- Since 0.1.0+brConsume :: BodyReader -> IO [S.ByteString]+brConsume f =+ go id+ where+ go front = do+ x <- brRead f+ if S.null x+ then return $ front []+ else go (front . (x:))++makeGzipReader :: BodyReader -> IO BodyReader+makeGzipReader br = do+ inf <- Z.initInflate $ Z.WindowBits 31+ istate <- newIORef Nothing+ let goPopper popper = do+ mbs <- popper+ case mbs of+ Just bs -> do+ writeIORef istate $ Just popper+ return bs+ Nothing -> do+ bs <- Z.flushInflate inf+ if S.null bs+ then start+ else do+ writeIORef istate Nothing+ return bs+ start = do+ bs <- brRead br+ if S.null bs+ then return S.empty+ else do+ popper <- Z.feedInflate inf bs+ goPopper popper+ return BodyReader+ { brRead = do+ state <- readIORef istate+ case state of+ Nothing -> start+ Just popper -> goPopper popper+ , brComplete = brComplete br+ }++makeUnlimitedReader :: Connection -> IO BodyReader+makeUnlimitedReader Connection {..} = do+ icomplete <- newIORef False+ return $! BodyReader+ { brRead = do+ bs <- connectionRead+ when (S.null bs) $ writeIORef icomplete True+ return bs+ , brComplete = readIORef icomplete+ }++makeLengthReader :: Int -> Connection -> IO BodyReader+makeLengthReader count0 Connection {..} = do+ icount <- newIORef count0+ return $! BodyReader+ { brRead = do+ count <- readIORef icount+ if count <= 0+ then return empty+ else do+ bs <- connectionRead+ when (S.null bs) $ throwIO $ ResponseBodyTooShort (fromIntegral count0) (fromIntegral $ count0 - count)+ case compare count $ S.length bs of+ LT -> do+ let (x, y) = S.splitAt count bs+ connectionUnread y+ writeIORef icount (-1)+ return x+ EQ -> do+ writeIORef icount (-1)+ return bs+ GT -> do+ writeIORef icount (count - S.length bs)+ return bs+ , brComplete = fmap (== -1) $ readIORef icount+ }++makeChunkedReader :: Bool -- ^ send headers+ -> Connection+ -> IO BodyReader+makeChunkedReader sendHeaders conn@Connection {..} = do+ icount <- newIORef 0+ return $! BodyReader+ { brRead = go icount+ , brComplete = do+ count <- readIORef icount+ return $! count == -1+ }+ where+ go icount = do+ count0 <- readIORef icount+ count <-+ if count0 == 0+ then readHeader+ else return count0+ if count <= 0+ then do+ writeIORef icount (-1)+ return empty+ else do+ (bs, count') <- sendChunk count+ writeIORef icount count'+ return bs++ sendChunk 0 = return (empty, 0)+ sendChunk remainder = do+ bs <- connectionRead+ when (S.null bs) $ throwIO InvalidChunkHeaders+ case compare remainder $ S.length bs of+ LT -> do+ let (x, y) = S.splitAt remainder bs+ assert (not $ S.null y) $ connectionUnread y+ requireNewline+ return (x, 0)+ EQ -> do+ requireNewline+ return (bs, 0)+ GT -> return (bs, remainder - S.length bs)++ requireNewline = do+ bs <- connectionReadLine conn+ unless (S.null bs) $ throwIO InvalidChunkHeaders++ readHeader = do+ bs <- connectionReadLine conn+ case parseHex bs of+ Nothing -> throwIO InvalidChunkHeaders+ Just hex -> return hex++ parseHex bs0 =+ case uncons bs0 of+ Just (w0, bs')+ | Just i0 <- toI w0 -> Just $ parseHex' i0 bs'+ _ -> Nothing+ parseHex' i bs =+ case uncons bs of+ Just (w, bs)+ | Just i' <- toI w -> parseHex' (i * 16 + i') bs+ _ -> i++ toI w+ | 48 <= w && w <= 57 = Just $ fromIntegral w - 48+ | 65 <= w && w <= 70 = Just $ fromIntegral w - 55+ | 97 <= w && w <= 102 = Just $ fromIntegral w - 87+ | otherwise = Nothing
+ Network/HTTP/Client/Connection.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+module Network.HTTP.Client.Connection+ ( connectionReadLine+ , connectionReadLineWith+ , dummyConnection+ , openSocketConnection+ , makeConnection+ ) where++import Data.ByteString (ByteString, empty)+import Data.IORef+import Control.Monad+import Control.Exception (throwIO)+import Network.HTTP.Client.Types+import Network.Socket (Socket, sClose, HostAddress)+import qualified Network.Socket as NS+import Network.Socket.ByteString (sendAll, recv)+import qualified Control.Exception as E+import qualified Data.ByteString as S+import Data.Word (Word8)++connectionReadLine :: Connection -> IO ByteString+connectionReadLine conn = do+ bs <- connectionRead conn+ when (S.null bs) $ throwIO IncompleteHeaders+ connectionReadLineWith conn bs++connectionReadLineWith :: Connection -> ByteString -> IO ByteString+connectionReadLineWith conn bs0 =+ go bs0 id 0+ where+ go bs front total =+ case S.breakByte charLF bs of+ (_, "") -> do+ let total' = total + S.length bs+ when (total' > 1024) $ throwIO OverlongHeaders+ bs' <- connectionRead conn+ when (S.null bs') $ throwIO IncompleteHeaders+ go bs' (front . (bs:)) total'+ (x, S.drop 1 -> y) -> do+ unless (S.null y) $! connectionUnread conn y+ return $! killCR $! S.concat $! front [x]++charLF, charCR :: Word8+charLF = 10+charCR = 13++killCR :: ByteString -> ByteString+killCR bs+ | S.null bs = bs+ | S.last bs == charCR = S.init bs+ | otherwise = bs+++-- | For testing+dummyConnection :: [ByteString] -- ^ input+ -> IO (Connection, IO [ByteString], IO [ByteString]) -- ^ conn, output, input+dummyConnection input0 = do+ iinput <- newIORef input0+ ioutput <- newIORef []+ return (Connection+ { connectionRead = atomicModifyIORef iinput $ \input ->+ case input of+ [] -> ([], empty)+ x:xs -> (xs, x)+ , connectionUnread = \x -> atomicModifyIORef iinput $ \input -> (x:input, ())+ , connectionWrite = \x -> atomicModifyIORef ioutput $ \output -> (output ++ [x], ())+ , connectionClose = return ()+ }, atomicModifyIORef ioutput $ \output -> ([], output), readIORef iinput)++makeConnection :: IO ByteString -- ^ read+ -> (ByteString -> IO ()) -- ^ write+ -> IO () -- ^ close+ -> IO Connection+makeConnection r w c = do+ istack <- newIORef []+ _ <- mkWeakIORef istack c+ return $! Connection+ { connectionRead = join $ atomicModifyIORef istack $ \stack ->+ case stack of+ x:xs -> (xs, return x)+ [] -> ([], r)+ , connectionUnread = \x -> atomicModifyIORef istack $ \stack -> (x:stack, ())+ , connectionWrite = w+ , connectionClose = c+ }++socketConnection :: Socket -> IO Connection+socketConnection socket = makeConnection+ (recv socket 4096)+ (sendAll socket)+ (sClose socket)++openSocketConnection :: Maybe HostAddress+ -> String -- ^ host+ -> Int -- ^ port+ -> IO Connection+openSocketConnection hostAddress host port = do+ let hints = NS.defaultHints {+ NS.addrFlags = [NS.AI_ADDRCONFIG]+ , NS.addrSocketType = NS.Stream+ }+ addrs <- case hostAddress of+ Nothing ->+ NS.getAddrInfo (Just hints) (Just host) (Just $ show port)+ Just ha ->+ return+ [NS.AddrInfo+ { NS.addrFlags = []+ , NS.addrFamily = NS.AF_INET+ , NS.addrSocketType = NS.Stream+ , NS.addrProtocol = 6 -- tcp+ , NS.addrAddress = NS.SockAddrInet (toEnum port) ha+ , NS.addrCanonName = Nothing+ }]++ firstSuccessful addrs $ \addr ->+ E.bracketOnError+ (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)+ (NS.addrProtocol addr))+ (NS.sClose)+ (\sock -> do+ NS.setSocketOption sock NS.NoDelay 1+ NS.connect sock (NS.addrAddress addr)+ socketConnection sock)++firstSuccessful :: [NS.AddrInfo] -> (NS.AddrInfo -> IO a) -> IO a+firstSuccessful [] _ = error "getAddrInfo returned empty list"+firstSuccessful (a:as) cb =+ cb a `E.catch` \(e :: E.IOException) ->+ case as of+ [] -> E.throwIO e+ _ -> firstSuccessful as cb
+ Network/HTTP/Client/Cookies.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library.+module Network.HTTP.Client.Cookies+ ( updateCookieJar+ , receiveSetCookie+ , generateCookie+ , insertCheckedCookie+ , insertCookiesIntoRequest+ , computeCookieString+ , evictExpiredCookies+ , createCookieJar+ , destroyCookieJar+ , pathMatches+ , removeExistingCookieFromCookieJar+ , domainMatches+ , isIpAddress+ , defaultPath+ ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as S8+import Data.Maybe+import qualified Data.List as L+import Data.Time.Clock+import Data.Time.Calendar+import Web.Cookie+import qualified Data.CaseInsensitive as CI+import Blaze.ByteString.Builder+import qualified Network.PublicSuffixList.Lookup as PSL+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)++import qualified Network.HTTP.Client.Request as Req+import qualified Network.HTTP.Client.Response as Res+import Network.HTTP.Client.Types as Req++slash :: Integral a => a+slash = 47 -- '/'++isIpAddress :: BS.ByteString -> Bool+isIpAddress =+ go 4+ where+ go 0 bs = BS.null bs+ go rest bs =+ case S8.readInt x of+ Just (i, x') | BS.null x' && i >= 0 && i < 256 -> go (rest - 1) y+ _ -> False+ where+ (x, y') = BS.breakByte 46 bs -- period+ y = BS.drop 1 y'++-- | This corresponds to the subcomponent algorithm entitled \"Domain Matching\" detailed+-- in section 5.1.3+domainMatches :: BS.ByteString -> BS.ByteString -> Bool+domainMatches string domainString+ | string == domainString = True+ | BS.length string < BS.length domainString + 1 = False+ | domainString `BS.isSuffixOf` string && BS.singleton (BS.last difference) == "." && not (isIpAddress string) = True+ | otherwise = False+ where difference = BS.take (BS.length string - BS.length domainString) string++-- | This corresponds to the subcomponent algorithm entitled \"Paths\" detailed+-- in section 5.1.4+defaultPath :: Req.Request -> BS.ByteString+defaultPath req+ | BS.null uri_path = "/"+ | BS.singleton (BS.head uri_path) /= "/" = "/"+ | BS.count slash uri_path <= 1 = "/"+ | otherwise = BS.reverse $ BS.tail $ BS.dropWhile (/= slash) $ BS.reverse uri_path+ where uri_path = Req.path req++-- | This corresponds to the subcomponent algorithm entitled \"Path-Match\" detailed+-- in section 5.1.4+pathMatches :: BS.ByteString -> BS.ByteString -> Bool+pathMatches requestPath cookiePath+ | cookiePath == path' = True+ | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.last cookiePath) == "/" = True+ | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.head remainder) == "/" = True+ | otherwise = False+ where remainder = BS.drop (BS.length cookiePath) requestPath+ path' = case S8.uncons requestPath of+ Just ('/', _) -> requestPath+ _ -> '/' `S8.cons` requestPath++createCookieJar :: [Cookie] -> CookieJar+createCookieJar = CJ++destroyCookieJar :: CookieJar -> [Cookie]+destroyCookieJar = expose++insertIntoCookieJar :: Cookie -> CookieJar -> CookieJar+insertIntoCookieJar cookie cookie_jar' = CJ $ cookie : cookie_jar+ where cookie_jar = expose cookie_jar'++removeExistingCookieFromCookieJar :: Cookie -> CookieJar -> (Maybe Cookie, CookieJar)+removeExistingCookieFromCookieJar cookie cookie_jar' = (mc, CJ lc)+ where (mc, lc) = removeExistingCookieFromCookieJarHelper cookie (expose cookie_jar')+ removeExistingCookieFromCookieJarHelper _ [] = (Nothing, [])+ removeExistingCookieFromCookieJarHelper c (c' : cs)+ | c == c' = (Just c', cs)+ | otherwise = (cookie', c' : cookie_jar'')+ where (cookie', cookie_jar'') = removeExistingCookieFromCookieJarHelper c cs++-- | Are we configured to reject cookies for domains such as \"com\"?+rejectPublicSuffixes :: Bool+rejectPublicSuffixes = True++isPublicSuffix :: BS.ByteString -> Bool+isPublicSuffix = PSL.isSuffix . decodeUtf8With lenientDecode++-- | This corresponds to the eviction algorithm described in Section 5.3 \"Storage Model\"+evictExpiredCookies :: CookieJar -- ^ Input cookie jar+ -> UTCTime -- ^ Value that should be used as \"now\"+ -> CookieJar -- ^ Filtered cookie jar+evictExpiredCookies cookie_jar' now = CJ $ filter (\ cookie -> cookie_expiry_time cookie >= now) $ expose cookie_jar'++-- | This applies the 'computeCookieString' to a given Request+insertCookiesIntoRequest :: Req.Request -- ^ The request to insert into+ -> CookieJar -- ^ Current cookie jar+ -> UTCTime -- ^ Value that should be used as \"now\"+ -> (Req.Request, CookieJar) -- ^ (Ouptut request, Updated cookie jar (last-access-time is updated))+insertCookiesIntoRequest request cookie_jar now+ | BS.null cookie_string = (request, cookie_jar')+ | otherwise = (request {Req.requestHeaders = cookie_header : purgedHeaders}, cookie_jar')+ where purgedHeaders = L.deleteBy (\ (a, _) (b, _) -> a == b) (CI.mk $ "Cookie", BS.empty) $ Req.requestHeaders request+ (cookie_string, cookie_jar') = computeCookieString request cookie_jar now True+ cookie_header = (CI.mk $ "Cookie", cookie_string)++-- | This corresponds to the algorithm described in Section 5.4 \"The Cookie Header\"+computeCookieString :: Req.Request -- ^ Input request+ -> CookieJar -- ^ Current cookie jar+ -> UTCTime -- ^ Value that should be used as \"now\"+ -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)+ -> (BS.ByteString, CookieJar) -- ^ (Contents of a \"Cookie\" header, Updated cookie jar (last-access-time is updated))+computeCookieString request cookie_jar now is_http_api = (output_line, cookie_jar')+ where matching_cookie cookie = condition1 && condition2 && condition3 && condition4+ where condition1+ | cookie_host_only cookie = Req.host request == cookie_domain cookie+ | otherwise = domainMatches (Req.host request) (cookie_domain cookie)+ condition2 = pathMatches (Req.path request) (cookie_path cookie)+ condition3+ | not (cookie_secure_only cookie) = True+ | otherwise = Req.secure request+ condition4+ | not (cookie_http_only cookie) = True+ | otherwise = is_http_api+ matching_cookies = filter matching_cookie $ expose cookie_jar+ output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies+ output_line = toByteString $ renderCookies $ output_cookies+ folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of+ (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar'''+ (Nothing, cookie_jar''') -> cookie_jar'''+ cookie_jar' = foldl folding_function cookie_jar matching_cookies++-- | This applies 'receiveSetCookie' to a given Response+updateCookieJar :: Response a -- ^ Response received from server+ -> Request -- ^ Request which generated the response+ -> UTCTime -- ^ Value that should be used as \"now\"+ -> CookieJar -- ^ Current cookie jar+ -> (CookieJar, Response a) -- ^ (Updated cookie jar with cookies from the Response, The response stripped of any \"Set-Cookie\" header)+updateCookieJar response request now cookie_jar = (cookie_jar', response { responseHeaders = other_headers })+ where (set_cookie_headers, other_headers) = L.partition ((== (CI.mk $ "Set-Cookie")) . fst) $ responseHeaders response+ set_cookie_data = map snd set_cookie_headers+ set_cookies = map parseSetCookie set_cookie_data+ cookie_jar' = foldl (\ cj sc -> receiveSetCookie sc request now True cj) cookie_jar set_cookies++-- | This corresponds to the algorithm described in Section 5.3 \"Storage Model\"+-- This function consists of calling 'generateCookie' followed by 'insertCheckedCookie'.+-- Use this function if you plan to do both in a row.+-- 'generateCookie' and 'insertCheckedCookie' are only provided for more fine-grained control.+receiveSetCookie :: SetCookie -- ^ The 'SetCookie' the cookie jar is receiving+ -> Req.Request -- ^ The request that originated the response that yielded the 'SetCookie'+ -> UTCTime -- ^ Value that should be used as \"now\"+ -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)+ -> CookieJar -- ^ Input cookie jar to modify+ -> CookieJar -- ^ Updated cookie jar+receiveSetCookie set_cookie request now is_http_api cookie_jar = case (do+ cookie <- generateCookie set_cookie request now is_http_api+ return $ insertCheckedCookie cookie cookie_jar is_http_api) of+ Just cj -> cj+ Nothing -> cookie_jar++-- | Insert a cookie created by generateCookie into the cookie jar (or not if it shouldn't be allowed in)+insertCheckedCookie :: Cookie -- ^ The 'SetCookie' the cookie jar is receiving+ -> CookieJar -- ^ Input cookie jar to modify+ -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)+ -> CookieJar -- ^ Updated (or not) cookie jar+insertCheckedCookie c cookie_jar is_http_api = case (do+ (cookie_jar', cookie') <- existanceTest c cookie_jar+ return $ insertIntoCookieJar cookie' cookie_jar') of+ Just cj -> cj+ Nothing -> cookie_jar+ where existanceTest cookie cookie_jar' = existanceTestHelper cookie $ removeExistingCookieFromCookieJar cookie cookie_jar'+ existanceTestHelper new_cookie (Just old_cookie, cookie_jar')+ | not is_http_api && cookie_http_only old_cookie = Nothing+ | otherwise = return (cookie_jar', new_cookie {cookie_creation_time = cookie_creation_time old_cookie})+ existanceTestHelper new_cookie (Nothing, cookie_jar') = return (cookie_jar', new_cookie)++-- | Turn a SetCookie into a Cookie, if it is valid+generateCookie :: SetCookie -- ^ The 'SetCookie' we are encountering+ -> Req.Request -- ^ The request that originated the response that yielded the 'SetCookie'+ -> UTCTime -- ^ Value that should be used as \"now\"+ -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)+ -> Maybe Cookie -- ^ The optional output cookie+generateCookie set_cookie request now is_http_api = do+ domain_sanitized <- sanitizeDomain $ step4 (setCookieDomain set_cookie)+ domain_intermediate <- step5 domain_sanitized+ (domain_final, host_only') <- step6 domain_intermediate+ http_only' <- step10+ return $ Cookie { cookie_name = setCookieName set_cookie+ , cookie_value = setCookieValue set_cookie+ , cookie_expiry_time = getExpiryTime (setCookieExpires set_cookie) (setCookieMaxAge set_cookie)+ , cookie_domain = domain_final+ , cookie_path = getPath $ setCookiePath set_cookie+ , cookie_creation_time = now+ , cookie_last_access_time = now+ , cookie_persistent = getPersistent+ , cookie_host_only = host_only'+ , cookie_secure_only = setCookieSecure set_cookie+ , cookie_http_only = http_only'+ }+ where sanitizeDomain domain'+ | has_a_character && BS.singleton (BS.last domain') == "." = Nothing+ | has_a_character && BS.singleton (BS.head domain') == "." = Just $ BS.tail domain'+ | otherwise = Just $ domain'+ where has_a_character = not (BS.null domain')+ step4 (Just set_cookie_domain) = set_cookie_domain+ step4 Nothing = BS.empty+ step5 domain'+ | firstCondition && domain' == (Req.host request) = return BS.empty+ | firstCondition = Nothing+ | otherwise = return domain'+ where firstCondition = rejectPublicSuffixes && has_a_character && isPublicSuffix domain'+ has_a_character = not (BS.null domain')+ step6 domain'+ | firstCondition && not (domainMatches (Req.host request) domain') = Nothing+ | firstCondition = return (domain', False)+ | otherwise = return (Req.host request, True)+ where firstCondition = not $ BS.null domain'+ step10+ | not is_http_api && setCookieHttpOnly set_cookie = Nothing+ | otherwise = return $ setCookieHttpOnly set_cookie+ getExpiryTime :: Maybe UTCTime -> Maybe DiffTime -> UTCTime+ getExpiryTime _ (Just t) = (fromRational $ toRational t) `addUTCTime` now+ getExpiryTime (Just t) Nothing = t+ getExpiryTime Nothing Nothing = UTCTime (365000 `addDays` utctDay now) (secondsToDiffTime 0)+ getPath (Just p) = p+ getPath Nothing = defaultPath request+ getPersistent = isJust (setCookieExpires set_cookie) || isJust (setCookieMaxAge set_cookie)
+ Network/HTTP/Client/Core.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.HTTP.Client.Core+ ( withResponse+ , httpLbs+ , httpRaw+ , responseOpen+ , responseClose+ , applyCheckStatus+ , httpRedirect+ ) where++import Network.HTTP.Types+import Network.HTTP.Client.Manager+import Network.HTTP.Client.Types+import Network.HTTP.Client.Body+import Network.HTTP.Client.Request+import Network.HTTP.Client.Response+import Network.HTTP.Client.Cookies+import Data.Time+import Control.Exception+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import Data.Monoid+import Control.Monad (void)++-- | Perform a @Request@ using a connection acquired from the given @Manager@,+-- and then provide the @Response@ to the given function. This function is+-- fully exception safe, guaranteeing that the response will be closed when the+-- inner function exits. It is defined as:+--+-- > withResponse req man f = bracket (responseOpen req man) responseClose f+--+-- It is recommended that you use this function in place of explicit calls to+-- 'responseOpen' and 'responseClose'.+--+-- You will need to use functions such as 'brRead' to consume the response+-- body.+--+-- Since 0.1.0+withResponse :: Request+ -> Manager+ -> (Response BodyReader -> IO a)+ -> IO a+withResponse req man f = bracket (responseOpen req man) responseClose f++-- | A convenience wrapper around 'withResponse' which reads in the entire+-- response body and immediately closes the connection. Note that this function+-- performs fully strict I\/O, and only uses a lazy ByteString in its response+-- for memory efficiency. If you are anticipating a large response body, you+-- are encouraged to use 'withResponse' and 'brRead' instead.+--+-- Since 0.1.0+httpLbs :: Request -> Manager -> IO (Response L.ByteString)+httpLbs req man = withResponse req man $ \res -> do+ bss <- brConsume $ responseBody res+ return res { responseBody = L.fromChunks bss }++-- | Get a 'Response' without any redirect following.+httpRaw+ :: Request+ -> Manager+ -> IO (Response BodyReader)+httpRaw req' m = do+ (req, cookie_jar') <- case cookieJar req' of+ Just cj -> do+ now <- getCurrentTime+ return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now+ Nothing -> return (req', mempty)+ (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper+ req+ (responseTimeout' req)+ (failedConnectionException req)+ (getConn req m)++ -- Originally, we would only test for exceptions when sending the request,+ -- not on calling @getResponse@. However, some servers seem to close+ -- connections after accepting the request headers, so we need to check for+ -- exceptions in both.+ ex <- try $ do+ requestBuilder req ci++ getResponse connRelease timeout' req ci++ case (ex, isManaged) of+ -- Connection was reused, and might have been closed. Try again+ (Left e, Reused) | mRetryableException m e -> do+ connRelease DontReuse+ responseOpen req m+ -- Not reused, or a non-retry, so this is a real exception+ (Left e, _) -> throwIO e+ -- Everything went ok, so the connection is good. If any exceptions get+ -- thrown in the response body, just throw them as normal.+ (Right res, _) -> case cookieJar req' of+ Just _ -> do+ now' <- getCurrentTime+ let (cookie_jar, _) = updateCookieJar res req now' cookie_jar'+ return $ res {responseCookieJar = cookie_jar}+ Nothing -> return res+ where++ responseTimeout' req+ | rt == useDefaultTimeout = mResponseTimeout m+ | otherwise = rt+ where+ rt = responseTimeout req++-- | The most low-level function for initiating an HTTP request.+--+-- The first argument to this function gives a full specification+-- on the request: the host to connect to, whether to use SSL,+-- headers, etc. Please see 'Request' for full details. The+-- second argument specifies which 'Manager' should be used.+--+-- This function then returns a 'Response' with a+-- 'BodyReader'. The 'Response' contains the status code+-- and headers that were sent back to us, and the+-- 'BodyReader' contains the body of the request. Note+-- that this 'BodyReader' allows you to have fully+-- interleaved IO actions during your HTTP download, making it+-- possible to download very large responses in constant memory.+--+-- An important note: the response body returned by this function represents a+-- live HTTP connection. As such, if you do not use the response body, an open+-- socket will be retained indefinitely. You must be certain to call+-- 'responseClose' on this response to free up resources.+--+-- This function automatically performs any necessary redirects, as specified+-- by the 'redirectCount' setting.+--+-- Since 0.1.0+responseOpen :: Request -> Manager -> IO (Response BodyReader)+responseOpen req0 manager = mWrapIOException manager $ do+ res <-+ if redirectCount req0 == 0+ then httpRaw req0 manager+ else go (redirectCount req0) req0+ maybe (return res) throwIO =<< applyCheckStatus (checkStatus req0) res+ where+ go count req' = httpRedirect+ count+ (\req -> do+ res <- httpRaw req manager+ let mreq = getRedirectedRequest req (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res))+ return (res, mreq))+ req'++-- | Apply 'Request'\'s 'checkStatus' and return resulting exception if any.+applyCheckStatus+ :: (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException)+ -> Response BodyReader+ -> IO (Maybe SomeException)+applyCheckStatus checkStatus' res =+ case checkStatus' (responseStatus res) (responseHeaders res) (responseCookieJar res) of+ Nothing -> return Nothing+ Just exc -> do+ exc' <-+ case fromException exc of+ Just (StatusCodeException s hdrs cookie_jar) -> do+ lbs <- brReadSome (responseBody res) 1024+ return $ toException $ StatusCodeException s (hdrs +++ [("X-Response-Body-Start", toStrict' lbs)]) cookie_jar+ _ -> return exc+ responseClose res+ return (Just exc')+ where+#if MIN_VERSION_bytestring(0,10,0)+ toStrict' = L.toStrict+#else+ toStrict' = S.concat . L.toChunks+#endif++-- | Redirect loop+httpRedirect+ :: Int -- ^ 'redirectCount'+ -> (Request -> IO (Response BodyReader, Maybe Request)) -- ^ function which performs a request and returns a response, and possibly another request if there's a redirect.+ -> Request+ -> IO (Response BodyReader)+httpRedirect count0 http' req0 = go count0 req0 []+ where+ go (-1) _ ress = throwIO . TooManyRedirects =<< mapM lbsResponse ress+ go count req' ress = do+ (res, mreq) <- http' req'+ case mreq of+ Just req -> do+ {- FIXME+ -- Allow the original connection to return to the+ -- connection pool immediately by flushing the body.+ -- If the response body is too large, don't flush, but+ -- instead just close the connection.+ let maxFlush = 1024+ readMay bs =+ case S8.readInt bs of+ Just (i, bs') | S.null bs' -> Just i+ _ -> Nothing+ case lookup "content-length" (responseHeaders res) >>= readMay of+ Just i | i > maxFlush -> return ()+ _ -> void $ brReadSome (responseBody res) maxFlush+ -}+ responseClose res++ -- And now perform the actual redirect+ go (count - 1) req (res:ress)+ Nothing -> return res++-- | Close any open resources associated with the given @Response@. In general,+-- this will either close an active @Connection@ or return it to the @Manager@+-- to be reused.+--+-- Since 0.1.0+responseClose :: Response a -> IO ()+responseClose = runResponseClose . responseClose'
+ Network/HTTP/Client/Headers.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+module Network.HTTP.Client.Headers+ ( parseStatusHeaders+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Exception (throwIO)+import Control.Monad+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.CaseInsensitive as CI+import Network.HTTP.Client.Connection+import Network.HTTP.Client.Types+import Network.HTTP.Types+import Data.Word (Word8)++charLF, charCR, charSpace, charColon, charPeriod :: Word8+charLF = 10+charCR = 13+charSpace = 32+charColon = 58+charPeriod = 46+++parseStatusHeaders :: Connection -> IO StatusHeaders+parseStatusHeaders conn = do+ (status, version) <- getStatusLine+ headers <- parseHeaders 0 id+ return $! StatusHeaders status version headers+ where+ getStatusLine = do+ -- Ensure that there is some data coming in. If not, we want to signal+ -- this as a connection problem and not a protocol problem.+ bs <- connectionRead conn+ when (S.null bs) $ throwIO NoResponseDataReceived++ status@(code, _) <- connectionReadLineWith conn bs >>= parseStatus 3+ if code == status100+ then newline ExpectedBlankAfter100Continue >> getStatusLine+ else return status++ newline exc = do+ line <- connectionReadLine conn+ unless (S.null line) $ throwIO exc++ parseStatus :: Int -> S.ByteString -> IO (Status, HttpVersion)+ parseStatus i bs | S.null bs && i > 0 = connectionReadLine conn >>= parseStatus (i - 1)+ parseStatus _ bs = do+ let (ver, bs2) = S.breakByte charSpace bs+ (code, bs3) = S.breakByte charSpace $ S.dropWhile (== charSpace) bs2+ msg = S.dropWhile (== charSpace) bs3+ case (,) <$> parseVersion ver <*> readInt code of+ Just (ver', code') -> return (Status code' msg, ver')+ Nothing -> throwIO $ InvalidStatusLine bs++ stripPrefixBS x y+ | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y+ | otherwise = Nothing+ parseVersion bs0 = do+ bs1 <- stripPrefixBS "HTTP/" bs0+ let (num1, S.drop 1 -> num2) = S.breakByte charPeriod bs1+ HttpVersion <$> readInt num1 <*> readInt num2++ readInt bs =+ case S8.readInt bs of+ Just (i, "") -> Just i+ _ -> Nothing++ parseHeaders 100 _ = throwIO OverlongHeaders+ parseHeaders count front = do+ line <- connectionReadLine conn+ if S.null line+ then return $ front []+ else do+ header <- parseHeader line+ parseHeaders (count + 1) $ front . (header:)++ parseHeader :: S.ByteString -> IO Header+ parseHeader bs = do+ let (key, bs2) = S.breakByte charColon bs+ when (S.null bs2) $ throwIO $ InvalidHeader bs+ return (CI.mk $! strip key, strip $! S.drop 1 bs2)++ strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace)
+ Network/HTTP/Client/Internal.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS_HADDOCK not-home #-}+-- | Note that this is essentially the \"kitchen sink\" export module,+-- including many functions intended only to be used internally by this+-- package. No API stability is guaranteed for this module. If you see+-- functions here which you believe should be promoted to a stable API, please+-- contact the author.+module Network.HTTP.Client.Internal+ ( -- * Low-level response body handling+ module Network.HTTP.Client.Body+ -- * Raw connection handling+ , module Network.HTTP.Client.Connection+ -- * Cookies+ , module Network.HTTP.Client.Cookies+ -- * Performing requests+ , module Network.HTTP.Client.Core+ -- * Parse response headers+ , module Network.HTTP.Client.Headers+ -- * Request helper functions+ , module Network.HTTP.Client.Request+ -- * Low-level response body handling+ , module Network.HTTP.Client.Response+ -- * Manager+ , module Network.HTTP.Client.Manager+ -- * All types+ , module Network.HTTP.Client.Types+ -- * Various utilities+ , module Network.HTTP.Client.Util+ ) where++import Network.HTTP.Client.Body+import Network.HTTP.Client.Connection+import Network.HTTP.Client.Cookies+import Network.HTTP.Client.Core+import Network.HTTP.Client.Headers+import Network.HTTP.Client.Manager+import Network.HTTP.Client.Request+import Network.HTTP.Client.Response+import Network.HTTP.Client.Types+import Network.HTTP.Client.Util
+ Network/HTTP/Client/Manager.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+module Network.HTTP.Client.Manager+ ( ManagerSettings (..)+ , newManager+ , closeManager+ , getConn+ , failedConnectionException+ , defaultManagerSettings+ ) where++#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif+import Data.Monoid (mappend)+import System.IO (hClose, hFlush, IOMode(..))+import qualified Data.IORef as I+import qualified Data.Map as Map++import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L++import qualified Blaze.ByteString.Builder as Blaze++import Data.Text (Text)+import qualified Data.Text as T++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Exception (mask_, SomeException, catch, throwIO, fromException, mask, IOException, Exception (..), handle)+import Control.Concurrent (forkIO, threadDelay)+import Data.Time (UTCTime (..), Day (..), DiffTime, getCurrentTime, addUTCTime)+import Control.DeepSeq (deepseq)++import qualified Network.Socket as NS++import Data.Default+import Data.Maybe (mapMaybe)+import System.IO (Handle)+import System.Mem.Weak (Weak, deRefWeak)+import Network.HTTP.Client.Types+import Network.HTTP.Client.Connection++-- | Default value for @ManagerSettings@.+--+-- Since 0.1.0+defaultManagerSettings :: ManagerSettings+defaultManagerSettings = ManagerSettings+ { managerConnCount = 10+ , managerRawConnection = return openSocketConnection+ , managerTlsConnection = return $ \_ _ _ -> throwIO TlsNotSupported+ , managerResponseTimeout = Just 5000000+ , managerRetryableException = \e ->+ case fromException e of+ Just (_ :: IOException) -> True+ _ ->+ case fromException e of+ -- Note: Some servers will timeout connections by accepting+ -- the incoming packets for the new request, but closing+ -- the connection as soon as we try to read. To make sure+ -- we open a new connection under these circumstances, we+ -- check for the NoResponseDataReceived exception.+ Just NoResponseDataReceived -> True+ _ -> False+ , managerWrapIOException =+ let wrapper se =+ case fromException se of+ Just e -> toException $ InternalIOException e+ Nothing -> se+ in handle $ throwIO . wrapper+ }++takeSocket :: Manager -> ConnKey -> IO (Maybe Connection)+takeSocket man key =+ I.atomicModifyIORef (mConns man) go+ where+ go Nothing = (Nothing, Nothing)+ go (Just m) =+ case Map.lookup key m of+ Nothing -> (Just m, Nothing)+ Just (One a _) -> (Just $ Map.delete key m, Just a)+ Just (Cons a _ _ rest) -> (Just $ Map.insert key rest m, Just a)++putSocket :: Manager -> ConnKey -> Connection -> IO ()+putSocket man key ci = do+ now <- getCurrentTime+ msock <- I.atomicModifyIORef (mConns man) (go now)+ maybe (return ()) connectionClose msock+ where+ go _ Nothing = (Nothing, Just ci)+ go now (Just m) =+ case Map.lookup key m of+ Nothing -> (Just $ Map.insert key (One ci now) m, Nothing)+ Just l ->+ let (l', mx) = addToList now (mMaxConns man) ci l+ in (Just $ Map.insert key l' m, mx)++-- | Add a new element to the list, up to the given maximum number. If we're+-- already at the maximum, return the new value as leftover.+addToList :: UTCTime -> Int -> a -> NonEmptyList a -> (NonEmptyList a, Maybe a)+addToList _ i x l | i <= 1 = (l, Just x)+addToList now _ x l@One{} = (Cons x 2 now l, Nothing)+addToList now maxCount x l@(Cons _ currCount _ _)+ | maxCount > currCount = (Cons x (currCount + 1) now l, Nothing)+ | otherwise = (l, Just x)++-- | Create a 'Manager'. You may manually call 'closeManager' to shut it down,+-- or allow the @Manager@ to be shut down automatically based on garbage+-- collection.+--+-- Creating a new 'Manager' is a relatively expensive operation, you are+-- advised to share a single 'Manager' between requests instead.+--+-- The first argument to this function is often 'defaultManagerSettings',+-- though add-on libraries may provide a recommended replacement.+--+-- Since 0.1.0+newManager :: ManagerSettings -> IO Manager+newManager ms = do+ rawConnection <- managerRawConnection ms+ tlsConnection <- managerTlsConnection ms+ mapRef <- I.newIORef (Just Map.empty)+ wmapRef <- I.mkWeakIORef mapRef $ closeManager' mapRef+ _ <- forkIO $ reap wmapRef+ let manager = Manager+ { mConns = mapRef+ , mMaxConns = managerConnCount ms+ , mResponseTimeout = managerResponseTimeout ms+ , mRawConnection = rawConnection+ , mTlsConnection = tlsConnection+ , mRetryableException = managerRetryableException ms+ , mWrapIOException = managerWrapIOException ms+ }+ return manager++-- | Collect and destroy any stale connections.+reap :: Weak (I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection))))+ -> IO ()+reap wmapRef =+ mask_ loop+ where+ loop = do+ threadDelay (5 * 1000 * 1000)+ mmapRef <- deRefWeak wmapRef+ case mmapRef of+ Nothing -> return () -- manager is closed+ Just mapRef -> goMapRef mapRef++ goMapRef mapRef = do+ now <- getCurrentTime+ let isNotStale time = 30 `addUTCTime` time >= now+ mtoDestroy <- I.atomicModifyIORef mapRef (findStaleWrap isNotStale)+ case mtoDestroy of+ Nothing -> return () -- manager is closed+ Just toDestroy -> do+ mapM_ safeConnClose toDestroy+ loop+ findStaleWrap _ Nothing = (Nothing, Nothing)+ findStaleWrap isNotStale (Just m) =+ let (x, y) = findStale isNotStale m+ in (Just x, Just y)+ findStale isNotStale =+ findStale' id id . Map.toList+ where+ findStale' destroy keep [] = (Map.fromList $ keep [], destroy [])+ findStale' destroy keep ((connkey, nelist):rest) =+ findStale' destroy' keep' rest+ where+ -- Note: By definition, the timestamps must be in descending order,+ -- so we don't need to traverse the whole list.+ (notStale, stale) = span (isNotStale . fst) $ neToList nelist+ destroy' = destroy . (map snd stale++)+ keep' =+ case neFromList notStale of+ Nothing -> keep+ Just x -> keep . ((connkey, x):)++ flushStaleCerts now =+ Map.fromList . mapMaybe flushStaleCerts' . Map.toList+ where+ flushStaleCerts' (host', inner) =+ case mapMaybe flushStaleCerts'' $ Map.toList inner of+ [] -> Nothing+ pairs ->+ let x = take 10 pairs+ in x `seqPairs` Just (host', Map.fromList x)+ flushStaleCerts'' (certs, expires)+ | expires > now = Just (certs, expires)+ | otherwise = Nothing++ seqPairs :: [(L.ByteString, UTCTime)] -> b -> b+ seqPairs [] b = b+ seqPairs (p:ps) b = p `seqPair` ps `seqPairs` b++ seqPair :: (L.ByteString, UTCTime) -> b -> b+ seqPair (lbs, utc) b = lbs `seqLBS` utc `seqUTC` b++ seqLBS :: L.ByteString -> b -> b+ seqLBS lbs b = L.length lbs `seq` b++ seqUTC :: UTCTime -> b -> b+ seqUTC (UTCTime day dt) b = day `seqDay` dt `seqDT` b++ seqDay :: Day -> b -> b+ seqDay (ModifiedJulianDay i) b = i `deepseq` b++ seqDT :: DiffTime -> b -> b+ seqDT = seq++neToList :: NonEmptyList a -> [(UTCTime, a)]+neToList (One a t) = [(t, a)]+neToList (Cons a _ t nelist) = (t, a) : neToList nelist++neFromList :: [(UTCTime, a)] -> Maybe (NonEmptyList a)+neFromList [] = Nothing+neFromList [(t, a)] = Just (One a t)+neFromList xs =+ Just . snd . go $ xs+ where+ go [] = error "neFromList.go []"+ go [(t, a)] = (2, One a t)+ go ((t, a):rest) =+ let (i, rest') = go rest+ i' = i + 1+ in i' `seq` (i', Cons a i t rest')++-- | Close all connections in a 'Manager'.+--+-- Note that this doesn't affect currently in-flight connections,+-- meaning you can safely use it without hurting any queries you may+-- have concurrently running.+--+-- Since 0.1.0+closeManager :: Manager -> IO ()+closeManager = closeManager' . mConns++closeManager' :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection)))+ -> IO ()+closeManager' connsRef = mask_ $ do+ m <- I.atomicModifyIORef connsRef $ \x -> (Nothing, x)+ mapM_ (nonEmptyMapM_ safeConnClose) $ maybe [] Map.elems m++safeConnClose :: Connection -> IO ()+safeConnClose ci = connectionClose ci `catch` \(_::SomeException) -> return ()++nonEmptyMapM_ :: Monad m => (a -> m ()) -> NonEmptyList a -> m ()+nonEmptyMapM_ f (One x _) = f x+nonEmptyMapM_ f (Cons x _ _ l) = f x >> nonEmptyMapM_ f l++-- | This function needs to acquire a @ConnInfo@- either from the @Manager@ or+-- via I\/O, and register it with the @ResourceT@ so it is guaranteed to be+-- either released or returned to the manager.+getManagedConn+ :: Manager+ -> ConnKey+ -> IO Connection+ -> IO (ConnRelease, Connection, ManagedConn)+-- We want to avoid any holes caused by async exceptions, so let's mask.+getManagedConn man key open = mask $ \restore -> do+ -- Try to take the socket out of the manager.+ mci <- takeSocket man key+ (ci, isManaged) <-+ case mci of+ -- There wasn't a matching connection in the manager, so create a+ -- new one.+ Nothing -> do+ ci <- restore open+ return (ci, Fresh)+ -- Return the existing one+ Just ci -> return (ci, Reused)++ -- When we release this connection, we can either reuse it (put it back in+ -- the manager) or not reuse it (close the socket). We set up a mutable+ -- reference to track what we want to do. By default, we say not to reuse+ -- it, that way if an exception is thrown, the connection won't be reused.+ toReuseRef <- I.newIORef DontReuse++ -- When the connection is explicitly released, we update our toReuseRef to+ -- indicate what action should be taken, and then call release.+ let connRelease Reuse = putSocket man key ci+ connRelease DontReuse = connectionClose ci++ return (connRelease, ci, isManaged)++-- | Create an exception to be thrown if the connection for the given request+-- fails.+failedConnectionException :: Request -> HttpException+failedConnectionException req =+ FailedConnectionException host' port'+ where+ (_, host', port') = getConnDest req++getConnDest :: Request -> (Bool, String, Int)+getConnDest req =+ case proxy req of+ Just p -> (True, S8.unpack (proxyHost p), proxyPort p)+ Nothing -> (False, S8.unpack $ host req, port req)++getConn :: Request+ -> Manager+ -> IO (ConnRelease, Connection, ManagedConn)+getConn req m =+ getManagedConn m (ConnKey connKeyHost connport (secure req)) $+ go connaddr connhost connport+ where+ h = host req+ (useProxy, connhost, connport) = getConnDest req+ (connaddr, connKeyHost) =+ case (hostAddress req, useProxy{-, socksProxy req-}) of+ (Just ha, False{-, Nothing-}) -> (Just ha, HostAddress ha)+ _ -> (Nothing, HostName $ T.pack connhost)+ go =+ case (secure req, useProxy) of+ (False, _) -> mRawConnection m+ (True, False) -> mTlsConnection m+ -- FIXME (True, True) -> getSslProxyConn (checkCerts m h) (clientCertificates req) h (port req)
+ Network/HTTP/Client/Request.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.HTTP.Client.Request+ ( parseUrl+ , setUriRelative+ , getUri+ , setUri+ , browserDecompress+ , alwaysDecompress+ , addProxy+ , applyBasicAuth+ , urlEncodedBody+ , needsGunzip+ , requestBuilder+ , useDefaultTimeout+ ) where++import Data.Maybe (fromMaybe, isJust)+import Data.Monoid (mempty, mappend)+import Data.String (IsString(..))+import Control.Monad (when, unless)+import Numeric (showHex)++import Data.Default (Default (def))++import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteStringIO)+import Blaze.ByteString.Builder.Char8 (fromChar)++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.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI)++import Control.Monad.IO.Class (liftIO)+import Control.Exception (Exception, toException, throw, throwIO)+import Control.Failure (Failure (failure))+import qualified Data.CaseInsensitive as CI+import qualified Data.ByteString.Base64 as B64++import Network.HTTP.Client.Types+import Network.HTTP.Client.Connection++import Network.HTTP.Client.Util (readDec, (<>))+import System.Timeout (timeout)+import Data.Time.Clock++-- | Convert a URL into a 'Request'.+--+-- This defaults some of the values in 'Request', such as setting 'method' to+-- GET and 'requestHeaders' to @[]@.+--+-- Since this function uses 'Failure', the return monad can be anything that is+-- an instance of 'Failure', such as 'IO' or 'Maybe'.+--+-- Since 0.1.0+parseUrl :: Failure HttpException m => String -> m Request+parseUrl s =+ case parseURI (encode s) of+ Just uri -> setUri def uri+ Nothing -> failure $ InvalidUrlException s "Invalid URL"+ where+ encode = escapeURIString isAllowedInURI++-- | Add a 'URI' to the request. If it is absolute (includes a host name), add+-- it as per 'setUri'; if it is relative, merge it with the existing request.+setUriRelative :: Failure HttpException m => Request -> URI -> m Request+setUriRelative req uri =+#if MIN_VERSION_network(2,4,0)+ setUri req $ uri `relativeTo` getUri req+#else+ case uri `relativeTo` getUri req of+ Just uri' -> setUri req uri'+ Nothing -> failure $ InvalidUrlException (show uri) "Invalid URL"+#endif++-- | Extract a 'URI' from the request.+--+-- Since 0.1.0+getUri :: Request -> URI+getUri req = URI+ { uriScheme = if secure req+ then "https:"+ else "http:"+ , uriAuthority = Just URIAuth+ { uriUserInfo = ""+ , uriRegName = S8.unpack $ host req+ , uriPort = ':' : show (port req)+ }+ , uriPath = S8.unpack $ path req+ , uriQuery = S8.unpack $ queryString req+ , uriFragment = ""+ }++-- | Validate a 'URI', then add it to the request.+setUri :: Failure HttpException m => Request -> URI -> m Request+setUri req uri = do+ sec <- parseScheme uri+ auth <- maybe (failUri "URL must be absolute") return $ uriAuthority uri+ if not . null $ uriUserInfo auth+ then failUri "URL auth not supported; use applyBasicAuth instead"+ else return ()+ port' <- parsePort sec auth+ return req+ { host = S8.pack $ uriRegName auth+ , port = port'+ , secure = sec+ , path = S8.pack $+ if null $ uriPath uri+ then "/"+ else uriPath uri+ , queryString = S8.pack $ uriQuery uri+ }+ where+ failUri :: Failure HttpException m => String -> m a+ failUri = failure . InvalidUrlException (show uri)++ parseScheme URI{uriScheme = scheme} =+ case scheme of+ "http:" -> return False+ "https:" -> return True+ _ -> failUri "Invalid scheme"++ parsePort sec URIAuth{uriPort = portStr} =+ case portStr of+ -- If the user specifies a port, then use it+ ':':rest -> maybe+ (failUri "Invalid port")+ return+ (readDec rest)+ -- Otherwise, use the default port+ _ -> case sec of+ False {- HTTP -} -> return 80+ True {- HTTPS -} -> return 443++instance Show Request where+ show x = unlines+ [ "Request {"+ , " host = " ++ show (host x)+ , " port = " ++ show (port x)+ , " secure = " ++ show (secure x)+ , " requestHeaders = " ++ show (requestHeaders x)+ , " path = " ++ show (path x)+ , " queryString = " ++ show (queryString x)+ --, " requestBody = " ++ show (requestBody x)+ , " method = " ++ show (method x)+ , " proxy = " ++ show (proxy x)+ , " rawBody = " ++ show (rawBody x)+ , " redirectCount = " ++ show (redirectCount x)+ , " responseTimeout = " ++ show (responseTimeout x)+ , "}"+ ]++-- | Magic value to be placed in a 'Request' to indicate that we should use the+-- timeout value in the @Manager@.+--+-- Since 1.9.3+useDefaultTimeout :: Maybe Int+useDefaultTimeout = Just (-3425)++instance Default Request where+ def = Request+ { host = "localhost"+ , port = 80+ , secure = False+ , requestHeaders = []+ , path = "/"+ , queryString = S8.empty+ , requestBody = RequestBodyLBS L.empty+ , method = "GET"+ , proxy = Nothing+ , hostAddress = Nothing+ , rawBody = False+ , decompress = browserDecompress+ , redirectCount = 10+ , checkStatus = \s@(W.Status sci _) hs cookie_jar ->+ if 200 <= sci && sci < 300+ then Nothing+ else Just $ toException $ StatusCodeException s hs cookie_jar+ , responseTimeout = useDefaultTimeout+ , getConnectionWrapper = \mtimeout exc f ->+ case mtimeout of+ Nothing -> fmap ((,) Nothing) f+ Just timeout' -> do+ before <- getCurrentTime+ mres <- timeout timeout' f+ case mres of+ Nothing -> throwIO exc+ Just res -> do+ now <- getCurrentTime+ let timeSpentMicro = diffUTCTime now before * 1000000+ remainingTime = round $ fromIntegral timeout' - timeSpentMicro+ if remainingTime <= 0+ then throwIO exc+ else return (Just remainingTime, res)+ , cookieJar = Just def+ }++instance IsString Request where+ fromString s =+ case parseUrl s of+ Left e -> throw (e :: HttpException)+ Right r -> r++-- | Always decompress a compressed stream.+alwaysDecompress :: S.ByteString -> Bool+alwaysDecompress = const True++-- | Decompress a compressed stream unless the content-type is 'application/x-tar'.+browserDecompress :: S.ByteString -> Bool+browserDecompress = (/= "application/x-tar")++-- | Add a Basic Auth header (with the specified user name and password) to the+-- given Request. Ignore error handling:+--+-- > applyBasicAuth "user" "pass" $ fromJust $ parseUrl url+--+-- Since 0.1.0+applyBasicAuth :: S.ByteString -> S.ByteString -> Request -> Request+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 ])+++-- | Add a proxy to the Request so that the Request when executed will use+-- the provided proxy.+--+-- Since 0.1.0+addProxy :: S.ByteString -> Int -> Request -> Request+addProxy hst prt req =+ req { proxy = Just $ Proxy hst prt }++-- | Add url-encoded parameters to the 'Request'.+--+-- This sets a new 'requestBody', adds a content-type request header and+-- changes the 'method' to POST.+--+-- Since 0.1.0+urlEncodedBody :: [(S.ByteString, S.ByteString)] -> Request -> Request+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+ -> [W.Header] -- ^ response headers+ -> Bool+needsGunzip req hs' =+ not (rawBody req)+ && ("content-encoding", "gzip") `elem` hs'+ && decompress req (fromMaybe "" $ lookup "content-type" hs')++requestBuilder :: Request -> Connection -> IO ()+requestBuilder req Connection {..} =+ bodySource+ where+ writeBuilder = toByteStringIO connectionWrite++ (contentLength, bodySource) =+ case requestBody req of+ RequestBodyLBS lbs -> (Just $ L.length lbs, writeBuilder $ builder `mappend` fromLazyByteString lbs)+ RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, writeBuilder $ builder `mappend` fromByteString bs)+ RequestBodyBuilder i b -> (Just $ i, writeBuilder $ builder `mappend` b)+ RequestBodyStream i stream -> (Just i, writeBuilder builder >> writeStream False stream)+ RequestBodyStreamChunked stream -> (Nothing, writeBuilder builder >> writeStream True stream)++ writeStream isChunked withStream =+ withStream loop+ where+ loop stream = do+ bs <- stream+ when isChunked $+ connectionWrite $ S8.pack $ showHex (S.length bs) (if S.null bs then "\r\n\r\n" else "\r\n")+ unless (S.null bs) $ do+ connectionWrite bs+ when isChunked $ connectionWrite "\r\n"+ loop stream+++ hh+ | port req == 80 && not (secure req) = host req+ | port req == 443 && secure req = host req+ | otherwise = host req <> S8.pack (':' : show (port req))++ requestProtocol+ | secure req = fromByteString "https://"+ | otherwise = fromByteString "http://"++ requestHostname+ | isJust (proxy req) = requestProtocol <> fromByteString hh+ | otherwise = mempty++ 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")++ acceptEncodingHeader =+ case lookup "Accept-Encoding" $ requestHeaders req of+ Nothing -> (("Accept-Encoding", "gzip"):)+ Just "" -> filter (\(k, _) -> k /= "Accept-Encoding")+ Just _ -> id++ hostHeader x =+ case lookup "Host" x of+ Nothing -> ("Host", hh) : x+ Just{} -> x++ headerPairs :: W.RequestHeaders+ headerPairs = hostHeader+ $ acceptEncodingHeader+ $ contentLengthHeader contentLength+ $ requestHeaders req++ builder :: Builder+ builder =+ fromByteString (method req)+ <> fromByteString " "+ <> requestHostname+ <> (case S8.uncons $ path req of+ Just ('/', _) -> fromByteString $ path req+ _ -> fromChar '/' <> fromByteString (path req))+ <> (case S8.uncons $ queryString req of+ Nothing -> mempty+ Just ('?', _) -> fromByteString $ queryString req+ _ -> 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"
+ Network/HTTP/Client/Response.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Network.HTTP.Client.Response+ ( getRedirectedRequest+ , getResponse+ , lbsResponse+ ) where++import Control.Arrow (first)+import Control.Monad (liftM)++import Control.Exception (throwIO)+import Control.Monad.IO.Class (MonadIO, liftIO)++import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L++import qualified Data.CaseInsensitive as CI++import Data.Default (def)++import qualified Network.HTTP.Types as W+import Network.URI (parseURIReference)++import Network.HTTP.Client.Types++import Network.HTTP.Client.Manager+import Network.HTTP.Client.Request+import Network.HTTP.Client.Util+import Network.HTTP.Client.Body+import Network.HTTP.Client.Headers+import Network.HTTP.Client.Connection++import System.Timeout (timeout)++-- | If a request is a redirection (status code 3xx) this function will create+-- a new request from the old request, the server headers returned with the+-- redirection, and the redirection code itself. This function returns 'Nothing'+-- if the code is not a 3xx, there is no 'location' header included, or if the+-- redirected response couldn't be parsed with 'parseUrl'.+--+-- If a user of this library wants to know the url chain that results from a+-- specific request, that user has to re-implement the redirect-following logic+-- themselves. An example of that might look like this:+--+-- > myHttp req man = do+-- > (res, redirectRequests) <- (`runStateT` []) $+-- > 'httpRedirect'+-- > 9000+-- > (\req' -> do+-- > res <- http req'{redirectCount=0} man+-- > modify (\rqs -> req' : rqs)+-- > return (res, getRedirectedRequest req' (responseHeaders res) (responseCookieJar res) (W.statusCode (responseStatus res))+-- > )+-- > 'lift'+-- > req+-- > applyCheckStatus (checkStatus req) res+-- > return redirectRequests+getRedirectedRequest :: Request -> W.ResponseHeaders -> CookieJar -> Int -> Maybe Request+getRedirectedRequest req hs cookie_jar code+ | 300 <= code && code < 400 = do+ l' <- lookup "location" hs+ req' <- setUriRelative req =<< parseURIReference (S8.unpack l')+ return $+ if code == 302 || code == 303+ -- According to the spec, this should *only* be for status code+ -- 303. However, almost all clients mistakenly implement it for+ -- 302 as well. So we have to be wrong like everyone else...+ then req'+ { method = "GET"+ , requestBody = RequestBodyBS ""+ , cookieJar = cookie_jar'+ }+ else req' {cookieJar = cookie_jar'}+ | otherwise = Nothing+ where+ cookie_jar' = fmap (const cookie_jar) $ cookieJar req++-- | Convert a 'Response' that has a 'Source' body to one with a lazy+-- 'L.ByteString' body.+lbsResponse :: Response BodyReader -> IO (Response L.ByteString)+lbsResponse res = do+ bss <- brConsume $ responseBody res+ return res+ { responseBody = L.fromChunks bss+ }++getResponse :: ConnRelease+ -> Maybe Int+ -> Request+ -> Connection+ -> IO (Response BodyReader)+getResponse connRelease timeout'' req@(Request {..}) conn = do+ let timeout' =+ case timeout'' of+ Nothing -> id+ Just useconds -> \ma -> do+ x <- timeout useconds ma+ case x of+ Nothing -> liftIO $ throwIO ResponseTimeout+ Just y -> return y+ StatusHeaders s version hs <- timeout' $ parseStatusHeaders conn+ let mcl = lookup "content-length" hs >>= readDec . S8.unpack++ -- should we put this connection back into the connection manager?+ toPut = Just "close" /= lookup "connection" hs && version > W.HttpVersion 1 0+ cleanup bodyConsumed = connRelease $ if toPut && bodyConsumed then Reuse else DontReuse++ body <-+ -- RFC 2616 section 4.4_1 defines responses that must not include a body+ if hasNoBody method (W.statusCode s) || mcl == Just 0+ then do+ cleanup True+ return brEmpty+ else do+ let isChunked = ("transfer-encoding", "chunked") `elem` hs+ body1 <-+ if isChunked+ then makeChunkedReader rawBody conn+ else+ case mcl of+ Just len -> makeLengthReader len conn+ Nothing -> makeUnlimitedReader conn+ body2 <- if needsGunzip req hs+ then makeGzipReader body1+ else return body1+ return $ brAddCleanup (cleanup True) body2++ return Response+ { responseStatus = s+ , responseVersion = version+ , responseHeaders = hs+ , responseBody = body+ , responseCookieJar = def+ , responseClose' = ResponseClose (cleanup False)+ }
+ Network/HTTP/Client/Types.hs view
@@ -0,0 +1,502 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RankNTypes #-}+module Network.HTTP.Client.Types+ ( BodyReader (..)+ , Connection (..)+ , StatusHeaders (..)+ , HttpException (..)+ , Cookie (..)+ , CookieJar (..)+ , Proxy (..)+ , RequestBody (..)+ , Popper+ , NeedsPopper+ , GivesPopper+ , Request (..)+ , ConnReuse (..)+ , ConnRelease+ , ManagedConn (..)+ , Response (..)+ , ResponseClose (..)+ , Manager (..)+ , ManagerSettings (..)+ , NonEmptyList (..)+ , ConnHost (..)+ , ConnKey (..)+ ) where++import qualified Data.Typeable as T (Typeable)+import Network.HTTP.Types+import Control.Exception (Exception, IOException, SomeException)+import Data.Word (Word64)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Blaze.ByteString.Builder (Builder, fromLazyByteString, fromByteString, toLazyByteString)+import Data.Int (Int64)+import Data.Default+import Data.Monoid+import Data.Time (UTCTime)+import qualified Data.List as DL+import Network.Socket (HostAddress)+import Data.IORef+import qualified Network.Socket as NS+import qualified Data.IORef as I+import qualified Data.Map as Map+import Data.Text (Text)++-- | An abstraction for representing an incoming response body coming from the+-- server. Data provided by this abstraction has already been gunzipped and+-- de-chunked, and respects any content-length headers present.+--+-- Since 0.1.0+data BodyReader = BodyReader+ { brRead :: !(IO S.ByteString)+ -- ^ Get a single chunk of data from the response body, or an empty+ -- bytestring if no more data is available.+ --+ -- Since 0.1.0+ , brComplete :: !(IO Bool)+ }++data Connection = Connection+ { connectionRead :: !(IO S.ByteString)+ -- ^ If no more data, return empty.+ , connectionUnread :: !(S.ByteString -> IO ())+ -- ^ Return data to be read next time.+ , connectionWrite :: !(S.ByteString -> IO ())+ -- ^ Send data to server+ , connectionClose :: !(IO ())+ }++data StatusHeaders = StatusHeaders !Status !HttpVersion !RequestHeaders+ deriving (Show, Eq, Ord)++data HttpException = StatusCodeException Status ResponseHeaders CookieJar+ | InvalidUrlException String String+ | TooManyRedirects [Response L.ByteString] -- ^ List of encountered responses containing redirects in reverse chronological order; including last redirect, which triggered the exception and was not followed.+ | UnparseableRedirect (Response L.ByteString) -- ^ Response containing unparseable redirect.+ | TooManyRetries+ | HttpParserException String+ | HandshakeFailed+ | OverlongHeaders+ | ResponseTimeout+ | FailedConnectionException String Int -- ^ host/port+ | ExpectedBlankAfter100Continue+ | InvalidStatusLine S.ByteString+ | InvalidHeader S.ByteString+ | InternalIOException IOException+ | ProxyConnectException S.ByteString Int (Either S.ByteString HttpException) -- ^ host/port+ | NoResponseDataReceived+ | TlsException SomeException+ | TlsNotSupported+ | ResponseBodyTooShort Word64 Word64+ -- ^ Expected size/actual size.+ --+ -- Since 1.9.4+ | InvalidChunkHeaders+ -- ^+ --+ -- Since 1.9.4+ | IncompleteHeaders+ deriving (Show, T.Typeable)+instance Exception HttpException+++-- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\"+data Cookie = Cookie+ { cookie_name :: S.ByteString+ , cookie_value :: S.ByteString+ , cookie_expiry_time :: UTCTime+ , cookie_domain :: S.ByteString+ , cookie_path :: S.ByteString+ , cookie_creation_time :: UTCTime+ , cookie_last_access_time :: UTCTime+ , cookie_persistent :: Bool+ , cookie_host_only :: Bool+ , cookie_secure_only :: Bool+ , cookie_http_only :: Bool+ }+ deriving (Read, Show)++newtype CookieJar = CJ { expose :: [Cookie] }+ deriving (Read, Show)++-- This corresponds to step 11 of the algorithm described in Section 5.3 \"Storage Model\"+instance Eq Cookie where+ (==) a b = name_matches && domain_matches && path_matches+ where name_matches = cookie_name a == cookie_name b+ domain_matches = cookie_domain a == cookie_domain b+ path_matches = cookie_path a == cookie_path b++instance Ord Cookie where+ compare c1 c2+ | S.length (cookie_path c1) > S.length (cookie_path c2) = LT+ | S.length (cookie_path c1) < S.length (cookie_path c2) = GT+ | cookie_creation_time c1 > cookie_creation_time c2 = GT+ | otherwise = LT++instance Default CookieJar where+ def = CJ []++instance Eq CookieJar where+ (==) cj1 cj2 = (DL.sort $ expose cj1) == (DL.sort $ expose cj2)++-- | Since 1.9+instance Monoid CookieJar where+ mempty = def+ (CJ a) `mappend` (CJ b) = CJ (DL.nub $ DL.sortBy compare' $ a `mappend` b)+ where compare' c1 c2 =+ -- inverse so that recent cookies are kept by nub over older+ if cookie_creation_time c1 > cookie_creation_time c2+ then LT+ else GT++-- | Define a HTTP proxy, consisting of a hostname and port number.++data Proxy = Proxy+ { proxyHost :: !S.ByteString -- ^ The host name of the HTTP proxy.+ , proxyPort :: !Int -- ^ The port number of the HTTP proxy.+ }+ deriving (Show, Read, Eq, Ord, T.Typeable)++-- | When using one of the 'RequestBodyStream' \/ 'RequestBodyStreamChunked'+-- constructors, you must ensure that the 'GivesPopper' can be called multiple+-- times. Usually this is not a problem.+--+-- The 'RequestBodyStreamChunked' will send a chunked request body. Note that+-- not all servers support this. Only use 'RequestBodyStreamChunked' if you+-- know the server you're sending to supports chunked request bodies.+--+-- Since 0.1.0+data RequestBody+ = RequestBodyLBS !L.ByteString+ | RequestBodyBS !S.ByteString+ | RequestBodyBuilder !Int64 !Builder+ | RequestBodyStream !Int64 !(GivesPopper ())+ | RequestBodyStreamChunked !(GivesPopper ())+instance Monoid RequestBody where+ mempty = RequestBodyBS S.empty+ mappend x0 y0 =+ case (simplify x0, simplify y0) of+ (Left (i, x), Left (j, y)) -> RequestBodyBuilder (i + j) (x `mappend` y)+ (Left x, Right y) -> combine (builderToStream x) y+ (Right x, Left y) -> combine x (builderToStream y)+ (Right x, Right y) -> combine x y+ where+ combine (Just i, x) (Just j, y) = RequestBodyStream (i + j) (combine' x y)+ combine (_, x) (_, y) = RequestBodyStreamChunked (combine' x y)++ combine' :: GivesPopper () -> GivesPopper () -> GivesPopper ()+ combine' x y f = x $ \x' -> y $ \y' -> combine'' x' y' f++ combine'' :: Popper -> Popper -> NeedsPopper () -> IO ()+ combine'' x y f = do+ istate <- newIORef $ Left (x, y)+ f $ go istate++ go istate = do+ state <- readIORef istate+ case state of+ Left (x, y) -> do+ bs <- x+ if S.null bs+ then do+ writeIORef istate $ Right y+ y+ else return bs+ Right y -> y++simplify :: RequestBody -> Either (Int64, Builder) (Maybe Int64, GivesPopper ())+simplify (RequestBodyLBS lbs) = Left (L.length lbs, fromLazyByteString lbs)+simplify (RequestBodyBS bs) = Left (fromIntegral $ S.length bs, fromByteString bs)+simplify (RequestBodyBuilder len b) = Left (len, b)+simplify (RequestBodyStream i gp) = Right (Just i, gp)+simplify (RequestBodyStreamChunked gp) = Right (Nothing, gp)++builderToStream :: (Int64, Builder) -> (Maybe Int64, GivesPopper ())+builderToStream (len, builder) =+ (Just len, gp)+ where+ gp np = do+ ibss <- newIORef $ L.toChunks $ toLazyByteString builder+ np $ do+ bss <- readIORef ibss+ case bss of+ [] -> return S.empty+ bs:bss' -> do+ writeIORef ibss bss'+ return bs++-- | A function which generates successive chunks of a request body, provider a+-- single empty bytestring when no more data is available.+--+-- Since 0.1.0+type Popper = IO S.ByteString++-- | A function which must be provided with a 'Popper'.+--+-- Since 0.1.0+type NeedsPopper a = Popper -> IO a++-- | A function which will provide a 'Popper' to a 'NeedsPopper'. This+-- seemingly convoluted structure allows for creation of request bodies which+-- allocate scarce resources in an exception safe manner.+--+-- Since 0.1.0+type GivesPopper a = NeedsPopper a -> IO a++-- | All information on how to connect to a host and what should be sent in the+-- HTTP request.+--+-- If you simply wish to download from a URL, see 'parseUrl'.+--+-- The constructor for this data type is not exposed. Instead, you should use+-- either the 'def' method to retrieve a default instance, or 'parseUrl' to+-- construct from a URL, and then use the records below to make modifications.+-- This approach allows http-client to add configuration options without+-- breaking backwards compatibility.+--+-- For example, to construct a POST request, you could do something like:+--+-- > initReq <- parseUrl "http://www.example.com/path"+-- > let req = initReq+-- > { method = "POST"+-- > }+--+-- For more information, please see+-- <http://www.yesodweb.com/book/settings-types>.+--+-- Since 0.1.0+data Request = Request+ { method :: Method+ -- ^ HTTP request method, eg GET, POST.+ --+ -- Since 0.1.0+ , secure :: Bool+ -- ^ Whether to use HTTPS (ie, SSL).+ --+ -- Since 0.1.0+ , host :: S.ByteString+ -- ^ Requested host name, used for both the IP address to connect to and+ -- the @host@ request header.+ --+ -- Since 0.1.0+ , port :: Int+ -- ^ The port to connect to. Also used for generating the @host@ request header.+ --+ -- Since 0.1.0+ , path :: S.ByteString+ -- ^ Everything from the host to the query string.+ --+ -- Since 0.1.0+ , queryString :: S.ByteString+ -- ^ Query string appended to the path.+ --+ -- Since 0.1.0+ , requestHeaders :: RequestHeaders+ -- ^ Custom HTTP request headers+ --+ -- The Content-Length and Transfer-Encoding headers are set automatically+ -- by this module, and shall not be added to @requestHeaders@.+ --+ -- If not provided by the user, @Host@ will automatically be set based on+ -- the @host@ and @port@ fields.+ --+ -- Moreover, the Accept-Encoding header is set implicitly to gzip for+ -- convenience by default. This behaviour can be overridden if needed, by+ -- setting the header explicitly to a different value. In order to omit the+ -- Accept-Header altogether, set it to the empty string \"\". If you need an+ -- empty Accept-Header (i.e. requesting the identity encoding), set it to a+ -- non-empty white-space string, e.g. \" \". See RFC 2616 section 14.3 for+ -- details about the semantics of the Accept-Header field. If you request a+ -- content-encoding not supported by this module, you will have to decode+ -- it yourself (see also the 'decompress' field).+ --+ -- Note: Multiple header fields with the same field-name will result in+ -- multiple header fields being sent and therefore it\'s the responsibility+ -- of the client code to ensure that the rules from RFC 2616 section 4.2+ -- are honoured.+ --+ -- Since 0.1.0+ , requestBody :: RequestBody+ -- ^ Request body to be sent to the server.+ --+ -- Since 0.1.0+ , proxy :: Maybe Proxy+ -- ^ Optional HTTP proxy.+ --+ -- Since 0.1.0+ , hostAddress :: Maybe HostAddress+ -- ^ Optional resolved host address. May not be used by all backends.+ --+ -- Since 0.1.0+ , rawBody :: Bool+ -- ^ If @True@, a chunked and\/or gzipped body will not be+ -- decoded. Use with caution.+ --+ -- Since 0.1.0+ , decompress :: S.ByteString -> Bool+ -- ^ Predicate to specify whether gzipped data should be+ -- decompressed on the fly (see 'alwaysDecompress' and+ -- 'browserDecompress'). Argument is the mime type.+ -- Default: browserDecompress.+ --+ -- Since 0.1.0+ , redirectCount :: Int+ -- ^ How many redirects to follow when getting a resource. 0 means follow+ -- no redirects. Default value: 10.+ --+ -- Since 0.1.0+ , checkStatus :: Status -> ResponseHeaders -> CookieJar -> Maybe SomeException+ -- ^ Check the status code. Note that this will run after all redirects are+ -- performed. Default: return a @StatusCodeException@ on non-2XX responses.+ --+ -- Since 0.1.0+ , responseTimeout :: Maybe Int+ -- ^ Number of microseconds to wait for a response. If @Nothing@, will wait+ -- indefinitely. Default: 5 seconds.+ --+ -- Since 0.1.0+ , getConnectionWrapper :: Maybe Int+ -> HttpException+ -> IO (ConnRelease, Connection, ManagedConn)+ -> IO (Maybe Int, (ConnRelease, Connection, ManagedConn))+ -- ^ Wraps the calls for getting new connections. This can be useful for+ -- instituting some kind of timeouts. The first argument is the value of+ -- @responseTimeout@. Second argument is the exception to be thrown on+ -- failure.+ --+ -- Default: If @responseTimeout@ is @Nothing@, does nothing. Otherwise,+ -- institutes timeout, and returns remaining time for @responseTimeout@.+ --+ -- Since 0.1.0+ , cookieJar :: Maybe CookieJar+ -- ^ A user-defined cookie jar.+ -- If 'Nothing', no cookie handling will take place, \"Cookie\" headers+ -- in 'requestHeaders' will be sent raw, and 'responseCookieJar' will be+ -- empty.+ --+ -- Since 0.1.0+ }++data ConnReuse = Reuse | DontReuse++type ConnRelease = ConnReuse -> IO ()++data ManagedConn = Fresh | Reused++-- | A simple representation of the HTTP response.+--+-- Since 0.1.0+data Response body = Response+ { responseStatus :: !Status+ -- ^ Status code of the response.+ --+ -- Since 0.1.0+ , responseVersion :: !HttpVersion+ -- ^ HTTP version used by the server.+ --+ -- Since 0.1.0+ , responseHeaders :: !ResponseHeaders+ -- ^ Response headers sent by the server.+ --+ -- Since 0.1.0+ , responseBody :: !body+ -- ^ Response body sent by the server.+ --+ -- Since 0.1.0+ , responseCookieJar :: !CookieJar+ -- ^ Cookies set on the client after interacting with the server. If+ -- cookies have been disabled by setting 'cookieJar' to @Nothing@, then+ -- this will always be empty.+ --+ -- Since 0.1.0+ , responseClose' :: !ResponseClose+ -- ^ Releases any resource held by this response. If the response body+ -- has not been fully read yet, doing so after this call will likely+ -- be impossible.+ --+ -- Since 0.1.0+ }+ deriving (Show, Eq, T.Typeable, Functor)++newtype ResponseClose = ResponseClose { runResponseClose :: IO () }+ deriving T.Typeable+instance Show ResponseClose where+ show _ = "ResponseClose"+instance Eq ResponseClose where+ _ == _ = True++-- | Settings for a @Manager@. Please use the 'defaultManagerSettings' function and then modify+-- individual settings. For more information, see <http://www.yesodweb.com/book/settings-types>.+--+-- Since 0.1.0+data ManagerSettings = ManagerSettings+ { managerConnCount :: !Int+ -- ^ Number of connections to a single host to keep alive. Default: 10.+ --+ -- Since 0.1.0+ , managerRawConnection :: !(IO (Maybe NS.HostAddress -> String -> Int -> IO Connection))+ -- ^ Create an insecure connection.+ --+ -- Since 0.1.0+ , managerTlsConnection :: !(IO (Maybe NS.HostAddress -> String -> Int -> IO Connection))+ -- ^ Create a TLS connection. Default behavior: throw an exception that TLS is not supported.+ --+ -- Since 0.1.0+ , managerResponseTimeout :: !(Maybe Int)+ -- ^ Default timeout (in microseconds) to be applied to requests which do+ -- not provide a timeout value.+ --+ -- Default is 5 seconds+ --+ -- Since 0.1.0+ , managerRetryableException :: !(SomeException -> Bool)+ -- ^ Exceptions for which we should retry our request if we were reusing an+ -- already open connection. In the case of IOExceptions, for example, we+ -- assume that the connection was closed on the server and therefore open a+ -- new one.+ --+ -- Since 0.1.0+ , managerWrapIOException :: !(forall a. IO a -> IO a)+ -- ^ Action wrapped around all attempted @Request@s, usually used to wrap+ -- up exceptions in library-specific types.+ --+ -- Default: wrap all @IOException@s in the @InternalIOException@ constructor.+ --+ -- Since 0.1.0+ }++-- | Keeps track of open connections for keep-alive.+--+-- If possible, you should share a single 'Manager' between multiple threads and requests.+--+-- Since 0.1.0+data Manager = Manager+ { mConns :: !(I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection))))+ -- ^ @Nothing@ indicates that the manager is closed.+ , mMaxConns :: !Int+ -- ^ This is a per-@ConnKey@ value.+ , mResponseTimeout :: !(Maybe Int)+ -- ^ Copied from 'managerResponseTimeout'+ , mRawConnection :: !(Maybe NS.HostAddress -> String -> Int -> IO Connection)+ , mTlsConnection :: !(Maybe NS.HostAddress -> String -> Int -> IO Connection)+ , mRetryableException :: !(SomeException -> Bool)+ , mWrapIOException :: !(forall a. IO a -> IO a)+ }++data NonEmptyList a =+ One !a !UTCTime |+ Cons !a !Int !UTCTime !(NonEmptyList a)++-- | Hostname or resolved host address.+data ConnHost =+ HostName !Text |+ HostAddress !NS.HostAddress+ deriving (Eq, Show, Ord)++-- | @ConnKey@ consists of a hostname, a port and a @Bool@+-- specifying whether to use SSL.+data ConnKey = ConnKey !ConnHost !Int !Bool+ deriving (Eq, Show, Ord)
+ Network/HTTP/Client/Util.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Network.HTTP.Client.Util+ ( hGetSome+ , (<>)+ , readDec+ , hasNoBody+ , fromStrict+ ) where++import Data.Monoid (Monoid, mappend)++import qualified Data.ByteString.Char8 as S8+#if MIN_VERSION_bytestring(0,10,0)+import Data.ByteString.Lazy (fromStrict)+#else+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as S+#endif++import qualified Data.Text as T+import qualified Data.Text.Read++#if MIN_VERSION_base(4,3,0)+import Data.ByteString (hGetSome)+#else+import GHC.IO.Handle.Types+import System.IO (hWaitForInput, hIsEOF)+import System.IO.Error (mkIOError, illegalOperationErrorType)++-- | Like 'hGet', except that a shorter 'ByteString' may be returned+-- if there are not enough bytes immediately available to satisfy the+-- whole request. 'hGetSome' only blocks if there is no data+-- available, and EOF has not yet been reached.+hGetSome :: Handle -> Int -> IO S.ByteString+hGetSome hh i+ | i > 0 = let+ loop = do+ s <- S.hGetNonBlocking hh i+ if not (S.null s)+ then return s+ else do eof <- hIsEOF hh+ if eof then return s+ else hWaitForInput hh (-1) >> loop+ -- for this to work correctly, the+ -- Handle should be in binary mode+ -- (see GHC ticket #3808)+ in loop+ | i == 0 = return S.empty+ | otherwise = illegalBufferSize hh "hGetSome" i++illegalBufferSize :: Handle -> String -> Int -> IO a+illegalBufferSize handle fn sz =+ ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing)+ --TODO: System.IO uses InvalidArgument here, but it's not exported :-(+ where+ msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz []+#endif++infixr 5 <>+(<>) :: Monoid m => m -> m -> m+(<>) = mappend++readDec :: Integral i => String -> Maybe i+readDec s =+ case Data.Text.Read.decimal $ T.pack s of+ Right (i, t)+ | T.null t -> Just i+ _ -> Nothing++hasNoBody :: S8.ByteString -- ^ request method+ -> Int -- ^ status code+ -> Bool+hasNoBody "HEAD" _ = True+hasNoBody _ 204 = True+hasNoBody _ 304 = True+hasNoBody _ i = 100 <= i && i < 200++#if !MIN_VERSION_bytestring(0,10,0)+{-# INLINE fromStrict #-}+fromStrict :: S.ByteString -> L.ByteString+fromStrict x = L.fromChunks [x]+#endif
http-client.cabal view
@@ -1,9 +1,7 @@ name: http-client-version: 0.1.0.0+version: 0.2.0.0 synopsis: An HTTP client engine, intended as a base layer for more user-friendly packages. description: This codebase has been refactored from http-conduit.- .- Note that, in its current state, this library is a preview release. It passes tests and seems to work correctly, but has not received a huge level of battle testing yet. I would recommend sticking with http-conduit for production usage until this library has been more thoroughly tested. homepage: https://github.com/snoyberg/http-client license: MIT license-file: LICENSE@@ -16,33 +14,34 @@ library exposed-modules: Network.HTTP.Client- Network.HTTP.Client.Util- Network.HTTP.Client.Types- Network.HTTP.Client.Body- Network.HTTP.Client.Manager+ Network.HTTP.Client.Internal+ other-modules: Network.HTTP.Client.Body+ Network.HTTP.Client.Connection+ Network.HTTP.Client.Cookies+ Network.HTTP.Client.Core Network.HTTP.Client.Headers+ Network.HTTP.Client.Manager Network.HTTP.Client.Request Network.HTTP.Client.Response- Network.HTTP.Client.Connection- Network.HTTP.Client.Cookies- build-depends: base >=4.5 && < 5- , bytestring >=0.9- , text >=0.11- , http-types >=0.8- , blaze-builder >=0.3+ Network.HTTP.Client.Types+ Network.HTTP.Client.Util+ build-depends: base >= 4.5 && < 5+ , bytestring >= 0.9+ , text >= 0.11+ , http-types >= 0.8+ , blaze-builder >= 0.3 , data-default- , time >=1.2- , network >=2.3- , zlib-bindings >=0.1 && <0.2+ , time >= 1.2+ , network >= 2.3+ , zlib-bindings >= 0.1 && <0.2 , containers , transformers- , deepseq >=1.3 && <1.4- , case-insensitive >=1.1 && <1.2- , failure >=0.2 && <0.3- , base64-bytestring >=1.0 && <1.1+ , deepseq >= 1.3 && <1.4+ , case-insensitive >= 1.1 && <1.2+ , failure >= 0.2 && <0.3+ , base64-bytestring >= 1.0 && <1.1 , publicsuffixlist , cookie- hs-source-dirs: src default-language: Haskell2010 test-suite spec
− src/Network/HTTP/Client.hs
@@ -1,199 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Network.HTTP.Client where--import Network.HTTP.Types-import Network.HTTP.Client.Manager-import Network.HTTP.Client.Types-import Network.HTTP.Client.Body-import Network.HTTP.Client.Request-import Network.HTTP.Client.Response-import Network.HTTP.Client.Cookies-import Data.Time-import Control.Exception-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L-import Data.Monoid-import Control.Monad (void)--withResponse :: Request- -> Manager- -> (Response BodyReader -> IO a)- -> IO a-withResponse req man f = bracket (responseOpen req man) responseClose f--httpLbs :: Request -> Manager -> IO (Response L.ByteString)-httpLbs req man = withResponse req man $ \res -> do- bss <- brConsume $ responseBody res- return res { responseBody = L.fromChunks bss }---- | Get a 'Response' without any redirect following.-httpRaw- :: Request- -> Manager- -> IO (Response BodyReader)-httpRaw req' m = do- (req, cookie_jar') <- case cookieJar req' of- Just cj -> do- now <- getCurrentTime- return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now- Nothing -> return (req', mempty)- (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper- req- (responseTimeout' req)- (failedConnectionException req)- (getConn req m)-- -- Originally, we would only test for exceptions when sending the request,- -- not on calling @getResponse@. However, some servers seem to close- -- connections after accepting the request headers, so we need to check for- -- exceptions in both.- ex <- try $ do- requestBuilder req ci-- getResponse connRelease timeout' req ci-- case (ex, isManaged) of- -- Connection was reused, and might have been closed. Try again- (Left e, Reused) | mRetryableException m e -> do- connRelease DontReuse- responseOpen req m- -- Not reused, or a non-retry, so this is a real exception- (Left e, _) -> throwIO e- -- Everything went ok, so the connection is good. If any exceptions get- -- thrown in the response body, just throw them as normal.- (Right res, _) -> case cookieJar req' of- Just _ -> do- now' <- getCurrentTime- let (cookie_jar, _) = updateCookieJar res req now' cookie_jar'- return $ res {responseCookieJar = cookie_jar}- Nothing -> return res- where-- responseTimeout' req- | rt == useDefaultTimeout = mResponseTimeout m- | otherwise = rt- where- rt = responseTimeout req---- | The most low-level function for initiating an HTTP request.------ The first argument to this function gives a full specification--- on the request: the host to connect to, whether to use SSL,--- headers, etc. Please see 'Request' for full details. The--- second argument specifies which 'Manager' should be used.------ This function then returns a 'Response' with a--- 'C.Source'. The 'Response' contains the status code--- and headers that were sent back to us, and the--- 'C.Source' contains the body of the request. Note--- that this 'C.Source' allows you to have fully--- interleaved IO actions during your HTTP download, making it--- possible to download very large responses in constant memory.--- You may also directly connect the returned 'C.Source'--- into a 'C.Sink', perhaps a file or another socket.------ An important note: the response body returned by this function represents a--- live HTTP connection. As such, if you do not use the response body, an open--- socket will be retained until the containing @ResourceT@ block exits. If you--- do not need the response body, it is recommended that you explicitly shut--- down the connection immediately, using the pattern:------ > responseBody res $$+- return ()------ As a more thorough example, consider the following program. Without the--- explicit response body closing, the program will run out of file descriptors--- around the 1000th request (depending on the operating system limits).------ > import Control.Monad (replicateM_)--- > import Control.Monad.IO.Class (liftIO)--- > import Data.Conduit (($$+-))--- > import Network (withSocketsDo)--- > import Network.HTTP.Conduit--- >--- > main = withSocketsDo $ withManager $ \manager -> do--- > req <- parseUrl "http://localhost/"--- > mapM_ (worker manager req) [1..5000]--- >--- > worker manager req i = do--- > res <- http req manager--- > responseBody res $$+- return () -- The important line--- > liftIO $ print (i, responseStatus res)------ Note: Unlike previous versions, this function will perform redirects, as--- specified by the 'redirectCount' setting.-responseOpen :: Request -> Manager -> IO (Response BodyReader)-responseOpen req0 manager = mWrapIOException manager $ do- res <-- if redirectCount req0 == 0- then httpRaw req0 manager- else go (redirectCount req0) req0- maybe (return res) throwIO =<< applyCheckStatus (checkStatus req0) res- where- go count req' = httpRedirect- count- (\req -> do- res <- httpRaw req manager- let mreq = getRedirectedRequest req (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res))- return (res, mreq))- req'---- | Apply 'Request'\'s 'checkStatus' and return resulting exception if any.-applyCheckStatus- :: (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException)- -> Response BodyReader- -> IO (Maybe SomeException)-applyCheckStatus checkStatus' res =- case checkStatus' (responseStatus res) (responseHeaders res) (responseCookieJar res) of- Nothing -> return Nothing- Just exc -> do- exc' <-- case fromException exc of- Just (StatusCodeException s hdrs cookie_jar) -> do- lbs <- brReadSome (responseBody res) 1024- return $ toException $ StatusCodeException s (hdrs ++- [("X-Response-Body-Start", toStrict' lbs)]) cookie_jar- _ -> return exc- responseClose res- return (Just exc')- where-#if MIN_VERSION_bytestring(0,10,0)- toStrict' = L.toStrict-#else- toStrict' = S.concat . L.toChunks-#endif---- | Redirect loop-httpRedirect- :: Int -- ^ 'redirectCount'- -> (Request -> IO (Response BodyReader, Maybe Request)) -- ^ function which performs a request and returns a response, and possibly another request if there's a redirect.- -> Request- -> IO (Response BodyReader)-httpRedirect count0 http' req0 = go count0 req0 []- where- go (-1) _ ress = throwIO . TooManyRedirects =<< mapM lbsResponse ress- go count req' ress = do- (res, mreq) <- http' req'- case mreq of- Just req -> do- {- FIXME- -- Allow the original connection to return to the- -- connection pool immediately by flushing the body.- -- If the response body is too large, don't flush, but- -- instead just close the connection.- let maxFlush = 1024- readMay bs =- case S8.readInt bs of- Just (i, bs') | S.null bs' -> Just i- _ -> Nothing- case lookup "content-length" (responseHeaders res) >>= readMay of- Just i | i > maxFlush -> return ()- _ -> void $ brReadSome (responseBody res) maxFlush- -}- responseClose res-- -- And now perform the actual redirect- go (count - 1) req (res:ress)- Nothing -> return res
− src/Network/HTTP/Client/Body.hs
@@ -1,194 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}-module Network.HTTP.Client.Body where--import Network.HTTP.Client.Connection-import Network.HTTP.Client.Types-import Control.Exception (throwIO, assert)-import Data.ByteString (ByteString, empty, uncons)-import Data.IORef-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Control.Monad (unless, when)-import qualified Codec.Zlib as Z--data BodyReader = BodyReader- { brRead :: !(IO ByteString)- , brComplete :: !(IO Bool)- }--brReadSome :: BodyReader -> Int -> IO L.ByteString-brReadSome BodyReader {..} =- loop id- where- loop front rem- | rem <= 0 = return $ L.fromChunks $ front []- | otherwise = do- bs <- brRead- if S.null bs- then return $ L.fromChunks $ front []- else loop (front . (bs:)) (rem - S.length bs)--brEmpty :: BodyReader-brEmpty = BodyReader- { brRead = return S.empty- , brComplete = return True- }--brAddCleanup :: IO () -> BodyReader -> BodyReader-brAddCleanup cleanup br = BodyReader- { brRead = do- bs <- brRead br- when (S.null bs) cleanup- return bs- , brComplete = brComplete br- }--brConsume :: BodyReader -> IO [S.ByteString]-brConsume f =- go id- where- go front = do- x <- brRead f- if S.null x- then return $ front []- else go (front . (x:))--makeGzipReader :: BodyReader -> IO BodyReader-makeGzipReader br = do- inf <- Z.initInflate $ Z.WindowBits 31- istate <- newIORef Nothing- let goPopper popper = do- mbs <- popper- case mbs of- Just bs -> do- writeIORef istate $ Just popper- return bs- Nothing -> do- bs <- Z.flushInflate inf- if S.null bs- then start- else do- writeIORef istate Nothing- return bs- start = do- bs <- brRead br- if S.null bs- then return S.empty- else do- popper <- Z.feedInflate inf bs- goPopper popper- return BodyReader- { brRead = do- state <- readIORef istate- case state of- Nothing -> start- Just popper -> goPopper popper- , brComplete = brComplete br- }--makeUnlimitedReader :: Connection -> IO BodyReader-makeUnlimitedReader Connection {..} = do- icomplete <- newIORef False- return $! BodyReader- { brRead = do- bs <- connectionRead- when (S.null bs) $ writeIORef icomplete True- return bs- , brComplete = readIORef icomplete- }--makeLengthReader :: Int -> Connection -> IO BodyReader-makeLengthReader count0 Connection {..} = do- icount <- newIORef count0- return $! BodyReader- { brRead = do- count <- readIORef icount- if count <= 0- then return empty- else do- bs <- connectionRead- when (S.null bs) $ throwIO $ ResponseBodyTooShort (fromIntegral count0) (fromIntegral $ count0 - count)- case compare count $ S.length bs of- LT -> do- let (x, y) = S.splitAt count bs- connectionUnread y- writeIORef icount (-1)- return x- EQ -> do- writeIORef icount (-1)- return bs- GT -> do- writeIORef icount (count - S.length bs)- return bs- , brComplete = fmap (== -1) $ readIORef icount- }--makeChunkedReader :: Bool -- ^ send headers- -> Connection- -> IO BodyReader-makeChunkedReader sendHeaders conn@Connection {..} = do- icount <- newIORef 0- return $! BodyReader- { brRead = go icount- , brComplete = do- count <- readIORef icount- return $! count == -1- }- where- go icount = do- count0 <- readIORef icount- count <-- if count0 == 0- then readHeader- else return count0- if count <= 0- then do- writeIORef icount (-1)- return empty- else do- (bs, count') <- sendChunk count- writeIORef icount count'- return bs-- sendChunk 0 = return (empty, 0)- sendChunk remainder = do- bs <- connectionRead- when (S.null bs) $ throwIO InvalidChunkHeaders- case compare remainder $ S.length bs of- LT -> do- let (x, y) = S.splitAt remainder bs- assert (not $ S.null y) $ connectionUnread y- requireNewline- return (x, 0)- EQ -> do- requireNewline- return (bs, 0)- GT -> return (bs, remainder - S.length bs)-- requireNewline = do- bs <- connectionReadLine conn- unless (S.null bs) $ throwIO InvalidChunkHeaders-- readHeader = do- bs <- connectionReadLine conn- case parseHex bs of- Nothing -> throwIO InvalidChunkHeaders- Just hex -> return hex-- parseHex bs0 =- case uncons bs0 of- Just (w0, bs')- | Just i0 <- toI w0 -> Just $ parseHex' i0 bs'- _ -> Nothing- parseHex' i bs =- case uncons bs of- Just (w, bs)- | Just i' <- toI w -> parseHex' (i * 16 + i') bs- _ -> i-- toI w- | 48 <= w && w <= 57 = Just $ fromIntegral w - 48- | 65 <= w && w <= 70 = Just $ fromIntegral w - 55- | 97 <= w && w <= 102 = Just $ fromIntegral w - 87- | otherwise = Nothing
− src/Network/HTTP/Client/Connection.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}-module Network.HTTP.Client.Connection where--import Data.ByteString (ByteString, empty)-import Data.IORef-import Control.Monad-import Control.Exception (throwIO)-import Network.HTTP.Client.Types-import Network.Socket (Socket, sClose, HostAddress, defaultHints, addrFlags)-import qualified Network.Socket as NS-import Network.Socket.ByteString (sendAll, recv)-import qualified Control.Exception as E-import qualified Data.ByteString as S-import Data.Word (Word8)--connectionReadLine :: Connection -> IO ByteString-connectionReadLine conn = do- bs <- connectionRead conn- when (S.null bs) $ throwIO IncompleteHeaders- connectionReadLineWith conn bs--connectionReadLineWith :: Connection -> ByteString -> IO ByteString-connectionReadLineWith conn bs0 =- go bs0 id 0- where- go bs front total =- case S.breakByte charLF bs of- (_, "") -> do- let total' = total + S.length bs- when (total' > 1024) $ throwIO OverlongHeaders- bs' <- connectionRead conn- when (S.null bs') $ throwIO IncompleteHeaders- go bs' (front . (bs:)) total'- (x, S.drop 1 -> y) -> do- unless (S.null y) $! connectionUnread conn y- return $! killCR $! S.concat $! front [x]--charLF, charCR, charSpace, charColon, charPeriod :: Word8-charLF = 10-charCR = 13-charSpace = 32-charColon = 58-charPeriod = 46--killCR :: ByteString -> ByteString-killCR bs- | S.null bs = bs- | S.last bs == charCR = S.init bs- | otherwise = bs----- | For testing-dummyConnection :: [ByteString] -- ^ input- -> IO (Connection, IO [ByteString], IO [ByteString]) -- ^ conn, output, input-dummyConnection input0 = do- iinput <- newIORef input0- ioutput <- newIORef []- return (Connection- { connectionRead = atomicModifyIORef iinput $ \input ->- case input of- [] -> ([], empty)- x:xs -> (xs, x)- , connectionUnread = \x -> atomicModifyIORef iinput $ \input -> (x:input, ())- , connectionWrite = \x -> atomicModifyIORef ioutput $ \output -> (output ++ [x], ())- , connectionClose = return ()- }, atomicModifyIORef ioutput $ \output -> ([], output), readIORef iinput)--makeConnection :: IO ByteString -- ^ read- -> (ByteString -> IO ()) -- ^ write- -> IO () -- ^ close- -> IO Connection-makeConnection r w c = do- istack <- newIORef []- _ <- mkWeakIORef istack c- return $! Connection- { connectionRead = join $ atomicModifyIORef istack $ \stack ->- case stack of- x:xs -> (xs, return x)- [] -> ([], r)- , connectionUnread = \x -> atomicModifyIORef istack $ \stack -> (x:stack, ())- , connectionWrite = w- , connectionClose = c- }--socketConnection :: Socket -> IO Connection-socketConnection socket = makeConnection- (recv socket 4096)- (sendAll socket)- (sClose socket)--openSocketConnection :: Maybe HostAddress- -> String -- ^ host- -> Int -- ^ port- -> IO Connection-openSocketConnection hostAddress host port = do- let hints = NS.defaultHints {- NS.addrFlags = [NS.AI_ADDRCONFIG]- , NS.addrSocketType = NS.Stream- }- addrs <- case hostAddress of- Nothing ->- NS.getAddrInfo (Just hints) (Just host) (Just $ show port)- Just ha ->- return- [NS.AddrInfo- { NS.addrFlags = []- , NS.addrFamily = NS.AF_INET- , NS.addrSocketType = NS.Stream- , NS.addrProtocol = 6 -- tcp- , NS.addrAddress = NS.SockAddrInet (toEnum port) ha- , NS.addrCanonName = Nothing- }]-- firstSuccessful addrs $ \addr ->- E.bracketOnError- (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)- (NS.addrProtocol addr))- (NS.sClose)- (\sock -> do- NS.setSocketOption sock NS.NoDelay 1- NS.connect sock (NS.addrAddress addr)- socketConnection sock)--firstSuccessful :: [NS.AddrInfo] -> (NS.AddrInfo -> IO a) -> IO a-firstSuccessful [] _ = error "getAddrInfo returned empty list"-firstSuccessful (a:as) cb =- cb a `E.catch` \(e :: E.IOException) ->- case as of- [] -> E.throwIO e- _ -> firstSuccessful as cb
− src/Network/HTTP/Client/Cookies.hs
@@ -1,246 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library.-module Network.HTTP.Client.Cookies where-{-- ( -- * Cookie functions- updateCookieJar- , receiveSetCookie- , generateCookie- , insertCheckedCookie- , insertCookiesIntoRequest- , computeCookieString- , evictExpiredCookies- ) where- -}--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as S8-import Data.Maybe-import qualified Data.List as L-import Data.Time.Clock-import Data.Time.Calendar-import Web.Cookie-import qualified Data.CaseInsensitive as CI-import Blaze.ByteString.Builder-import qualified Network.PublicSuffixList.Lookup as PSL-import Data.Text.Encoding (decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)--import qualified Network.HTTP.Client.Request as Req-import qualified Network.HTTP.Client.Response as Res-import Network.HTTP.Client.Types as Req--slash :: Integral a => a-slash = 47 -- '/'--isIpAddress :: BS.ByteString -> Bool-isIpAddress =- go 4- where- go 0 bs = BS.null bs- go rest bs =- case S8.readInt x of- Just (i, x') | BS.null x' && i >= 0 && i < 256 -> go (rest - 1) y- _ -> False- where- (x, y') = BS.breakByte 46 bs -- period- y = BS.drop 1 y'---- | This corresponds to the subcomponent algorithm entitled \"Domain Matching\" detailed--- in section 5.1.3-domainMatches :: BS.ByteString -> BS.ByteString -> Bool-domainMatches string domainString- | string == domainString = True- | BS.length string < BS.length domainString + 1 = False- | domainString `BS.isSuffixOf` string && BS.singleton (BS.last difference) == "." && not (isIpAddress string) = True- | otherwise = False- where difference = BS.take (BS.length string - BS.length domainString) string---- | This corresponds to the subcomponent algorithm entitled \"Paths\" detailed--- in section 5.1.4-defaultPath :: Req.Request -> BS.ByteString-defaultPath req- | BS.null uri_path = "/"- | BS.singleton (BS.head uri_path) /= "/" = "/"- | BS.count slash uri_path <= 1 = "/"- | otherwise = BS.reverse $ BS.tail $ BS.dropWhile (/= slash) $ BS.reverse uri_path- where uri_path = Req.path req---- | This corresponds to the subcomponent algorithm entitled \"Path-Match\" detailed--- in section 5.1.4-pathMatches :: BS.ByteString -> BS.ByteString -> Bool-pathMatches requestPath cookiePath- | cookiePath == path' = True- | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.last cookiePath) == "/" = True- | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.head remainder) == "/" = True- | otherwise = False- where remainder = BS.drop (BS.length cookiePath) requestPath- path' = case S8.uncons requestPath of- Just ('/', _) -> requestPath- _ -> '/' `S8.cons` requestPath--createCookieJar :: [Cookie] -> CookieJar-createCookieJar = CJ--destroyCookieJar :: CookieJar -> [Cookie]-destroyCookieJar = expose--insertIntoCookieJar :: Cookie -> CookieJar -> CookieJar-insertIntoCookieJar cookie cookie_jar' = CJ $ cookie : cookie_jar- where cookie_jar = expose cookie_jar'--removeExistingCookieFromCookieJar :: Cookie -> CookieJar -> (Maybe Cookie, CookieJar)-removeExistingCookieFromCookieJar cookie cookie_jar' = (mc, CJ lc)- where (mc, lc) = removeExistingCookieFromCookieJarHelper cookie (expose cookie_jar')- removeExistingCookieFromCookieJarHelper _ [] = (Nothing, [])- removeExistingCookieFromCookieJarHelper c (c' : cs)- | c == c' = (Just c', cs)- | otherwise = (cookie', c' : cookie_jar'')- where (cookie', cookie_jar'') = removeExistingCookieFromCookieJarHelper c cs---- | Are we configured to reject cookies for domains such as \"com\"?-rejectPublicSuffixes :: Bool-rejectPublicSuffixes = True--isPublicSuffix :: BS.ByteString -> Bool-isPublicSuffix = PSL.isSuffix . decodeUtf8With lenientDecode---- | This corresponds to the eviction algorithm described in Section 5.3 \"Storage Model\"-evictExpiredCookies :: CookieJar -- ^ Input cookie jar- -> UTCTime -- ^ Value that should be used as \"now\"- -> CookieJar -- ^ Filtered cookie jar-evictExpiredCookies cookie_jar' now = CJ $ filter (\ cookie -> cookie_expiry_time cookie >= now) $ expose cookie_jar'---- | This applies the 'computeCookieString' to a given Request-insertCookiesIntoRequest :: Req.Request -- ^ The request to insert into- -> CookieJar -- ^ Current cookie jar- -> UTCTime -- ^ Value that should be used as \"now\"- -> (Req.Request, CookieJar) -- ^ (Ouptut request, Updated cookie jar (last-access-time is updated))-insertCookiesIntoRequest request cookie_jar now- | BS.null cookie_string = (request, cookie_jar')- | otherwise = (request {Req.requestHeaders = cookie_header : purgedHeaders}, cookie_jar')- where purgedHeaders = L.deleteBy (\ (a, _) (b, _) -> a == b) (CI.mk $ "Cookie", BS.empty) $ Req.requestHeaders request- (cookie_string, cookie_jar') = computeCookieString request cookie_jar now True- cookie_header = (CI.mk $ "Cookie", cookie_string)---- | This corresponds to the algorithm described in Section 5.4 \"The Cookie Header\"-computeCookieString :: Req.Request -- ^ Input request- -> CookieJar -- ^ Current cookie jar- -> UTCTime -- ^ Value that should be used as \"now\"- -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)- -> (BS.ByteString, CookieJar) -- ^ (Contents of a \"Cookie\" header, Updated cookie jar (last-access-time is updated))-computeCookieString request cookie_jar now is_http_api = (output_line, cookie_jar')- where matching_cookie cookie = condition1 && condition2 && condition3 && condition4- where condition1- | cookie_host_only cookie = Req.host request == cookie_domain cookie- | otherwise = domainMatches (Req.host request) (cookie_domain cookie)- condition2 = pathMatches (Req.path request) (cookie_path cookie)- condition3- | not (cookie_secure_only cookie) = True- | otherwise = Req.secure request- condition4- | not (cookie_http_only cookie) = True- | otherwise = is_http_api- matching_cookies = filter matching_cookie $ expose cookie_jar- output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies- output_line = toByteString $ renderCookies $ output_cookies- folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of- (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar'''- (Nothing, cookie_jar''') -> cookie_jar'''- cookie_jar' = foldl folding_function cookie_jar matching_cookies---- | This applies 'receiveSetCookie' to a given Response-updateCookieJar :: Res.Response a -- ^ Response received from server- -> Req.Request -- ^ Request which generated the response- -> UTCTime -- ^ Value that should be used as \"now\"- -> CookieJar -- ^ Current cookie jar- -> (CookieJar, Res.Response a) -- ^ (Updated cookie jar with cookies from the Response, The response stripped of any \"Set-Cookie\" header)-updateCookieJar response request now cookie_jar = (cookie_jar', response {Res.responseHeaders = other_headers})- where (set_cookie_headers, other_headers) = L.partition ((== (CI.mk $ "Set-Cookie")) . fst) $ Res.responseHeaders response- set_cookie_data = map snd set_cookie_headers- set_cookies = map parseSetCookie set_cookie_data- cookie_jar' = foldl (\ cj sc -> receiveSetCookie sc request now True cj) cookie_jar set_cookies---- | This corresponds to the algorithm described in Section 5.3 \"Storage Model\"--- This function consists of calling 'generateCookie' followed by 'insertCheckedCookie'.--- Use this function if you plan to do both in a row.--- 'generateCookie' and 'insertCheckedCookie' are only provided for more fine-grained control.-receiveSetCookie :: SetCookie -- ^ The 'SetCookie' the cookie jar is receiving- -> Req.Request -- ^ The request that originated the response that yielded the 'SetCookie'- -> UTCTime -- ^ Value that should be used as \"now\"- -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)- -> CookieJar -- ^ Input cookie jar to modify- -> CookieJar -- ^ Updated cookie jar-receiveSetCookie set_cookie request now is_http_api cookie_jar = case (do- cookie <- generateCookie set_cookie request now is_http_api- return $ insertCheckedCookie cookie cookie_jar is_http_api) of- Just cj -> cj- Nothing -> cookie_jar---- | Insert a cookie created by generateCookie into the cookie jar (or not if it shouldn't be allowed in)-insertCheckedCookie :: Cookie -- ^ The 'SetCookie' the cookie jar is receiving- -> CookieJar -- ^ Input cookie jar to modify- -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)- -> CookieJar -- ^ Updated (or not) cookie jar-insertCheckedCookie c cookie_jar is_http_api = case (do- (cookie_jar', cookie') <- existanceTest c cookie_jar- return $ insertIntoCookieJar cookie' cookie_jar') of- Just cj -> cj- Nothing -> cookie_jar- where existanceTest cookie cookie_jar' = existanceTestHelper cookie $ removeExistingCookieFromCookieJar cookie cookie_jar'- existanceTestHelper new_cookie (Just old_cookie, cookie_jar')- | not is_http_api && cookie_http_only old_cookie = Nothing- | otherwise = return (cookie_jar', new_cookie {cookie_creation_time = cookie_creation_time old_cookie})- existanceTestHelper new_cookie (Nothing, cookie_jar') = return (cookie_jar', new_cookie)---- | Turn a SetCookie into a Cookie, if it is valid-generateCookie :: SetCookie -- ^ The 'SetCookie' we are encountering- -> Req.Request -- ^ The request that originated the response that yielded the 'SetCookie'- -> UTCTime -- ^ Value that should be used as \"now\"- -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)- -> Maybe Cookie -- ^ The optional output cookie-generateCookie set_cookie request now is_http_api = do- domain_sanitized <- sanitizeDomain $ step4 (setCookieDomain set_cookie)- domain_intermediate <- step5 domain_sanitized- (domain_final, host_only') <- step6 domain_intermediate- http_only' <- step10- return $ Cookie { cookie_name = setCookieName set_cookie- , cookie_value = setCookieValue set_cookie- , cookie_expiry_time = getExpiryTime (setCookieExpires set_cookie) (setCookieMaxAge set_cookie)- , cookie_domain = domain_final- , cookie_path = getPath $ setCookiePath set_cookie- , cookie_creation_time = now- , cookie_last_access_time = now- , cookie_persistent = getPersistent- , cookie_host_only = host_only'- , cookie_secure_only = setCookieSecure set_cookie- , cookie_http_only = http_only'- }- where sanitizeDomain domain'- | has_a_character && BS.singleton (BS.last domain') == "." = Nothing- | has_a_character && BS.singleton (BS.head domain') == "." = Just $ BS.tail domain'- | otherwise = Just $ domain'- where has_a_character = not (BS.null domain')- step4 (Just set_cookie_domain) = set_cookie_domain- step4 Nothing = BS.empty- step5 domain'- | firstCondition && domain' == (Req.host request) = return BS.empty- | firstCondition = Nothing- | otherwise = return domain'- where firstCondition = rejectPublicSuffixes && has_a_character && isPublicSuffix domain'- has_a_character = not (BS.null domain')- step6 domain'- | firstCondition && not (domainMatches (Req.host request) domain') = Nothing- | firstCondition = return (domain', False)- | otherwise = return (Req.host request, True)- where firstCondition = not $ BS.null domain'- step10- | not is_http_api && setCookieHttpOnly set_cookie = Nothing- | otherwise = return $ setCookieHttpOnly set_cookie- getExpiryTime :: Maybe UTCTime -> Maybe DiffTime -> UTCTime- getExpiryTime _ (Just t) = (fromRational $ toRational t) `addUTCTime` now- getExpiryTime (Just t) Nothing = t- getExpiryTime Nothing Nothing = UTCTime (365000 `addDays` utctDay now) (secondsToDiffTime 0)- getPath (Just p) = p- getPath Nothing = defaultPath request- getPersistent = isJust (setCookieExpires set_cookie) || isJust (setCookieMaxAge set_cookie)
− src/Network/HTTP/Client/Headers.hs
@@ -1,75 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}-module Network.HTTP.Client.Headers where--import Control.Applicative ((<$>), (<*>))-import Control.Exception (throwIO)-import Control.Monad-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Data.CaseInsensitive as CI-import Network.HTTP.Client.Connection-import Network.HTTP.Client.Types-import Network.HTTP.Types--parseStatusHeaders :: Connection -> IO StatusHeaders-parseStatusHeaders conn = do- (status, version) <- getStatusLine- headers <- parseHeaders 0 id- return $! StatusHeaders status version headers- where- getStatusLine = do- -- Ensure that there is some data coming in. If not, we want to signal- -- this as a connection problem and not a protocol problem.- bs <- connectionRead conn- when (S.null bs) $ throwIO NoResponseDataReceived-- status@(code, _) <- connectionReadLineWith conn bs >>= parseStatus 3- if code == status100- then newline ExpectedBlankAfter100Continue >> getStatusLine- else return status-- newline exc = do- line <- connectionReadLine conn- unless (S.null line) $ throwIO exc-- parseStatus :: Int -> S.ByteString -> IO (Status, HttpVersion)- parseStatus i bs | S.null bs && i > 0 = connectionReadLine conn >>= parseStatus (i - 1)- parseStatus _ bs = do- let (ver, bs2) = S.breakByte charSpace bs- (code, bs3) = S.breakByte charSpace $ S.dropWhile (== charSpace) bs2- msg = S.dropWhile (== charSpace) bs3- case (,) <$> parseVersion ver <*> readInt code of- Just (ver', code') -> return (Status code' msg, ver')- Nothing -> throwIO $ InvalidStatusLine bs-- stripPrefixBS x y- | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y- | otherwise = Nothing- parseVersion bs0 = do- bs1 <- stripPrefixBS "HTTP/" bs0- let (num1, S.drop 1 -> num2) = S.breakByte charPeriod bs1- HttpVersion <$> readInt num1 <*> readInt num2-- readInt bs =- case S8.readInt bs of- Just (i, "") -> Just i- _ -> Nothing-- parseHeaders 100 _ = throwIO OverlongHeaders- parseHeaders count front = do- line <- connectionReadLine conn- if S.null line- then return $ front []- else do- header <- parseHeader line- parseHeaders (count + 1) $ front . (header:)-- parseHeader :: S.ByteString -> IO Header- parseHeader bs = do- let (key, bs2) = S.breakByte charColon bs- when (S.null bs2) $ throwIO $ InvalidHeader bs- return (CI.mk $! strip key, strip $! S.drop 1 bs2)-- strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace)
− src/Network/HTTP/Client/Manager.hs
@@ -1,371 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RankNTypes #-}-module Network.HTTP.Client.Manager- ( Manager- , mResponseTimeout- , mRetryableException- , mWrapIOException- , ManagerSettings (..)- , ConnKey (..)- , ConnHost (..)- , newManager- , closeManager- , getConn- , ConnReuse (..)- , ConnRelease- , ManagedConn (..)- , failedConnectionException- , defaultManagerSettings- ) where--#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif-import Data.Monoid (mappend)-import System.IO (hClose, hFlush, IOMode(..))-import qualified Data.IORef as I-import qualified Data.Map as Map--import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L--import qualified Blaze.ByteString.Builder as Blaze--import Data.Text (Text)-import qualified Data.Text as T--import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Exception (mask_, SomeException, catch, throwIO, fromException, mask, IOException, Exception (..), handle)-import Control.Concurrent (forkIO, threadDelay)-import Data.Time (UTCTime (..), Day (..), DiffTime, getCurrentTime, addUTCTime)-import Control.DeepSeq (deepseq)--import qualified Network.Socket as NS--import Data.Default-import Data.Maybe (mapMaybe)-import System.IO (Handle)-import System.Mem.Weak (Weak, deRefWeak)-import Network.HTTP.Client.Types-import Network.HTTP.Client.Connection---- | Settings for a @Manager@. Please use the 'defaultManagerSettings' function and then modify--- individual settings.-data ManagerSettings = ManagerSettings- { managerConnCount :: !Int- -- ^ Number of connections to a single host to keep alive. Default: 10.- , managerRawConnection :: !(IO (Maybe NS.HostAddress -> String -> Int -> IO Connection))- -- ^ Create an insecure connection.- , managerTlsConnection :: !(IO (Maybe NS.HostAddress -> String -> Int -> IO Connection))- -- ^ Create a TLS connection. Default behavior: throw an exception that TLS is not supported.- , managerResponseTimeout :: !(Maybe Int)- -- ^ Default timeout (in microseconds) to be applied to requests which do- -- not provide a timeout value.- --- -- Default is 5 seconds- --- -- Since 1.9.3- , managerRetryableException :: !(SomeException -> Bool)- -- ^ Exceptions for which we should retry our request if we were reusing an- -- already open connection. In the case of IOExceptions, for example, we- -- assume that the connection was closed on the server and therefore open a- -- new one.- , managerWrapIOException :: !(forall a. IO a -> IO a)- }--defaultManagerSettings :: ManagerSettings-defaultManagerSettings = ManagerSettings- { managerConnCount = 10- , managerRawConnection = return openSocketConnection- , managerTlsConnection = return $ \_ _ _ -> throwIO TlsNotSupported- , managerResponseTimeout = Just 5000000- , managerRetryableException = \e ->- case fromException e of- Just (_ :: IOException) -> True- _ ->- case fromException e of- -- Note: Some servers will timeout connections by accepting- -- the incoming packets for the new request, but closing- -- the connection as soon as we try to read. To make sure- -- we open a new connection under these circumstances, we- -- check for the NoResponseDataReceived exception.- Just NoResponseDataReceived -> True- _ -> False- , managerWrapIOException =- let wrapper se =- case fromException se of- Just e -> toException $ InternalIOException e- Nothing -> se- in handle $ throwIO . wrapper- }---- | Keeps track of open connections for keep-alive.--- If possible, you should share a single 'Manager' between multiple threads and requests.-data Manager = Manager- { mConns :: !(I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection))))- -- ^ @Nothing@ indicates that the manager is closed.- , mMaxConns :: !Int- -- ^ This is a per-@ConnKey@ value.- , mResponseTimeout :: !(Maybe Int)- -- ^ Copied from 'managerResponseTimeout'- , mRawConnection :: !(Maybe NS.HostAddress -> String -> Int -> IO Connection)- , mTlsConnection :: !(Maybe NS.HostAddress -> String -> Int -> IO Connection)- , mRetryableException :: !(SomeException -> Bool)- , mWrapIOException :: !(forall a. IO a -> IO a)- }--data NonEmptyList a =- One !a !UTCTime |- Cons !a !Int !UTCTime !(NonEmptyList a)---- | Hostname or resolved host address.-data ConnHost =- HostName !Text |- HostAddress !NS.HostAddress- deriving (Eq, Show, Ord)---- | @ConnKey@ consists of a hostname, a port and a @Bool@--- specifying whether to use SSL.-data ConnKey = ConnKey !ConnHost !Int !Bool- deriving (Eq, Show, Ord)--takeSocket :: Manager -> ConnKey -> IO (Maybe Connection)-takeSocket man key =- I.atomicModifyIORef (mConns man) go- where- go Nothing = (Nothing, Nothing)- go (Just m) =- case Map.lookup key m of- Nothing -> (Just m, Nothing)- Just (One a _) -> (Just $ Map.delete key m, Just a)- Just (Cons a _ _ rest) -> (Just $ Map.insert key rest m, Just a)--putSocket :: Manager -> ConnKey -> Connection -> IO ()-putSocket man key ci = do- now <- getCurrentTime- msock <- I.atomicModifyIORef (mConns man) (go now)- maybe (return ()) connectionClose msock- where- go _ Nothing = (Nothing, Just ci)- go now (Just m) =- case Map.lookup key m of- Nothing -> (Just $ Map.insert key (One ci now) m, Nothing)- Just l ->- let (l', mx) = addToList now (mMaxConns man) ci l- in (Just $ Map.insert key l' m, mx)---- | Add a new element to the list, up to the given maximum number. If we're--- already at the maximum, return the new value as leftover.-addToList :: UTCTime -> Int -> a -> NonEmptyList a -> (NonEmptyList a, Maybe a)-addToList _ i x l | i <= 1 = (l, Just x)-addToList now _ x l@One{} = (Cons x 2 now l, Nothing)-addToList now maxCount x l@(Cons _ currCount _ _)- | maxCount > currCount = (Cons x (currCount + 1) now l, Nothing)- | otherwise = (l, Just x)---- | Create a 'Manager'. You must manually call 'closeManager' to shut it down.------ Creating a new 'Manager' is an expensive operation, you are advised to share--- a single 'Manager' between requests instead.-newManager :: ManagerSettings -> IO Manager-newManager ms = do- rawConnection <- managerRawConnection ms- tlsConnection <- managerTlsConnection ms- mapRef <- I.newIORef (Just Map.empty)- wmapRef <- I.mkWeakIORef mapRef $ closeManager' mapRef- _ <- forkIO $ reap wmapRef- let manager = Manager- { mConns = mapRef- , mMaxConns = managerConnCount ms- , mResponseTimeout = managerResponseTimeout ms- , mRawConnection = rawConnection- , mTlsConnection = tlsConnection- , mRetryableException = managerRetryableException ms- , mWrapIOException = managerWrapIOException ms- }- return manager---- | Collect and destroy any stale connections.-reap :: Weak (I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection))))- -> IO ()-reap wmapRef =- mask_ loop- where- loop = do- threadDelay (5 * 1000 * 1000)- mmapRef <- deRefWeak wmapRef- case mmapRef of- Nothing -> return () -- manager is closed- Just mapRef -> goMapRef mapRef-- goMapRef mapRef = do- now <- getCurrentTime- let isNotStale time = 30 `addUTCTime` time >= now- mtoDestroy <- I.atomicModifyIORef mapRef (findStaleWrap isNotStale)- case mtoDestroy of- Nothing -> return () -- manager is closed- Just toDestroy -> do- mapM_ safeConnClose toDestroy- loop- findStaleWrap _ Nothing = (Nothing, Nothing)- findStaleWrap isNotStale (Just m) =- let (x, y) = findStale isNotStale m- in (Just x, Just y)- findStale isNotStale =- findStale' id id . Map.toList- where- findStale' destroy keep [] = (Map.fromList $ keep [], destroy [])- findStale' destroy keep ((connkey, nelist):rest) =- findStale' destroy' keep' rest- where- -- Note: By definition, the timestamps must be in descending order,- -- so we don't need to traverse the whole list.- (notStale, stale) = span (isNotStale . fst) $ neToList nelist- destroy' = destroy . (map snd stale++)- keep' =- case neFromList notStale of- Nothing -> keep- Just x -> keep . ((connkey, x):)-- flushStaleCerts now =- Map.fromList . mapMaybe flushStaleCerts' . Map.toList- where- flushStaleCerts' (host', inner) =- case mapMaybe flushStaleCerts'' $ Map.toList inner of- [] -> Nothing- pairs ->- let x = take 10 pairs- in x `seqPairs` Just (host', Map.fromList x)- flushStaleCerts'' (certs, expires)- | expires > now = Just (certs, expires)- | otherwise = Nothing-- seqPairs :: [(L.ByteString, UTCTime)] -> b -> b- seqPairs [] b = b- seqPairs (p:ps) b = p `seqPair` ps `seqPairs` b-- seqPair :: (L.ByteString, UTCTime) -> b -> b- seqPair (lbs, utc) b = lbs `seqLBS` utc `seqUTC` b-- seqLBS :: L.ByteString -> b -> b- seqLBS lbs b = L.length lbs `seq` b-- seqUTC :: UTCTime -> b -> b- seqUTC (UTCTime day dt) b = day `seqDay` dt `seqDT` b-- seqDay :: Day -> b -> b- seqDay (ModifiedJulianDay i) b = i `deepseq` b-- seqDT :: DiffTime -> b -> b- seqDT = seq--neToList :: NonEmptyList a -> [(UTCTime, a)]-neToList (One a t) = [(t, a)]-neToList (Cons a _ t nelist) = (t, a) : neToList nelist--neFromList :: [(UTCTime, a)] -> Maybe (NonEmptyList a)-neFromList [] = Nothing-neFromList [(t, a)] = Just (One a t)-neFromList xs =- Just . snd . go $ xs- where- go [] = error "neFromList.go []"- go [(t, a)] = (2, One a t)- go ((t, a):rest) =- let (i, rest') = go rest- i' = i + 1- in i' `seq` (i', Cons a i t rest')---- | Close all connections in a 'Manager'. Afterwards, the 'Manager'--- can be reused if desired.------ Note that this doesn't affect currently in-flight connections,--- meaning you can safely use it without hurting any queries you may--- have concurrently running.-closeManager :: Manager -> IO ()-closeManager = closeManager' . mConns--closeManager' :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection)))- -> IO ()-closeManager' connsRef = mask_ $ do- m <- I.atomicModifyIORef connsRef $ \x -> (Nothing, x)- mapM_ (nonEmptyMapM_ safeConnClose) $ maybe [] Map.elems m--safeConnClose :: Connection -> IO ()-safeConnClose ci = connectionClose ci `catch` \(_::SomeException) -> return ()--nonEmptyMapM_ :: Monad m => (a -> m ()) -> NonEmptyList a -> m ()-nonEmptyMapM_ f (One x _) = f x-nonEmptyMapM_ f (Cons x _ _ l) = f x >> nonEmptyMapM_ f l---- | This function needs to acquire a @ConnInfo@- either from the @Manager@ or--- via I\/O, and register it with the @ResourceT@ so it is guaranteed to be--- either released or returned to the manager.-getManagedConn- :: Manager- -> ConnKey- -> IO Connection- -> IO (ConnRelease, Connection, ManagedConn)--- We want to avoid any holes caused by async exceptions, so let's mask.-getManagedConn man key open = mask $ \restore -> do- -- Try to take the socket out of the manager.- mci <- takeSocket man key- (ci, isManaged) <-- case mci of- -- There wasn't a matching connection in the manager, so create a- -- new one.- Nothing -> do- ci <- restore open- return (ci, Fresh)- -- Return the existing one- Just ci -> return (ci, Reused)-- -- When we release this connection, we can either reuse it (put it back in- -- the manager) or not reuse it (close the socket). We set up a mutable- -- reference to track what we want to do. By default, we say not to reuse- -- it, that way if an exception is thrown, the connection won't be reused.- toReuseRef <- I.newIORef DontReuse-- -- When the connection is explicitly released, we update our toReuseRef to- -- indicate what action should be taken, and then call release.- let connRelease Reuse = putSocket man key ci- connRelease DontReuse = connectionClose ci-- return (connRelease, ci, isManaged)---- | Create an exception to be thrown if the connection for the given request--- fails.-failedConnectionException :: Request -> HttpException-failedConnectionException req =- FailedConnectionException host' port'- where- (_, host', port') = getConnDest req--getConnDest :: Request -> (Bool, String, Int)-getConnDest req =- case proxy req of- Just p -> (True, S8.unpack (proxyHost p), proxyPort p)- Nothing -> (False, S8.unpack $ host req, port req)--getConn :: Request- -> Manager- -> IO (ConnRelease, Connection, ManagedConn)-getConn req m =- getManagedConn m (ConnKey connKeyHost connport (secure req)) $- go connaddr connhost connport- where- h = host req- (useProxy, connhost, connport) = getConnDest req- (connaddr, connKeyHost) =- case (hostAddress req, useProxy{-, socksProxy req-}) of- (Just ha, False{-, Nothing-}) -> (Just ha, HostAddress ha)- _ -> (Nothing, HostName $ T.pack connhost)- go =- case (secure req, useProxy) of- (False, _) -> mRawConnection m- (True, False) -> mTlsConnection m- -- FIXME (True, True) -> getSslProxyConn (checkCerts m h) (clientCertificates req) h (port req)
− src/Network/HTTP/Client/Request.hs
@@ -1,343 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Network.HTTP.Client.Request- ( parseUrl- , setUriRelative- , getUri- , setUri- , browserDecompress- , alwaysDecompress- , addProxy- , applyBasicAuth- , urlEncodedBody- , needsGunzip- , requestBuilder- , useDefaultTimeout- ) where--import Data.Maybe (fromMaybe, isJust)-import Data.Monoid (mempty, mappend)-import Data.String (IsString(..))-import Control.Monad (when, unless)-import Numeric (showHex)--import Data.Default (Default (def))--import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteStringIO)-import Blaze.ByteString.Builder.Char8 (fromChar)--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.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI)--import Control.Monad.IO.Class (liftIO)-import Control.Exception (Exception, toException, throw, throwIO)-import Control.Failure (Failure (failure))-import qualified Data.CaseInsensitive as CI-import qualified Data.ByteString.Base64 as B64--import Network.HTTP.Client.Types-import Network.HTTP.Client.Connection--import Network.HTTP.Client.Util (readDec, (<>))-import System.Timeout (timeout)-import Data.Time.Clock---- | Convert a URL into a 'Request'.------ This defaults some of the values in 'Request', such as setting 'method' to--- GET and 'requestHeaders' to @[]@.------ Since this function uses 'Failure', the return monad can be anything that is--- an instance of 'Failure', such as 'IO' or 'Maybe'.-parseUrl :: Failure HttpException m => String -> m Request-parseUrl s =- case parseURI (encode s) of- Just uri -> setUri def uri- Nothing -> failure $ InvalidUrlException s "Invalid URL"- where- encode = escapeURIString isAllowedInURI---- | Add a 'URI' to the request. If it is absolute (includes a host name), add--- it as per 'setUri'; if it is relative, merge it with the existing request.-setUriRelative :: Failure HttpException m => Request -> URI -> m Request-setUriRelative req uri =-#if MIN_VERSION_network(2,4,0)- setUri req $ uri `relativeTo` getUri req-#else- case uri `relativeTo` getUri req of- Just uri' -> setUri req uri'- Nothing -> failure $ InvalidUrlException (show uri) "Invalid URL"-#endif---- | Extract a 'URI' from the request.-getUri :: Request -> URI-getUri req = URI- { uriScheme = if secure req- then "https:"- else "http:"- , uriAuthority = Just URIAuth- { uriUserInfo = ""- , uriRegName = S8.unpack $ host req- , uriPort = ':' : show (port req)- }- , uriPath = S8.unpack $ path req- , uriQuery = S8.unpack $ queryString req- , uriFragment = ""- }---- | Validate a 'URI', then add it to the request.-setUri :: Failure HttpException m => Request -> URI -> m Request-setUri req uri = do- sec <- parseScheme uri- auth <- maybe (failUri "URL must be absolute") return $ uriAuthority uri- if not . null $ uriUserInfo auth- then failUri "URL auth not supported; use applyBasicAuth instead"- else return ()- port' <- parsePort sec auth- return req- { host = S8.pack $ uriRegName auth- , port = port'- , secure = sec- , path = S8.pack $- if null $ uriPath uri- then "/"- else uriPath uri- , queryString = S8.pack $ uriQuery uri- }- where- failUri :: Failure HttpException m => String -> m a- failUri = failure . InvalidUrlException (show uri)-- parseScheme URI{uriScheme = scheme} =- case scheme of- "http:" -> return False- "https:" -> return True- _ -> failUri "Invalid scheme"-- parsePort sec URIAuth{uriPort = portStr} =- case portStr of- -- If the user specifies a port, then use it- ':':rest -> maybe- (failUri "Invalid port")- return- (readDec rest)- -- Otherwise, use the default port- _ -> case sec of- False {- HTTP -} -> return 80- True {- HTTPS -} -> return 443--instance Show Request where- show x = unlines- [ "Request {"- , " host = " ++ show (host x)- , " port = " ++ show (port x)- , " secure = " ++ show (secure x)- , " requestHeaders = " ++ show (requestHeaders x)- , " path = " ++ show (path x)- , " queryString = " ++ show (queryString x)- --, " requestBody = " ++ show (requestBody x)- , " method = " ++ show (method x)- , " proxy = " ++ show (proxy x)- , " rawBody = " ++ show (rawBody x)- , " redirectCount = " ++ show (redirectCount x)- , " responseTimeout = " ++ show (responseTimeout x)- , "}"- ]---- | Magic value to be placed in a 'Request' to indicate that we should use the--- timeout value in the @Manager@.------ Since 1.9.3-useDefaultTimeout :: Maybe Int-useDefaultTimeout = Just (-3425)--instance Default Request where- def = Request- { host = "localhost"- , port = 80- , secure = False- , requestHeaders = []- , path = "/"- , queryString = S8.empty- , requestBody = RequestBodyLBS L.empty- , method = "GET"- , proxy = Nothing- , hostAddress = Nothing- , rawBody = False- , decompress = browserDecompress- , redirectCount = 10- , checkStatus = \s@(W.Status sci _) hs cookie_jar ->- if 200 <= sci && sci < 300- then Nothing- else Just $ toException $ StatusCodeException s hs cookie_jar- , responseTimeout = useDefaultTimeout- , getConnectionWrapper = \mtimeout exc f ->- case mtimeout of- Nothing -> fmap ((,) Nothing) f- Just timeout' -> do- before <- getCurrentTime- mres <- timeout timeout' f- case mres of- Nothing -> throwIO exc- Just res -> do- now <- getCurrentTime- let timeSpentMicro = diffUTCTime now before * 1000000- remainingTime = round $ fromIntegral timeout' - timeSpentMicro- if remainingTime <= 0- then throwIO exc- else return (Just remainingTime, res)- , cookieJar = Just def- }--instance IsString Request where- fromString s =- case parseUrl s of- Left e -> throw (e :: HttpException)- Right r -> r---- | Always decompress a compressed stream.-alwaysDecompress :: ContentType -> Bool-alwaysDecompress = const True---- | Decompress a compressed stream unless the content-type is 'application/x-tar'.-browserDecompress :: ContentType -> Bool-browserDecompress = (/= "application/x-tar")---- | Add a Basic Auth header (with the specified user name and password) to the--- given Request. Ignore error handling:------ applyBasicAuth "user" "pass" $ fromJust $ parseUrl url--applyBasicAuth :: S.ByteString -> S.ByteString -> Request -> Request-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 ])----- | Add a proxy to the Request so that the Request when executed will use--- the provided proxy.-addProxy :: S.ByteString -> Int -> Request -> Request-addProxy hst prt req =- req { proxy = Just $ Proxy hst prt }---- | Add url-encoded parameters to the 'Request'.------ This sets a new 'requestBody', adds a content-type request header and--- changes the 'method' to POST.-urlEncodedBody :: [(S.ByteString, S.ByteString)] -> Request -> Request-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- -> [W.Header] -- ^ response headers- -> Bool-needsGunzip req hs' =- not (rawBody req)- && ("content-encoding", "gzip") `elem` hs'- && decompress req (fromMaybe "" $ lookup "content-type" hs')--requestBuilder :: Request -> Connection -> IO ()-requestBuilder req Connection {..} =- bodySource- where- writeBuilder = toByteStringIO connectionWrite-- (contentLength, bodySource) =- case requestBody req of- RequestBodyLBS lbs -> (Just $ L.length lbs, writeBuilder $ builder `mappend` fromLazyByteString lbs)- RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, writeBuilder $ builder `mappend` fromByteString bs)- RequestBodyBuilder i b -> (Just $ i, writeBuilder $ builder `mappend` b)- RequestBodyStream i stream -> (Just i, writeBuilder builder >> writeStream False stream)- RequestBodyStreamChunked stream -> (Nothing, writeBuilder builder >> writeStream True stream)-- writeStream isChunked withStream =- withStream loop- where- loop stream = do- bs <- stream- when isChunked $- connectionWrite $ S8.pack $ showHex (S.length bs) "\r\n"- unless (S.null bs) $ do- connectionWrite bs- when isChunked $ connectionWrite "\r\n"- loop stream--- hh- | port req == 80 && not (secure req) = host req- | port req == 443 && secure req = host req- | otherwise = host req <> S8.pack (':' : show (port req))-- requestProtocol- | secure req = fromByteString "https://"- | otherwise = fromByteString "http://"-- requestHostname- | isJust (proxy req) = requestProtocol <> fromByteString hh- | otherwise = mempty-- 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")-- acceptEncodingHeader =- case lookup "Accept-Encoding" $ requestHeaders req of- Nothing -> (("Accept-Encoding", "gzip"):)- Just "" -> filter (\(k, _) -> k /= "Accept-Encoding")- Just _ -> id-- hostHeader x =- case lookup "Host" x of- Nothing -> ("Host", hh) : x- Just{} -> x-- headerPairs :: W.RequestHeaders- headerPairs = hostHeader- $ acceptEncodingHeader- $ contentLengthHeader contentLength- $ requestHeaders req-- builder :: Builder- builder =- fromByteString (method req)- <> fromByteString " "- <> requestHostname- <> (case S8.uncons $ path req of- Just ('/', _) -> fromByteString $ path req- _ -> fromChar '/' <> fromByteString (path req))- <> (case S8.uncons $ queryString req of- Nothing -> mempty- Just ('?', _) -> fromByteString $ queryString req- _ -> 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"
− src/Network/HTTP/Client/Response.hs
@@ -1,140 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Network.HTTP.Client.Response- ( Response (..)- , getRedirectedRequest- , getResponse- , lbsResponse- ) where--import Control.Arrow (first)-import Control.Monad (liftM)--import Control.Exception (throwIO)-import Control.Monad.IO.Class (MonadIO, liftIO)--import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L--import qualified Data.CaseInsensitive as CI--import Data.Default (def)--import qualified Network.HTTP.Types as W-import Network.URI (parseURIReference)--import Network.HTTP.Client.Types--import Network.HTTP.Client.Manager-import Network.HTTP.Client.Request-import Network.HTTP.Client.Util-import Network.HTTP.Client.Body-import Network.HTTP.Client.Headers-import Network.HTTP.Client.Connection--import System.Timeout (timeout)---- | If a request is a redirection (status code 3xx) this function will create--- a new request from the old request, the server headers returned with the--- redirection, and the redirection code itself. This function returns 'Nothing'--- if the code is not a 3xx, there is no 'location' header included, or if the--- redirected response couldn't be parsed with 'parseUrl'.------ If a user of this library wants to know the url chain that results from a--- specific request, that user has to re-implement the redirect-following logic--- themselves. An example of that might look like this:------ > myHttp req man = do--- > (res, redirectRequests) <- (`runStateT` []) $--- > 'httpRedirect'--- > 9000--- > (\req' -> do--- > res <- http req'{redirectCount=0} man--- > modify (\rqs -> req' : rqs)--- > return (res, getRedirectedRequest req' (responseHeaders res) (responseCookieJar res) (W.statusCode (responseStatus res))--- > )--- > 'lift'--- > req--- > applyCheckStatus (checkStatus req) res--- > return redirectRequests-getRedirectedRequest :: Request -> W.ResponseHeaders -> CookieJar -> Int -> Maybe Request-getRedirectedRequest req hs cookie_jar code- | 300 <= code && code < 400 = do- l' <- lookup "location" hs- req' <- setUriRelative req =<< parseURIReference (S8.unpack l')- return $- if code == 302 || code == 303- -- According to the spec, this should *only* be for status code- -- 303. However, almost all clients mistakenly implement it for- -- 302 as well. So we have to be wrong like everyone else...- then req'- { method = "GET"- , requestBody = RequestBodyBS ""- , cookieJar = cookie_jar'- }- else req' {cookieJar = cookie_jar'}- | otherwise = Nothing- where- cookie_jar' = fmap (const cookie_jar) $ cookieJar req---- | Convert a 'Response' that has a 'Source' body to one with a lazy--- 'L.ByteString' body.-lbsResponse :: Response BodyReader -> IO (Response L.ByteString)-lbsResponse res = do- bss <- brConsume $ responseBody res- return res- { responseBody = L.fromChunks bss- }--getResponse :: ConnRelease- -> Maybe Int- -> Request- -> Connection- -> IO (Response BodyReader)-getResponse connRelease timeout'' req@(Request {..}) conn = do- let timeout' =- case timeout'' of- Nothing -> id- Just useconds -> \ma -> do- x <- timeout useconds ma- case x of- Nothing -> liftIO $ throwIO ResponseTimeout- Just y -> return y- StatusHeaders s version hs <- timeout' $ parseStatusHeaders conn- let mcl = lookup "content-length" hs >>= readDec . S8.unpack-- -- should we put this connection back into the connection manager?- toPut = Just "close" /= lookup "connection" hs && version > W.HttpVersion 1 0- cleanup bodyConsumed = connRelease $ if toPut && bodyConsumed then Reuse else DontReuse-- body <-- -- RFC 2616 section 4.4_1 defines responses that must not include a body- if hasNoBody method (W.statusCode s) || mcl == Just 0- then do- cleanup True- return brEmpty- else do- let isChunked = ("transfer-encoding", "chunked") `elem` hs- body1 <-- if isChunked- then makeChunkedReader rawBody conn- else- case mcl of- Just len -> makeLengthReader len conn- Nothing -> makeUnlimitedReader conn- body2 <- if needsGunzip req hs- then makeGzipReader body1- else return body1- return $ brAddCleanup (cleanup True) body2-- return Response- { responseStatus = s- , responseVersion = version- , responseHeaders = hs- , responseBody = body- , responseCookieJar = def- , responseClose' = ResponseClose (cleanup False)- }
− src/Network/HTTP/Client/Types.hs
@@ -1,327 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-module Network.HTTP.Client.Types where--import Data.Typeable-import Network.HTTP.Types-import Control.Exception (Exception, IOException, SomeException)-import Data.Word (Word64)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Blaze.ByteString.Builder (Builder, fromLazyByteString, fromByteString, toLazyByteString)-import Data.Int (Int64)-import Data.Default-import Data.Monoid-import Data.Time (UTCTime)-import qualified Data.List as DL-import Network.Socket (HostAddress)-import Data.IORef--data Connection = Connection- { connectionRead :: !(IO S.ByteString)- -- ^ If no more data, return empty.- , connectionUnread :: !(S.ByteString -> IO ())- -- ^ Return data to be read next time.- , connectionWrite :: !(S.ByteString -> IO ())- -- ^ Send data to server- , connectionClose :: !(IO ())- }--data StatusHeaders = StatusHeaders !Status !HttpVersion !RequestHeaders- deriving (Show, Eq, Ord)--data HttpException = StatusCodeException Status ResponseHeaders CookieJar- | InvalidUrlException String String- | TooManyRedirects [Response L.ByteString] -- ^ List of encountered responses containing redirects in reverse chronological order; including last redirect, which triggered the exception and was not followed.- | UnparseableRedirect (Response L.ByteString) -- ^ Response containing unparseable redirect.- | TooManyRetries- | HttpParserException String- | HandshakeFailed- | OverlongHeaders- | ResponseTimeout- | FailedConnectionException String Int -- ^ host/port- | ExpectedBlankAfter100Continue- | InvalidStatusLine S.ByteString- | InvalidHeader S.ByteString- | InternalIOException IOException- | ProxyConnectException S.ByteString Int (Either S.ByteString HttpException) -- ^ host/port- | NoResponseDataReceived- | TlsException SomeException- | TlsNotSupported- | ResponseBodyTooShort Word64 Word64- -- ^ Expected size/actual size.- --- -- Since 1.9.4- | InvalidChunkHeaders- -- ^- --- -- Since 1.9.4- | IncompleteHeaders- deriving (Show, Typeable)-instance Exception HttpException----- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\"-data Cookie = Cookie- { cookie_name :: S.ByteString- , cookie_value :: S.ByteString- , cookie_expiry_time :: UTCTime- , cookie_domain :: S.ByteString- , cookie_path :: S.ByteString- , cookie_creation_time :: UTCTime- , cookie_last_access_time :: UTCTime- , cookie_persistent :: Bool- , cookie_host_only :: Bool- , cookie_secure_only :: Bool- , cookie_http_only :: Bool- }- deriving (Read, Show)--newtype CookieJar = CJ { expose :: [Cookie] }- deriving (Read, Show)---- This corresponds to step 11 of the algorithm described in Section 5.3 \"Storage Model\"-instance Eq Cookie where- (==) a b = name_matches && domain_matches && path_matches- where name_matches = cookie_name a == cookie_name b- domain_matches = cookie_domain a == cookie_domain b- path_matches = cookie_path a == cookie_path b--instance Ord Cookie where- compare c1 c2- | S.length (cookie_path c1) > S.length (cookie_path c2) = LT- | S.length (cookie_path c1) < S.length (cookie_path c2) = GT- | cookie_creation_time c1 > cookie_creation_time c2 = GT- | otherwise = LT--instance Default CookieJar where- def = CJ []--instance Eq CookieJar where- (==) cj1 cj2 = (DL.sort $ expose cj1) == (DL.sort $ expose cj2)---- | Since 1.9-instance Monoid CookieJar where- mempty = def- (CJ a) `mappend` (CJ b) = CJ (DL.nub $ DL.sortBy compare' $ a `mappend` b)- where compare' c1 c2 =- -- inverse so that recent cookies are kept by nub over older- if cookie_creation_time c1 > cookie_creation_time c2- then LT- else GT---- | Define a HTTP proxy, consisting of a hostname and port number.--data Proxy = Proxy- { proxyHost :: S.ByteString -- ^ The host name of the HTTP proxy.- , proxyPort :: Int -- ^ The port number of the HTTP proxy.- }- deriving (Show, Read, Eq, Ord, Typeable)---- | When using one of the--- 'RequestBodySource' \/ 'RequestBodySourceChunked' constructors,--- you must ensure--- that the 'Source' can be called multiple times. Usually this--- is not a problem.------ The 'RequestBodySourceChunked' will send a chunked request--- body, note that not all servers support this. Only use--- 'RequestBodySourceChunked' if you know the server you're--- sending to supports chunked request bodies.-data RequestBody- = RequestBodyLBS !L.ByteString- | RequestBodyBS !S.ByteString- | RequestBodyBuilder !Int64 !Builder- | RequestBodyStream !Int64 !(GivesPopper ())- | RequestBodyStreamChunked !(GivesPopper ())-instance Monoid RequestBody where- mempty = RequestBodyBS S.empty- mappend x0 y0 =- case (simplify x0, simplify y0) of- (Left (i, x), Left (j, y)) -> RequestBodyBuilder (i + j) (x `mappend` y)- (Left x, Right y) -> combine (builderToStream x) y- (Right x, Left y) -> combine x (builderToStream y)- (Right x, Right y) -> combine x y- where- combine (Just i, x) (Just j, y) = RequestBodyStream (i + j) (combine' x y)- combine (_, x) (_, y) = RequestBodyStreamChunked (combine' x y)-- combine' :: GivesPopper () -> GivesPopper () -> GivesPopper ()- combine' x y f = x $ \x' -> y $ \y' -> combine'' x' y' f-- combine'' :: Popper -> Popper -> NeedsPopper () -> IO ()- combine'' x y f = do- istate <- newIORef $ Left (x, y)- f $ go istate-- go istate = do- state <- readIORef istate- case state of- Left (x, y) -> do- bs <- x- if S.null bs- then do- writeIORef istate $ Right y- y- else return bs- Right y -> y--simplify :: RequestBody -> Either (Int64, Builder) (Maybe Int64, GivesPopper ())-simplify (RequestBodyLBS lbs) = Left (L.length lbs, fromLazyByteString lbs)-simplify (RequestBodyBS bs) = Left (fromIntegral $ S.length bs, fromByteString bs)-simplify (RequestBodyBuilder len b) = Left (len, b)-simplify (RequestBodyStream i gp) = Right (Just i, gp)-simplify (RequestBodyStreamChunked gp) = Right (Nothing, gp)--builderToStream :: (Int64, Builder) -> (Maybe Int64, GivesPopper ())-builderToStream (len, builder) =- (Just len, gp)- where- gp np = do- ibss <- newIORef $ L.toChunks $ toLazyByteString builder- np $ do- bss <- readIORef ibss- case bss of- [] -> return S.empty- bs:bss' -> do- writeIORef ibss bss'- return bs--type Popper = IO S.ByteString-type NeedsPopper a = Popper -> IO a-type GivesPopper a = NeedsPopper a -> IO a---- | All information on how to connect to a host and what should be sent in the--- HTTP request.------ If you simply wish to download from a URL, see 'parseUrl'.------ The constructor for this data type is not exposed. Instead, you should use--- either the 'def' method to retrieve a default instance, or 'parseUrl' to--- construct from a URL, and then use the records below to make modifications.--- This approach allows http-conduit to add configuration options without--- breaking backwards compatibility.------ For example, to construct a POST request, you could do something like:------ > initReq <- parseUrl "http://www.example.com/path"--- > let req = initReq--- > { method = "POST"--- > }------ For more information, please see--- <http://www.yesodweb.com/book/settings-types>.-data Request = Request- { method :: Method- -- ^ HTTP request method, eg GET, POST.- , secure :: Bool- -- ^ Whether to use HTTPS (ie, SSL).- , host :: S.ByteString- , port :: Int- , path :: S.ByteString- -- ^ Everything from the host to the query string.- , queryString :: S.ByteString- , requestHeaders :: RequestHeaders- -- ^ Custom HTTP request headers- --- -- As already stated in the introduction, the Content-Length and Host- -- headers are set automatically by this module, and shall not be added to- -- requestHeaders.- --- -- Moreover, the Accept-Encoding header is set implicitly to gzip for- -- convenience by default. This behaviour can be overridden if needed, by- -- setting the header explicitly to a different value. In order to omit the- -- Accept-Header altogether, set it to the empty string \"\". If you need an- -- empty Accept-Header (i.e. requesting the identity encoding), set it to a- -- non-empty white-space string, e.g. \" \". See RFC 2616 section 14.3 for- -- details about the semantics of the Accept-Header field. If you request a- -- content-encoding not supported by this module, you will have to decode- -- it yourself (see also the 'decompress' field).- --- -- Note: Multiple header fields with the same field-name will result in- -- multiple header fields being sent and therefore it\'s the responsibility- -- of the client code to ensure that the rules from RFC 2616 section 4.2- -- are honoured.- , requestBody :: RequestBody- , proxy :: Maybe Proxy- -- ^ Optional HTTP proxy.- , hostAddress :: Maybe HostAddress- -- ^ Optional resolved host address.- --- -- Since 1.8.9- , rawBody :: Bool- -- ^ If @True@, a chunked and\/or gzipped body will not be- -- decoded. Use with caution.- , decompress :: ContentType -> Bool- -- ^ Predicate to specify whether gzipped data should be- -- decompressed on the fly (see 'alwaysDecompress' and- -- 'browserDecompress'). Default: browserDecompress.- , redirectCount :: Int- -- ^ How many redirects to follow when getting a resource. 0 means follow- -- no redirects. Default value: 10.- , checkStatus :: Status -> ResponseHeaders -> CookieJar -> Maybe SomeException- -- ^ Check the status code. Note that this will run after all redirects are- -- performed. Default: return a @StatusCodeException@ on non-2XX responses.- , responseTimeout :: Maybe Int- -- ^ Number of microseconds to wait for a response. If @Nothing@, will wait- -- indefinitely. Default: 5 seconds.- , getConnectionWrapper :: Maybe Int- -> HttpException- -> IO (ConnRelease, Connection, ManagedConn)- -> IO (Maybe Int, (ConnRelease, Connection, ManagedConn))- -- ^ Wraps the calls for getting new connections. This can be useful for- -- instituting some kind of timeouts. The first argument is the value of- -- @responseTimeout@. Second argument is the exception to be thrown on- -- failure.- --- -- Default: If @responseTimeout@ is @Nothing@, does nothing. Otherwise,- -- institutes timeout, and returns remaining time for @responseTimeout@.- --- -- Since 1.8.8- , cookieJar :: Maybe CookieJar- -- ^ A user-defined cookie jar.- -- If 'Nothing', no cookie handling will take place, \"Cookie\" headers- -- in 'requestHeaders' will be sent raw, and 'responseCookieJar' will be- -- empty.- --- -- Since 1.9.0- }--type ContentType = S.ByteString--data ConnReuse = Reuse | DontReuse--type ConnRelease = ConnReuse -> IO ()--data ManagedConn = Fresh | Reused---- | A simple representation of the HTTP response created by 'lbsConsumer'.-data Response body = Response- { responseStatus :: !Status- -- ^ Status code of the response.- , responseVersion :: !HttpVersion- -- ^ HTTP version used by the server.- , responseHeaders :: !ResponseHeaders- -- ^ Response headers sent by the server.- , responseBody :: !body- -- ^ Response body sent by the server.- , responseCookieJar :: !CookieJar- -- ^ Cookies set on the client after interacting with the server. If- -- cookies have been disabled by setting 'cookieJar' to @Nothing@, then- -- this will always be empty.- , responseClose' :: !ResponseClose- -- ^ Releases any resource held by this response. If the response body- -- has not been fully read yet, doing so after this call will likely- -- be impossible.- }- deriving (Show, Eq, Typeable, Functor)--responseClose :: Response a -> IO ()-responseClose = runResponseClose . responseClose'--newtype ResponseClose = ResponseClose { runResponseClose :: IO () }- deriving Typeable-instance Show ResponseClose where- show _ = "ResponseClose"-instance Eq ResponseClose where- _ == _ = True
− src/Network/HTTP/Client/Util.hs
@@ -1,84 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-module Network.HTTP.Client.Util- ( hGetSome- , (<>)- , readDec- , hasNoBody- , fromStrict- ) where--import Data.Monoid (Monoid, mappend)--import qualified Data.ByteString.Char8 as S8-#if MIN_VERSION_bytestring(0,10,0)-import Data.ByteString.Lazy (fromStrict)-#else-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as S-#endif--import qualified Data.Text as T-import qualified Data.Text.Read--#if MIN_VERSION_base(4,3,0)-import Data.ByteString (hGetSome)-#else-import GHC.IO.Handle.Types-import System.IO (hWaitForInput, hIsEOF)-import System.IO.Error (mkIOError, illegalOperationErrorType)---- | Like 'hGet', except that a shorter 'ByteString' may be returned--- if there are not enough bytes immediately available to satisfy the--- whole request. 'hGetSome' only blocks if there is no data--- available, and EOF has not yet been reached.-hGetSome :: Handle -> Int -> IO S.ByteString-hGetSome hh i- | i > 0 = let- loop = do- s <- S.hGetNonBlocking hh i- if not (S.null s)- then return s- else do eof <- hIsEOF hh- if eof then return s- else hWaitForInput hh (-1) >> loop- -- for this to work correctly, the- -- Handle should be in binary mode- -- (see GHC ticket #3808)- in loop- | i == 0 = return S.empty- | otherwise = illegalBufferSize hh "hGetSome" i--illegalBufferSize :: Handle -> String -> Int -> IO a-illegalBufferSize handle fn sz =- ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing)- --TODO: System.IO uses InvalidArgument here, but it's not exported :-(- where- msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz []-#endif--infixr 5 <>-(<>) :: Monoid m => m -> m -> m-(<>) = mappend--readDec :: Integral i => String -> Maybe i-readDec s =- case Data.Text.Read.decimal $ T.pack s of- Right (i, t)- | T.null t -> Just i- _ -> Nothing--hasNoBody :: S8.ByteString -- ^ request method- -> Int -- ^ status code- -> Bool-hasNoBody "HEAD" _ = True-hasNoBody _ 204 = True-hasNoBody _ 304 = True-hasNoBody _ i = 100 <= i && i < 200--#if !MIN_VERSION_bytestring(0,10,0)-{-# INLINE fromStrict #-}-fromStrict :: S.ByteString -> L.ByteString-fromStrict x = L.fromChunks [x]-#endif
test/Network/HTTP/Client/BodySpec.hs view
@@ -2,8 +2,8 @@ module Network.HTTP.Client.BodySpec where import Test.Hspec-import Network.HTTP.Client.Body-import Network.HTTP.Client.Connection+import Network.HTTP.Client+import Network.HTTP.Client.Internal import qualified Data.ByteString as S import Codec.Compression.GZip (compress) import qualified Data.ByteString.Lazy as L
test/Network/HTTP/Client/HeadersSpec.hs view
@@ -1,9 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Client.HeadersSpec where -import Network.HTTP.Client.Connection-import Network.HTTP.Client.Headers-import Network.HTTP.Client.Types+import Network.HTTP.Client+import Network.HTTP.Client.Internal import Network.HTTP.Types import Test.Hspec
test/Network/HTTP/Client/ResponseSpec.hs view
@@ -3,10 +3,8 @@ module Network.HTTP.Client.ResponseSpec where import Test.Hspec-import Network.HTTP.Client.Request-import Network.HTTP.Client.Response-import Network.HTTP.Client.Connection-import Network.HTTP.Client.Body+import Network.HTTP.Client+import Network.HTTP.Client.Internal import Network.HTTP.Types import Codec.Compression.GZip (compress) import qualified Data.ByteString.Lazy as L
test/Network/HTTP/ClientSpec.hs view
@@ -1,12 +1,8 @@-{-# LANGUAGE RecordWildCards #-} module Network.HTTP.ClientSpec where import Data.Default import Network.HTTP.Client-import Network.HTTP.Client.Manager-import Network.HTTP.Client.Request-import Network.HTTP.Client.Types-import Network.HTTP.Types+import Network.HTTP.Types (status200) import Test.Hspec main :: IO ()@@ -17,5 +13,5 @@ it "works" $ do req <- parseUrl "http://www.yesodweb.com/" man <- newManager defaultManagerSettings- Response {..} <- httpLbs req man- responseStatus `shouldBe` status200+ res <- httpLbs req man+ responseStatus res `shouldBe` status200