http-client 0.4.31.2 → 0.5.0
raw patch · 22 files changed
+501/−493 lines, 22 filesdep −data-default-classdep ~bytestring
Dependencies removed: data-default-class
Dependency ranges changed: bytestring
Files
- ChangeLog.md +9/−7
- Network/HTTP/Client.hs +41/−10
- Network/HTTP/Client/Body.hs +20/−20
- Network/HTTP/Client/Connection.hs +16/−21
- Network/HTTP/Client/Cookies.hs +1/−3
- Network/HTTP/Client/Core.hs +50/−78
- Network/HTTP/Client/Headers.hs +9/−12
- Network/HTTP/Client/Manager.hs +37/−52
- Network/HTTP/Client/MultipartFormData.hs +2/−2
- Network/HTTP/Client/Request.hs +47/−92
- Network/HTTP/Client/Response.hs +2/−8
- Network/HTTP/Client/Types.hs +178/−78
- Network/HTTP/Client/Util.hs +2/−10
- http-client.cabal +2/−3
- publicsuffixlist/Network/PublicSuffixList/Serialize.hs +2/−2
- test-nonet/Network/HTTP/Client/BodySpec.hs +2/−2
- test-nonet/Network/HTTP/Client/CookieSpec.hs +0/−1
- test-nonet/Network/HTTP/Client/RequestBodySpec.hs +4/−4
- test-nonet/Network/HTTP/Client/RequestSpec.hs +11/−13
- test-nonet/Network/HTTP/Client/ResponseSpec.hs +1/−1
- test-nonet/Network/HTTP/ClientSpec.hs +50/−45
- test/Network/HTTP/ClientSpec.hs +15/−29
ChangeLog.md view
@@ -1,11 +1,13 @@-## 0.4.31.2--* Use redirectCount set through managerModifyRequest [#244](https://github.com/snoyberg/http-client/pull/244)--## 0.4.31.1+## 0.5.0 -* The closeConnection method for tls connections should not be called multiple- times [#225](https://github.com/snoyberg/http-client/issues/225)+* Remove `instance Default Request`+* Modify `instance IsString Request` to use `parseRequest` instead of `parseUrlThrow`+* Clean up the `HttpException` constructors+* Rename `checkStatus` to `checkResponse` and modify type+* Fix the ugly magic constant workaround for responseTimeout+* Remove `getConnectionWrapper`+* Add the `HttpExceptionRequest` wrapper so that all exceptions related to a+ request are thrown with that request's information ## 0.4.31
Network/HTTP/Client.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}@@ -111,7 +111,7 @@ , managerTlsConnection , managerResponseTimeout , managerRetryableException- , managerWrapIOException+ , managerWrapException , managerIdleConnectionCount , managerModifyRequest -- *** Manager proxy settings@@ -125,6 +125,11 @@ , proxyEnvironment , proxyEnvironmentNamed , defaultProxy+ -- *** Response timeouts+ , ResponseTimeout+ , responseTimeoutMicro+ , responseTimeoutNone+ , responseTimeoutDefault -- *** Helpers , rawConnectionModifySocket -- * Request@@ -153,7 +158,7 @@ , applyBasicProxyAuth , decompress , redirectCount- , checkStatus+ , checkResponse , responseTimeout , cookieJar , requestVersion@@ -179,6 +184,7 @@ , brConsume -- * Misc , HttpException (..)+ , HttpExceptionContent (..) , Cookie (..) , CookieJar , Proxy (..)@@ -194,7 +200,6 @@ import Network.HTTP.Client.Response import Network.HTTP.Client.Types -import Data.Text (Text) import Data.IORef (newIORef, writeIORef, readIORef, modifyIORef) import qualified Data.ByteString.Lazy as L import Data.Foldable (Foldable)@@ -202,7 +207,7 @@ import Network.HTTP.Types (statusCode) import GHC.Generics (Generic) import Data.Typeable (Typeable)-import Control.Exception (bracket)+import Control.Exception (bracket, handle, throwIO) -- | A datatype holding information on redirected requests and the final response. --@@ -222,7 +227,7 @@ -- -- Since 0.4.1 }- deriving (Functor, Traversable, Foldable, Show, Typeable, Generic)+ deriving (Functor, Data.Traversable.Traversable, Data.Foldable.Foldable, Show, Typeable, Generic) -- | A variant of @responseOpen@ which keeps a history of all redirects -- performed in the interim, together with the first 1024 bytes of their@@ -230,12 +235,15 @@ -- -- Since 0.4.1 responseOpenHistory :: Request -> Manager -> IO (HistoriedResponse BodyReader)-responseOpenHistory req0 man = do+responseOpenHistory req0 man = handle (throwIO . toHttpException req0) $ do reqRef <- newIORef req0 historyRef <- newIORef id- let go req0 = do- (man, req) <- getModifiedRequestManager man req0- (req', res) <- httpRaw' req man+ let go req = do+ (req', res') <- httpRaw' req man+ let res = res'+ { responseBody = handle (throwIO . toHttpException req0)+ (responseBody res')+ } case getRedirectedRequest req' (responseHeaders res)@@ -329,3 +337,26 @@ -- > putStrLn $ "The status code was: " ++ (show $ statusCode $ responseStatus response) -- > print $ responseBody response --+++-- | Specify a response timeout in microseconds+--+-- @since 0.5.0+responseTimeoutMicro :: Int -> ResponseTimeout+responseTimeoutMicro = ResponseTimeoutMicro++-- | Do not have a response timeout+--+-- @since 0.5.0+responseTimeoutNone :: ResponseTimeout+responseTimeoutNone = ResponseTimeoutNone++-- | Use the default response timeout+--+-- When used on a 'Request', means: use the manager's timeout value+--+-- When used on a 'ManagerSettings', means: default to 30 seconds+--+-- @since 0.5.0+responseTimeoutDefault :: ResponseTimeout+responseTimeoutDefault = ResponseTimeoutDefault
Network/HTTP/Client/Body.hs view
@@ -14,8 +14,8 @@ import Network.HTTP.Client.Connection import Network.HTTP.Client.Types-import Control.Exception (throwIO, assert)-import Data.ByteString (ByteString, empty, uncons)+import Control.Exception (assert)+import Data.ByteString (empty, uncons) import Data.IORef import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L@@ -38,23 +38,23 @@ -- -- Since 0.4.20 brReadSome :: BodyReader -> Int -> IO L.ByteString-brReadSome brRead =+brReadSome brRead' = loop id where- loop front rem- | rem <= 0 = return $ L.fromChunks $ front []+ loop front rem'+ | rem' <= 0 = return $ L.fromChunks $ front [] | otherwise = do- bs <- brRead+ bs <- brRead' if S.null bs then return $ L.fromChunks $ front []- else loop (front . (bs:)) (rem - S.length bs)+ else loop (front . (bs:)) (rem' - S.length bs) brEmpty :: BodyReader brEmpty = return S.empty brAddCleanup :: IO () -> BodyReader -> BodyReader-brAddCleanup cleanup brRead = do- bs <- brRead+brAddCleanup cleanup brRead' = do+ bs <- brRead' when (S.null bs) cleanup return bs @@ -62,17 +62,17 @@ -- -- Since 0.1.0 brConsume :: BodyReader -> IO [S.ByteString]-brConsume brRead =+brConsume brRead' = go id where go front = do- x <- brRead+ x <- brRead' if S.null x then return $ front [] else go (front . (x:)) makeGzipReader :: BodyReader -> IO BodyReader-makeGzipReader brRead = do+makeGzipReader brRead' = do inf <- Z.initInflate $ Z.WindowBits 31 istate <- newIORef Nothing let goPopper popper = do@@ -88,9 +88,9 @@ else do writeIORef istate Nothing return bs- Z.PRError e -> throwIO $ HttpZlibException e+ Z.PRError e -> throwHttp $ HttpZlibException e start = do- bs <- brRead+ bs <- brRead' if S.null bs then return S.empty else do@@ -119,7 +119,7 @@ then return empty else do bs <- connectionRead- when (S.null bs) $ throwIO $ ResponseBodyTooShort (fromIntegral count0) (fromIntegral $ count0 - count)+ when (S.null bs) $ throwHttp $ ResponseBodyTooShort (fromIntegral count0) (fromIntegral $ count0 - count) case compare count $ S.length bs of LT -> do let (x, y) = S.splitAt count bs@@ -162,7 +162,7 @@ readChunk 0 = return (empty, 0) readChunk remainder = do bs <- connectionRead- when (S.null bs) $ throwIO InvalidChunkHeaders+ when (S.null bs) $ throwHttp InvalidChunkHeaders case compare remainder $ S.length bs of LT -> do let (x, y) = S.splitAt remainder bs@@ -180,12 +180,12 @@ requireNewline = do bs <- connectionReadLine conn- unless (S.null bs) $ throwIO InvalidChunkHeaders+ unless (S.null bs) $ throwHttp InvalidChunkHeaders readHeader = do bs <- connectionReadLine conn case parseHex bs of- Nothing -> throwIO InvalidChunkHeaders+ Nothing -> throwHttp InvalidChunkHeaders Just hex -> return (bs `S.append` "\r\n", hex) parseHex bs0 =@@ -195,8 +195,8 @@ _ -> Nothing parseHex' i bs = case uncons bs of- Just (w, bs)- | Just i' <- toI w -> parseHex' (i * 16 + i') bs+ Just (w, bs')+ | Just i' <- toI w -> parseHex' (i * 16 + i') bs' _ -> i toI w
Network/HTTP/Client/Connection.hs view
@@ -14,7 +14,6 @@ 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@@ -27,7 +26,7 @@ connectionReadLine :: Connection -> IO ByteString connectionReadLine conn = do bs <- connectionRead conn- when (S.null bs) $ throwIO IncompleteHeaders+ when (S.null bs) $ throwHttp IncompleteHeaders connectionReadLineWith conn bs -- | Keep dropping input until a blank line is found.@@ -44,9 +43,9 @@ case S.break (== charLF) bs of (_, "") -> do let total' = total + S.length bs- when (total' > 4096) $ throwIO OverlongHeaders+ when (total' > 4096) $ throwHttp OverlongHeaders bs' <- connectionRead conn- when (S.null bs') $ throwIO IncompleteHeaders+ when (S.null bs') $ throwHttp IncompleteHeaders go bs' (front . (bs:)) total' (x, S.drop 1 -> y) -> do unless (S.null y) $! connectionUnread conn y@@ -90,17 +89,11 @@ -- already closed connection. closedVar <- newIORef False - let close = do- closed <- atomicModifyIORef closedVar (\closed -> (True, closed))- unless closed $- c-- _ <- mkWeakIORef istack close+ _ <- mkWeakIORef istack c return $! Connection { connectionRead = do closed <- readIORef closedVar- when closed $- throwIO ConnectionClosed+ when closed $ throwHttp ConnectionClosed join $ atomicModifyIORef istack $ \stack -> case stack of x:xs -> (xs, return x)@@ -108,17 +101,19 @@ , connectionUnread = \x -> do closed <- readIORef closedVar- when closed $- throwIO ConnectionClosed+ when closed $ throwHttp ConnectionClosed atomicModifyIORef istack $ \stack -> (x:stack, ()) , connectionWrite = \x -> do closed <- readIORef closedVar- when closed $- throwIO ConnectionClosed+ when closed $ throwHttp ConnectionClosed w x - , connectionClose = close+ , connectionClose = do+ closed <- readIORef closedVar+ unless closed $+ c+ writeIORef closedVar True } socketConnection :: Socket -> Int -> IO Connection@@ -140,14 +135,14 @@ -> String -- ^ host -> Int -- ^ port -> IO Connection-openSocketConnectionSize tweakSocket chunksize hostAddress host port = do+openSocketConnectionSize tweakSocket chunksize hostAddress' host' port' = do let hints = NS.defaultHints { NS.addrFlags = [NS.AI_ADDRCONFIG] , NS.addrSocketType = NS.Stream }- addrs <- case hostAddress of+ addrs <- case hostAddress' of Nothing ->- NS.getAddrInfo (Just hints) (Just host) (Just $ show port)+ NS.getAddrInfo (Just hints) (Just host') (Just $ show port') Just ha -> return [NS.AddrInfo@@ -155,7 +150,7 @@ , NS.addrFamily = NS.AF_INET , NS.addrSocketType = NS.Stream , NS.addrProtocol = 6 -- tcp- , NS.addrAddress = NS.SockAddrInet (toEnum port) ha+ , NS.addrAddress = NS.SockAddrInet (toEnum port') ha , NS.addrCanonName = Nothing }]
Network/HTTP/Client/Cookies.hs view
@@ -30,8 +30,6 @@ 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@@ -39,7 +37,7 @@ isIpAddress :: BS.ByteString -> Bool isIpAddress =- go 4+ go (4 :: Int) where go 0 bs = BS.null bs go rest bs =
Network/HTTP/Client/Core.hs view
@@ -7,10 +7,8 @@ , httpNoBody , httpRaw , httpRaw'- , getModifiedRequestManager , responseOpen , responseClose- , applyCheckStatus , httpRedirect , httpRedirect' ) where@@ -18,21 +16,20 @@ #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif-import Network.HTTP.Client.Body-import Network.HTTP.Client.Cookies+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.Types-import Network.HTTP.Types+import Network.HTTP.Client.Cookies import Data.Maybe (fromMaybe, isJust) 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)+import System.Timeout (timeout) -- | Perform a @Request@ using a connection acquired from the given @Manager@, -- and then provide the @Response@ to the given function. This function is@@ -83,22 +80,20 @@ -- | Get a 'Response' without any redirect following. ----- This extended version of 'httpRaw' also returns the potentially modified Request.+-- This extended version of 'httpRaw' also returns the Request potentially modified by @managerModifyRequest@. httpRaw' :: Request -> Manager -> IO (Request, Response BodyReader) httpRaw' req0 m = do- let req' = mSetProxy m req0+ req' <- mModifyRequest m $ mSetProxy m req0 (req, cookie_jar') <- case cookieJar req' of Just cj -> do now <- getCurrentTime return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now- Nothing -> return (req', mempty)+ Nothing -> return (req', Data.Monoid.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,@@ -126,25 +121,31 @@ return (req, res {responseCookieJar = cookie_jar}) Nothing -> return (req, res) where-- responseTimeout' req- | rt == useDefaultTimeout = mResponseTimeout m- | otherwise = rt- where- rt = responseTimeout req+ getConnectionWrapper mtimeout f =+ case mtimeout of+ Nothing -> fmap ((,) Nothing) f+ Just timeout' -> do+ before <- getCurrentTime+ mres <- timeout timeout' f+ case mres of+ Nothing -> throwHttp ConnectionTimeout+ Just res -> do+ now <- getCurrentTime+ let timeSpentMicro = diffUTCTime now before * 1000000+ remainingTime = round $ fromIntegral timeout' - timeSpentMicro+ if remainingTime <= 0+ then throwHttp ConnectionTimeout+ else return (Just remainingTime, res) --- | The used Manager can be overridden (by requestManagerOverride) and the used--- Request can be modified (through managerModifyRequest). This function allows--- to retrieve the possibly overridden Manager and the possibly modified--- Request.------ (In case the Manager is overridden by requestManagerOverride, the Request is--- being modified by managerModifyRequest of the new Manager, not the old one.)-getModifiedRequestManager :: Manager -> Request -> IO (Manager, Request)-getModifiedRequestManager manager0 req0 = do- let manager = fromMaybe manager0 (requestManagerOverride req0)- req <- mModifyRequest manager req0- return (manager, req)+ responseTimeout' req =+ case responseTimeout req of+ ResponseTimeoutDefault ->+ case mResponseTimeout m of+ ResponseTimeoutDefault -> Just 30000000+ ResponseTimeoutNone -> Nothing+ ResponseTimeoutMicro u -> Just u+ ResponseTimeoutNone -> Nothing+ ResponseTimeoutMicro u -> Just u -- | The most low-level function for initiating an HTTP request. --@@ -176,64 +177,27 @@ -- -- Since 0.1.0 responseOpen :: Request -> Manager -> IO (Response BodyReader)-responseOpen req0 manager' = handle addTlsHostPort $ mWrapIOException manager $ do+responseOpen req0 manager' = wrapExc $ mWrapException manager req0 $ do (req, res) <- if redirectCount req0 == 0 then httpRaw' req0 manager else go (redirectCount req0) req0- maybe (return res) throwIO =<< applyCheckStatus req (checkStatus req) res+ checkResponse req req res+ return res+ { responseBody = wrapExc (responseBody res)+ } where+ wrapExc = handle $ throwIO . toHttpException req0 manager = fromMaybe manager' (requestManagerOverride req0) - addTlsHostPort (TlsException e) = throwIO $ TlsExceptionHostPort e (host req0) (port req0)- addTlsHostPort e = throwIO e- go count req' = httpRedirect' count (\req -> do- (manager, modReq) <- getModifiedRequestManager manager req- (req'', res) <- httpRaw' modReq manager- let mreq = if redirectCount modReq == 0- then Nothing- else getRedirectedRequest req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res))+ (req'', res) <- httpRaw' req manager+ let mreq = getRedirectedRequest req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) return (res, fromMaybe req'' mreq, isJust mreq)) req' --- | Apply 'Request'\'s 'checkStatus' and return resulting exception if any.-applyCheckStatus- :: Request- -> (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException)- -> Response BodyReader- -> IO (Maybe SomeException)-applyCheckStatus req 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)- , ("X-Request-URL", S.concat- [ method req- , " "- , S8.pack $ show $ getUri req- ])- ]) cookie_jar- _ -> return exc- responseClose res- return (Just exc')- where-#ifndef MIN_VERSION_bytestring-#define MIN_VERSION_bytestring(x,y,z) 1-#endif-#if MIN_VERSION_bytestring(0,10,0)- toStrict' = L.toStrict-#else- toStrict' = S.concat . L.toChunks-#endif- -- | Redirect loop. httpRedirect :: Int -- ^ 'redirectCount'@@ -257,7 +221,7 @@ -> IO (Request, Response BodyReader) httpRedirect' count0 http' req0 = go count0 req0 [] where- go count _ ress | count < 0 = throwIO $ TooManyRedirects ress+ go count _ ress | count < 0 = throwHttp $ TooManyRedirects ress go count req' ress = do (res, req, isRedirect) <- http' req' if isRedirect then do@@ -270,7 +234,15 @@ -- The connection may already be closed, e.g. -- when using withResponseHistory. See -- https://github.com/snoyberg/http-client/issues/169- `catch` \(_ :: ConnectionClosed) -> return L.empty+ `catch` \se ->+ case () of+ ()+ | Just ConnectionClosed <-+ fmap unHttpExceptionContentWrapper+ (fromException se) -> return L.empty+ | Just (HttpExceptionRequest _ ConnectionClosed) <-+ fromException se -> return L.empty+ _ -> throwIO se responseClose res -- And now perform the actual redirect
Network/HTTP/Client/Headers.hs view
@@ -5,8 +5,7 @@ ( parseStatusHeaders ) where -import Control.Applicative ((<$>), (<*>))-import Control.Exception (throwIO)+import Control.Applicative as A ((<$>), (<*>)) import Control.Monad import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8@@ -17,9 +16,7 @@ import Network.HTTP.Types import Data.Word (Word8) -charLF, charCR, charSpace, charColon, charPeriod :: Word8-charLF = 10-charCR = 13+charSpace, charColon, charPeriod :: Word8 charSpace = 32 charColon = 58 charPeriod = 46@@ -32,7 +29,7 @@ where withTimeout = case timeout' of Nothing -> id- Just t -> timeout t >=> maybe (throwIO ResponseTimeout) return+ Just t -> timeout t >=> maybe (throwHttp ResponseTimeout) return getStatus = withTimeout next where@@ -48,14 +45,14 @@ (s, v) <- nextStatusLine if statusCode s == 100 then connectionDropTillBlankLine conn >> return Nothing- else Just . StatusHeaders s v <$> parseHeaders 0 id+ else Just . StatusHeaders s v A.<$> parseHeaders (0 :: Int) id nextStatusLine :: IO (Status, HttpVersion) nextStatusLine = 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+ when (S.null bs) $ throwHttp NoResponseDataReceived connectionReadLineWith conn bs >>= parseStatus 3 parseStatus :: Int -> S.ByteString -> IO (Status, HttpVersion)@@ -64,9 +61,9 @@ let (ver, bs2) = S.break (== charSpace) bs (code, bs3) = S.break (== charSpace) $ S.dropWhile (== charSpace) bs2 msg = S.dropWhile (== charSpace) bs3- case (,) <$> parseVersion ver <*> readInt code of+ case (,) <$> parseVersion ver A.<*> readInt code of Just (ver', code') -> return (Status code' msg, ver')- Nothing -> throwIO $ InvalidStatusLine bs+ Nothing -> throwHttp $ InvalidStatusLine bs stripPrefixBS x y | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y@@ -81,7 +78,7 @@ Just (i, "") -> Just i _ -> Nothing - parseHeaders 100 _ = throwIO OverlongHeaders+ parseHeaders 100 _ = throwHttp OverlongHeaders parseHeaders count front = do line <- connectionReadLine conn if S.null line@@ -93,7 +90,7 @@ parseHeader :: S.ByteString -> IO Header parseHeader bs = do let (key, bs2) = S.break (== charColon) bs- when (S.null bs2) $ throwIO $ InvalidHeader bs+ when (S.null bs2) $ throwHttp $ InvalidHeader bs return (CI.mk $! strip key, strip $! S.drop 1 bs2) strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace)
Network/HTTP/Client/Manager.hs view
@@ -10,7 +10,6 @@ , closeManager , withManager , getConn- , failedConnectionException , defaultManagerSettings , rawConnectionModifySocket , proxyFromRequest@@ -30,32 +29,23 @@ #endif import Control.Applicative ((<|>)) import Control.Arrow (first)-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.Char (toLower) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Read (decimal) -import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad (unless, join, when, void, mplus)-import Control.Exception (mask_, SomeException, bracket, catch, throwIO, fromException, mask, IOException, Exception (..), handle)+import Control.Monad (unless, join, void)+import Control.Exception (mask_, 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 Data.Time (UTCTime (..), getCurrentTime, addUTCTime) import qualified Network.Socket as NS -import Data.Maybe (mapMaybe)-import System.IO (Handle) import System.Mem.Weak (Weak, deRefWeak) import Network.HTTP.Types (status200) import Network.HTTP.Client.Types@@ -76,12 +66,14 @@ -> IO (Maybe NS.HostAddress -> String -> Int -> IO Connection) rawConnectionModifySocket = return . openSocketConnection +{- FIXME was this intended to be exported? -- | Same as @rawConnectionModifySocket@, but also takes in a chunk size. -- -- Since 0.4.5 rawConnectionModifySocketSize :: (NS.Socket -> IO ()) -> IO (Int -> Maybe NS.HostAddress -> String -> Int -> IO Connection) rawConnectionModifySocketSize = return . openSocketConnectionSize+-} -- | Default value for @ManagerSettings@. --@@ -94,14 +86,14 @@ defaultManagerSettings = ManagerSettings { managerConnCount = 10 , managerRawConnection = return $ openSocketConnection (const $ return ())- , managerTlsConnection = return $ \_ _ _ -> throwIO TlsNotSupported- , managerTlsProxyConnection = return $ \_ _ _ _ _ _ -> throwIO TlsNotSupported- , managerResponseTimeout = Just 30000000+ , managerTlsConnection = return $ \_ _ _ -> throwHttp TlsNotSupported+ , managerTlsProxyConnection = return $ \_ _ _ _ _ _ -> throwHttp TlsNotSupported+ , managerResponseTimeout = ResponseTimeoutDefault , managerRetryableException = \e -> case fromException e of Just (_ :: IOException) -> True _ ->- case fromException e of+ case fmap unHttpExceptionContentWrapper $ 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@@ -110,12 +102,12 @@ Just NoResponseDataReceived -> True Just IncompleteHeaders -> True _ -> False- , managerWrapIOException =+ , managerWrapException = \_req -> let wrapper se = case fromException se of- Just e -> toException $ InternalIOException e- Nothing -> se- in handle $ throwIO . wrapper+ Just (_ :: IOException) -> throwHttp $ InternalException se+ Nothing -> throwIO se+ in handle wrapper , managerIdleConnectionCount = 512 , managerModifyRequest = return , managerProxyInsecure = defaultProxy@@ -199,7 +191,7 @@ , mTlsConnection = tlsConnection , mTlsProxyConnection = tlsProxyConnection , mRetryableException = managerRetryableException ms- , mWrapIOException = managerWrapIOException ms+ , mWrapException = managerWrapException ms , mIdleConnectionCount = managerIdleConnectionCount ms , mModifyRequest = managerModifyRequest ms , mSetProxy = \req ->@@ -252,6 +244,7 @@ Nothing -> keep Just x -> keep . ((connkey, x):) + {- FIXME why isn't this being used anymore? flushStaleCerts now = Map.fromList . mapMaybe flushStaleCerts' . Map.toList where@@ -283,6 +276,7 @@ seqDT :: DiffTime -> b -> b seqDT = seq+ -} neToList :: NonEmptyList a -> [(UTCTime, a)] neToList (One a t) = [(t, a)]@@ -318,7 +312,7 @@ !m <- I.atomicModifyIORef connsRef $ \x -> (ManagerClosed, x) case m of ManagerClosed -> return ()- ManagerOpen _ m -> mapM_ (nonEmptyMapM_ safeConnClose) $ Map.elems m+ ManagerOpen _ m' -> mapM_ (nonEmptyMapM_ safeConnClose) $ Map.elems m' -- | Create, use and close a 'Manager'. --@@ -369,24 +363,16 @@ I.writeIORef toReuseRef r releaseHelper - releaseHelper = mask $ \restore -> do+ releaseHelper = mask $ \restore' -> do wasReleased <- I.atomicModifyIORef wasReleasedRef $ \x -> (True, x) unless wasReleased $ do toReuse <- I.readIORef toReuseRef- restore $ case toReuse of+ restore' $ case toReuse of Reuse -> putSocket man key ci 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@@ -397,13 +383,13 @@ -- secure proxy. dropProxyAuthSecure :: Request -> Request dropProxyAuthSecure req- | secure req && useProxy = req+ | secure req && useProxy' = req { requestHeaders = filter (\(k, _) -> k /= "Proxy-Authorization") (requestHeaders req) } | otherwise = req where- (useProxy, _, _) = getConnDest req+ (useProxy', _, _) = getConnDest req getConn :: Request -> Manager@@ -411,29 +397,28 @@ getConn req m -- Stop Mac OS X from getting high: -- https://github.com/snoyberg/http-client/issues/40#issuecomment-39117909- | S8.null h = throwIO $ InvalidDestinationHost h+ | S8.null h = throwHttp $ InvalidDestinationHost h | otherwise = getManagedConn m (ConnKey connKeyHost connport (host req) (port req) (secure req)) $ wrapConnectExc $ go connaddr connhost connport where h = host req- (useProxy, connhost, connport) = getConnDest req+ (useProxy', connhost, connport) = getConnDest req (connaddr, connKeyHost) =- case (hostAddress req, useProxy) of+ case (hostAddress req, useProxy') of (Just ha, False) -> (Just ha, HostAddress ha) _ -> (Nothing, HostName $ T.pack connhost) wrapConnectExc = handle $ \e ->- throwIO $ FailedConnectionException2 connhost connport (secure req)- (toException (e :: IOException))+ throwHttp $ ConnectionFailure (toException (e :: IOException)) go =- case (secure req, useProxy) of+ case (secure req, useProxy') of (False, _) -> mRawConnection m (True, False) -> mTlsConnection m (True, True) -> let ultHost = host req ultPort = port req- proxyAuthorizationHeader = maybe "" (\h -> S8.concat ["Proxy-Authorization: ", h, "\r\n"]) . lookup "Proxy-Authorization" $ requestHeaders req+ proxyAuthorizationHeader = maybe "" (\h' -> S8.concat ["Proxy-Authorization: ", h', "\r\n"]) . lookup "Proxy-Authorization" $ requestHeaders req hostHeader = S8.concat ["Host: ", ultHost, (S8.pack $ show ultPort), "\r\n"] connstr = S8.concat [ "CONNECT "@@ -446,9 +431,9 @@ , "\r\n" ] parse conn = do- sh@(StatusHeaders status _ _) <- parseStatusHeaders conn Nothing Nothing+ StatusHeaders status _ _ <- parseStatusHeaders conn Nothing Nothing unless (status == status200) $- throwIO $ ProxyConnectException ultHost ultPort $ Right $ StatusCodeException status [] (CJ [])+ throwHttp $ ProxyConnectException ultHost ultPort status in mTlsProxyConnection m connstr parse (S8.unpack ultHost) -- | Get the proxy settings from the @Request@ itself.@@ -477,8 +462,8 @@ -- Since 0.4.7 proxyEnvironment :: Maybe Proxy -- ^ fallback if no environment set -> ProxyOverride-proxyEnvironment mp = ProxyOverride $ \secure ->- envHelper (envName secure) $ maybe EHNoProxy EHUseProxy mp+proxyEnvironment mp = ProxyOverride $ \secure' ->+ envHelper (envName secure') $ maybe EHNoProxy EHUseProxy mp envName :: Bool -- ^ secure? -> Text@@ -501,8 +486,8 @@ -- -- Since 0.4.7 defaultProxy :: ProxyOverride-defaultProxy = ProxyOverride $ \secure ->- envHelper (envName secure) EHFromRequest+defaultProxy = ProxyOverride $ \secure' ->+ envHelper (envName secure') EHFromRequest data EnvHelper = EHFromRequest | EHNoProxy@@ -518,7 +503,7 @@ Nothing -> return noEnvProxy Just "" -> return noEnvProxy Just str -> do- let invalid = throwIO $ InvalidProxyEnvironmentVariable name (T.pack str)+ let invalid = throwHttp $ InvalidProxyEnvironmentVariable name (T.pack str) (p, muserpass) <- maybe invalid return $ do uri <- case U.parseURI str of Just u | U.uriScheme u == "http:" -> return u@@ -530,7 +515,7 @@ guard $ null $ U.uriFragment uri auth <- U.uriAuthority uri- port <-+ port' <- case U.uriPort auth of "" -> Just 80 ':':rest ->@@ -539,7 +524,7 @@ _ -> Nothing _ -> Nothing - Just $ (Proxy (S8.pack $ U.uriRegName auth) port, extractBasicAuthInfo uri)+ Just $ (Proxy (S8.pack $ U.uriRegName auth) port', extractBasicAuthInfo uri) return $ \req -> if host req `hasDomainSuffixIn` noProxyDomains then noEnvProxy req@@ -554,4 +539,4 @@ domainSuffixes Nothing = [] domainSuffixes (Just "") = [] domainSuffixes (Just no_proxy) = [prefixed $ S8.dropWhile (== ' ') suffix | suffix <- S8.split ',' (S8.pack (map toLower no_proxy)), not (S8.null suffix)]- hasDomainSuffixIn host = any (`S8.isSuffixOf` prefixed (S8.map toLower host))+ hasDomainSuffixIn host' = any (`S8.isSuffixOf` prefixed (S8.map toLower host'))
Network/HTTP/Client/MultipartFormData.hs view
@@ -107,7 +107,7 @@ partBS :: Text -- ^ Name of the corresponding \<input\>. -> BS.ByteString -- ^ The body for this 'Part'. -> Part-partBS n b = Part n mempty mempty mempty $ return $ RequestBodyBS b+partBS n b = Part n Data.Monoid.mempty mempty mempty $ return $ RequestBodyBS b -- | Make a 'Part' whose content is a lazy 'BL.ByteString'. --@@ -225,7 +225,7 @@ <> cp "Content-Type: " <> cp ct _ -> mempty)- <> foldMap (\(k, v) ->+ <> Data.Foldable.foldMap (\(k, v) -> cp "\r\n" <> cp (CI.original k) <> cp ": "
Network/HTTP/Client/Request.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-}- {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.HTTP.Client.Request@@ -24,7 +23,6 @@ , urlEncodedBody , needsGunzip , requestBuilder- , useDefaultTimeout , setRequestIgnoreStatus , setQueryString , streamFile@@ -37,12 +35,10 @@ import Data.Monoid (mempty, mappend) import Data.String (IsString(..)) import Data.Char (toLower)-import Control.Applicative ((<$>))-import Control.Monad (when, unless, guard)+import Control.Applicative as A ((<$>))+import Control.Monad (unless, guard) import Numeric (showHex) -import Data.Default.Class (Default (def))- import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteStringIO, flush) import Blaze.ByteString.Builder.Char8 (fromChar, fromShow) @@ -52,22 +48,18 @@ import Data.ByteString.Lazy.Internal (defaultChunkSize) import qualified Network.HTTP.Types as W-import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, unEscapeString, isAllowedInURI, isReserved)+import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, unEscapeString, isAllowedInURI) -import Control.Monad.IO.Class (liftIO)-import Control.Exception (Exception, toException, throw, throwIO, IOException)+import Control.Exception (throw, throwIO, IOException) import qualified Control.Exception as E import qualified Data.CaseInsensitive as CI import qualified Data.ByteString.Base64 as B64 +import Network.HTTP.Client.Body import Network.HTTP.Client.Types import Network.HTTP.Client.Util-import Network.HTTP.Client.Connection -import Network.HTTP.Client.Util (readDec, (<>))-import Data.Time.Clock import Control.Monad.Catch (MonadThrow, throwM)-import Data.IORef import System.IO (withBinaryFile, hTell, hFileSize, Handle, IOMode (ReadMode)) import Control.Monad (liftM)@@ -85,22 +77,19 @@ -- -- @since 0.4.30 parseUrlThrow :: MonadThrow m => String -> m Request-parseUrlThrow s' =- case parseURI (encode s) of- Just uri -> liftM setMethod (setUri def uri)- Nothing -> throwM $ InvalidUrlException s "Invalid URL"+parseUrlThrow =+ liftM yesThrow . parseRequest where- encode = escapeURIString isAllowedInURI- (mmethod, s) =- case break (== ' ') s' of- (x, ' ':y) | all (\c -> 'A' <= c && c <= 'Z') x -> (Just x, y)- _ -> (Nothing, s')-- setMethod req =- case mmethod of- Nothing -> req- Just m -> req { method = S8.pack m }-+ yesThrow req = req+ { checkResponse = \_req res ->+ let W.Status sci _ = responseStatus res in+ if 200 <= sci && sci < 300+ then return ()+ else do+ chunk <- brReadSome (responseBody res) 1024+ let res' = fmap (const ()) res+ throwHttp $ StatusCodeException res' (L.toStrict chunk)+ } -- | Convert a URL into a 'Request'. --@@ -121,11 +110,22 @@ -- -- @since 0.4.30 parseRequest :: MonadThrow m => String -> m Request-parseRequest =- liftM noThrow . parseUrlThrow+parseRequest s' =+ case parseURI (encode s) of+ Just uri -> liftM setMethod (setUri defaultRequest uri)+ Nothing -> throwM $ InvalidUrlException s "Invalid URL" where- noThrow req = req { checkStatus = \_ _ _ -> Nothing }+ encode = escapeURIString isAllowedInURI+ (mmethod, s) =+ case break (== ' ') s' of+ (x, ' ':y) | all (\c -> 'A' <= c && c <= 'Z') x -> (Just x, y)+ _ -> (Nothing, s') + setMethod req =+ case mmethod of+ Nothing -> req+ Just m -> req { method = S8.pack m }+ -- | Same as 'parseRequest', but in the cases of a parse error -- generates an impure exception. Mostly useful for static strings which -- are known to be correctly formatted.@@ -178,7 +178,7 @@ -- Return Nothing when there is no auth info in URI. extractBasicAuthInfo :: URI -> Maybe (S8.ByteString, S8.ByteString) extractBasicAuthInfo uri = do- userInfo <- uriUserInfo <$> uriAuthority uri+ userInfo <- uriUserInfo A.<$> uriAuthority uri guard (':' `elem` userInfo) let (username, ':':password) = break (==':') . takeWhile (/='@') $ userInfo return (toLiteral username, toLiteral password)@@ -223,40 +223,11 @@ 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)- , " requestVersion = " ++ show (requestVersion 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)- -- | A default request value -- -- @since 0.4.30 defaultRequest :: Request-defaultRequest = def { checkStatus = \_ _ _ -> Nothing }--instance Default Request where- def = Request+defaultRequest = Request { host = "localhost" , port = 80 , secure = False@@ -270,27 +241,9 @@ , 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+ , checkResponse = \_ _ -> return ()+ , responseTimeout = ResponseTimeoutDefault+ , cookieJar = Just Data.Monoid.mempty , requestVersion = W.http11 , onRequestBodyException = \se -> case E.fromException se of@@ -299,11 +252,13 @@ , requestManagerOverride = Nothing } +-- | Parses a URL via 'parseRequest_'+--+-- /NOTE/: Prior to version 0.5.0, this instance used 'parseUrlThrow'+-- instead. instance IsString Request where- fromString s =- case parseUrl s of- Left e -> throw e- Right r -> r+ fromString = parseRequest_+ {-# INLINE fromString #-} -- | Always decompress a compressed stream. alwaysDecompress :: S.ByteString -> Bool@@ -384,7 +339,7 @@ expectContinue = Just "100-continue" == lookup "Expect" (requestHeaders req) checkBadSend f = f `E.catch` onRequestBodyException req writeBuilder = toByteStringIO connectionWrite- writeHeadersWith contentLength = writeBuilder . (builder contentLength `mappend`)+ writeHeadersWith contentLength = writeBuilder . (builder contentLength `Data.Monoid.mappend`) flushHeaders contentLength = writeHeadersWith contentLength flush toTriple (RequestBodyLBS lbs) = do@@ -420,16 +375,16 @@ toTriple (RequestBodyIO mbody) = mbody >>= toTriple writeStream mlen withStream =- withStream (loop 0) + withStream (loop 0) where loop !n stream = do bs <- stream if S.null bs- then case mlen of + then case mlen of -- If stream is chunked, no length argument Nothing -> connectionWrite "0\r\n\r\n" -- Not chunked - validate length argument- Just len -> unless (len == n) $ throwIO $ WrongRequestBodyStreamSize (fromIntegral len) (fromIntegral n)+ Just len -> unless (len == n) $ throwHttp $ WrongRequestBodyStreamSize (fromIntegral len) (fromIntegral n) else do connectionWrite $ if (isNothing mlen) -- Chunked@@ -515,7 +470,7 @@ -- -- @since 0.4.29 setRequestIgnoreStatus :: Request -> Request-setRequestIgnoreStatus req = req { checkStatus = \_ _ _ -> Nothing }+setRequestIgnoreStatus req = req { checkResponse = \_ _ -> return () } -- | Set the query string to the given key/value pairs. --
Network/HTTP/Client/Response.hs view
@@ -8,16 +8,10 @@ , lbsResponse ) where -import Control.Monad ((>=>), when)--import Control.Exception (throwIO)- import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L -import Data.Default.Class (def)--import Data.Maybe (isJust)+import Data.Monoid (mempty) import qualified Network.HTTP.Types as W import Network.URI (parseURIReference, escapeURIString, isAllowedInURI)@@ -122,6 +116,6 @@ , responseVersion = version , responseHeaders = hs , responseBody = body- , responseCookieJar = def+ , responseCookieJar = Data.Monoid.mempty , responseClose' = ResponseClose (cleanup False) }
Network/HTTP/Client/Types.hs view
@@ -7,8 +7,11 @@ ( BodyReader , Connection (..) , StatusHeaders (..)- , ConnectionClosed (..) , HttpException (..)+ , HttpExceptionContent (..)+ , unHttpExceptionContentWrapper+ , throwHttp+ , toHttpException , Cookie (..) , CookieJar (..) , Proxy (..)@@ -31,17 +34,17 @@ , ConnKey (..) , ProxyOverride (..) , StreamFileStatus (..)+ , ResponseTimeout (..) ) where import qualified Data.Typeable as T (Typeable) import Network.HTTP.Types-import Control.Exception (Exception, IOException, SomeException)+import Control.Exception (Exception, SomeException, throwIO) 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.Class import Data.Foldable (Foldable) import Data.Monoid import Data.String (IsString, fromString)@@ -85,40 +88,115 @@ data StatusHeaders = StatusHeaders Status HttpVersion RequestHeaders deriving (Show, Eq, Ord, T.Typeable) -data ConnectionClosed = ConnectionClosed- deriving (Eq, Show, T.Typeable)+-- | A newtype wrapper which is not exported from this library but is an+-- instance of @Exception@. This allows @HttpExceptionContent@ to be thrown+-- (via this wrapper), but users of the library can't accidentally try to catch+-- it (when they /should/ be trying to catch 'HttpException').+--+-- @since 0.5.0+newtype HttpExceptionContentWrapper = HttpExceptionContentWrapper+ { unHttpExceptionContentWrapper :: HttpExceptionContent+ }+ deriving (Show, T.Typeable)+instance Exception HttpExceptionContentWrapper -instance Exception ConnectionClosed+throwHttp :: HttpExceptionContent -> IO a+throwHttp = throwIO . HttpExceptionContentWrapper -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+toHttpException :: Request -> HttpExceptionContentWrapper -> HttpException+toHttpException req (HttpExceptionContentWrapper e) = HttpExceptionRequest req e++-- | An exception which may be generated by this library+--+-- @since 0.5.0+data HttpException+ = HttpExceptionRequest Request HttpExceptionContent+ -- ^ Most exceptions are specific to a 'Request'. Inspect the+ -- 'HttpExceptionContent' value for details on what occurred.+ --+ -- @since 0.5.0+ | InvalidUrlException String String+ -- ^ A URL (first field) is invalid for a given reason+ -- (second argument).+ --+ -- @since 0.5.0+ deriving (Show, T.Typeable)+instance Exception HttpException++data HttpExceptionContent+ = StatusCodeException (Response ()) S.ByteString+ -- ^ Generated by the @parseUrlThrow@ function when the+ -- server returns a non-2XX response status code.+ --+ -- May include the beginning of the response body.+ --+ -- @since 0.5.0+ | TooManyRedirects [Response L.ByteString]+ -- ^ The server responded with too many redirects for a+ -- request.+ --+ -- Contains the list of encountered responses containing+ -- redirects in reverse chronological order; including last+ -- redirect, which triggered the exception and was not+ -- followed.+ --+ -- @since 0.5.0 | OverlongHeaders+ -- ^ Either too many headers, or too many total bytes in a+ -- single header, were returned by the server, and the+ -- memory exhaustion protection in this library has kicked+ -- in.+ --+ -- @since 0.5.0 | ResponseTimeout- | FailedConnectionException String Int- -- ^ host/port+ -- ^ The server took too long to return a response. This can+ -- be altered via 'responseTimeout' or+ -- 'managerResponseTimeout'. --- -- Note that in old versions of http-client and- -- http-conduit, this exception would indicate a failed- -- attempt to create a connection. However, since (at least)- -- http-client 0.4, it indicates a timeout occurred while- -- trying to establish the connection. For more information- -- on this, see:+ -- @since 0.5.0+ | ConnectionTimeout+ -- ^ Attempting to connect to the server timed out. --- -- <https://github.com/snoyberg/http-client/commit/b86b1cdd91e56ee33150433dedb32954d2082621#commitcomment-10718689>- | FailedConnectionException2 String Int Bool SomeException -- ^ host\/port\/secure- | ExpectedBlankAfter100Continue+ -- @since 0.5.0+ | ConnectionFailure SomeException+ -- ^ An exception occured when trying to connect to the+ -- server.+ --+ -- @since 0.5.0 | InvalidStatusLine S.ByteString+ -- ^ The status line returned by the server could not be parsed.+ --+ -- @since 0.5.0 | InvalidHeader S.ByteString- | InternalIOException IOException- | ProxyConnectException S.ByteString Int (Either S.ByteString HttpException) -- ^ host/port+ -- ^ The given response header line could not be parsed+ --+ -- @since 0.5.0+ | InternalException SomeException+ -- ^ An exception was raised by an underlying library when+ -- performing the request. Most often, this is caused by a+ -- failing socket action or a TLS exception.+ --+ -- @since 0.5.0+ | ProxyConnectException S.ByteString Int Status+ -- ^ A non-200 status code was returned when trying to+ -- connect to the proxy server on the given host and port.+ --+ -- @since 0.5.0 | NoResponseDataReceived- | TlsException SomeException+ -- ^ No response data was received from the server at all.+ -- This exception may deserve special handling within the+ -- library, since it may indicate that a pipelining has been+ -- used, and a connection thought to be open was in fact+ -- closed.+ --+ -- @since 0.5.0 | TlsNotSupported+ -- ^ Exception thrown when using a @Manager@ which does not+ -- have support for secure connections. Typically, you will+ -- want to use @tlsManagerSettings@ from @http-client-tls@+ -- to overcome this.+ --+ -- @since 0.5.0 | WrongRequestBodyStreamSize Word64 Word64 -- ^ The request body provided did not match the expected size. --@@ -126,36 +204,42 @@ -- -- @since 0.4.31 | ResponseBodyTooShort Word64 Word64- -- ^ Expected size/actual size.+ -- ^ The returned response body is too short. Provides the+ -- expected size and actual size. --- -- Since 1.9.4+ -- @since 0.5.0 | InvalidChunkHeaders- -- ^+ -- ^ A chunked response body had invalid headers. --- -- Since 1.9.4+ -- @since 0.5.0 | IncompleteHeaders+ -- ^ An incomplete set of response headers were returned.+ --+ -- @since 0.5.0 | InvalidDestinationHost S.ByteString+ -- ^ The host we tried to connect to is invalid (e.g., an+ -- empty string). | HttpZlibException ZlibException- -- ^+ -- ^ An exception was thrown when inflating a response body. --- -- Since 0.3+ -- @since 0.5.0 | InvalidProxyEnvironmentVariable Text Text- -- ^ Environment name and value- --- -- Since 0.4.7- | ResponseLengthAndChunkingBothUsed- -- ^ Detect a case where both the @content-length@ header- -- and @transfer-encoding: chunked@ are used. Since 0.4.8.+ -- ^ Values in the proxy environment variable were invalid.+ -- Provides the environment variable name and its value. --- -- Since 0.4.11 this exception isn't thrown anymore.- | TlsExceptionHostPort SomeException S.ByteString Int- -- ^ TLS exception, together with the host and port+ -- @since 0.5.0+ | ConnectionClosed+ -- ^ Attempted to use a 'Connection' which was already closed --- -- @since 0.4.24+ -- @since 0.5.0 deriving (Show, T.Typeable)-instance Exception HttpException +-- Purposely not providing this instance, since we don't want users to+-- accidentally try and catch these exceptions instead of HttpException+--+-- instance Exception HttpExceptionContent + -- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\" data Cookie = Cookie { cookie_name :: S.ByteString@@ -189,15 +273,12 @@ | 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+instance Data.Monoid.Monoid CookieJar where+ mempty = CJ [] (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@@ -277,6 +358,7 @@ simplify (RequestBodyBuilder len b) = Left (len, b) simplify (RequestBodyStream i gp) = Right (Just i, gp) simplify (RequestBodyStreamChunked gp) = Right (Nothing, gp)+simplify (RequestBodyIO _mbody) = error "FIXME No support for Monoid on RequestBodyIO" builderToStream :: (Int64, Builder) -> (Maybe Int64, GivesPopper ()) builderToStream (len, builder) =@@ -412,30 +494,21 @@ -- 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.+ , checkResponse :: Request -> Response BodyReader -> IO ()+ -- ^ Check the response immediately after receiving the status and headers.+ -- This can be useful for throwing exceptions on non-success status codes. --- -- Since 0.1.0- , responseTimeout :: Maybe Int+ -- In previous versions of http-client, this went under the name+ -- @checkStatus@, but was renamed to avoid confusion about the new default+ -- behavior (doing nothing).+ --+ -- @since 0.5.0+ , responseTimeout :: ResponseTimeout -- ^ Number of microseconds to wait for a response. If -- @Nothing@, will wait indefinitely. Default: use -- 'managerResponseTimeout' (which by default is 30 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@@ -467,6 +540,34 @@ } deriving T.Typeable +-- | How to deal with timing out a response+--+-- @since 0.5.0+data ResponseTimeout+ = ResponseTimeoutMicro !Int+ | ResponseTimeoutNone+ | ResponseTimeoutDefault+ deriving Show++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)+ , " requestVersion = " ++ show (requestVersion x)+ , "}"+ ]+ data ConnReuse = Reuse | DontReuse deriving T.Typeable @@ -507,7 +608,7 @@ -- -- Since 0.1.0 }- deriving (Show, Eq, T.Typeable, Functor, Foldable, Traversable)+ deriving (Show, Eq, T.Typeable, Functor, Data.Foldable.Foldable, Data.Traversable.Traversable) newtype ResponseClose = ResponseClose { runResponseClose :: IO () } deriving T.Typeable@@ -529,7 +630,6 @@ -- ^ Create an insecure connection. -- -- Since 0.1.0- -- FIXME in the future, combine managerTlsConnection and managerTlsProxyConnection , managerTlsConnection :: IO (Maybe NS.HostAddress -> String -> Int -> IO Connection) -- ^ Create a TLS connection. Default behavior: throw an exception that TLS is not supported. --@@ -538,13 +638,13 @@ -- ^ Create a TLS proxy connection. Default behavior: throw an exception that TLS is not supported. -- -- Since 0.2.2- , managerResponseTimeout :: Maybe Int- -- ^ Default timeout (in microseconds) to be applied to requests which do- -- not provide a timeout value.+ , managerResponseTimeout :: ResponseTimeout+ -- ^ Default timeout to be applied to requests which do not provide a+ -- timeout value. -- -- Default is 30 seconds --- -- Since 0.1.0+ -- @since 0.5.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@@ -552,13 +652,13 @@ -- new one. -- -- Since 0.1.0- , managerWrapIOException :: forall a. IO a -> IO a+ , managerWrapException :: forall a. Request -> 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.+ -- Default: wrap all @IOException@s in the @InternalException@ constructor. --- -- Since 0.1.0+ -- @since 0.5.0 , managerIdleConnectionCount :: Int -- ^ Total number of idle connection to keep open at a given time. --@@ -614,13 +714,13 @@ -- there are no connections to manage. , mMaxConns :: Int -- ^ This is a per-@ConnKey@ value.- , mResponseTimeout :: Maybe Int+ , mResponseTimeout :: ResponseTimeout -- ^ Copied from 'managerResponseTimeout' , mRawConnection :: Maybe NS.HostAddress -> String -> Int -> IO Connection , mTlsConnection :: Maybe NS.HostAddress -> String -> Int -> IO Connection , mTlsProxyConnection :: S.ByteString -> (Connection -> IO ()) -> String -> Maybe NS.HostAddress -> String -> Int -> IO Connection , mRetryableException :: SomeException -> Bool- , mWrapIOException :: forall a. IO a -> IO a+ , mWrapException :: forall a. Request -> IO a -> IO a , mIdleConnectionCount :: Int , mModifyRequest :: Request -> IO Request , mSetProxy :: Request -> Request
Network/HTTP/Client/Util.hs view
@@ -32,14 +32,6 @@ import qualified Data.Text.Read import System.Timeout (timeout) -import System.IO.Unsafe (unsafePerformIO)-import Control.Exception (mask_, Exception, throwTo, try, finally, SomeException, assert)-import Control.Monad (join, when, void)-import Control.Concurrent (myThreadId, threadDelay, forkIO)-import Data.IORef-import Data.Function (fix)-import Data.Typeable (Typeable)- #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif@@ -80,8 +72,8 @@ #endif infixr 5 <>-(<>) :: Monoid m => m -> m -> m-(<>) = mappend+(<>) :: Data.Monoid.Monoid m => m -> m -> m+(<>) = Data.Monoid.mappend readDec :: Integral i => String -> Maybe i readDec s =
http-client.cabal view
@@ -1,6 +1,6 @@ name: http-client-version: 0.4.31.2-synopsis: An HTTP client engine, intended as a base layer for more user-friendly packages.+version: 0.5.0+synopsis: An HTTP client engine description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/http-client>. homepage: https://github.com/snoyberg/http-client license: MIT@@ -40,7 +40,6 @@ , text >= 0.11 , http-types >= 0.8 , blaze-builder >= 0.3- , data-default-class , time >= 1.2 , network >= 2.3 , streaming-commons >= 0.1.0.2 && < 0.2
publicsuffixlist/Network/PublicSuffixList/Serialize.hs view
@@ -48,13 +48,13 @@ putTree = putMap . children putMap :: Map T.Text (Tree T.Text) -> Builder-putMap m = foldMap putPair (Map.toList m) `mappend` fromWord8 0+putMap m = Data.Foldable.foldMap putPair (Map.toList m) `mappend` fromWord8 0 putPair :: (T.Text, Tree T.Text) -> Builder putPair (x, y) = putText x `mappend` putTree y putText :: T.Text -> Builder-putText t = fromText t `mappend` fromWord8 0+putText t = fromText t `Data.Monoid.mappend` fromWord8 0 putDataStructure :: DataStructure -> BS.ByteString putDataStructure (x, y) = toByteString $ putTree x `mappend` putTree y
test-nonet/Network/HTTP/Client/BodySpec.hs view
@@ -12,8 +12,8 @@ main = hspec spec brComplete :: BodyReader -> IO Bool-brComplete brRead = do- xs <- brRead+brComplete brRead' = do+ xs <- brRead' return (xs == "") spec :: Spec
test-nonet/Network/HTTP/Client/CookieSpec.hs view
@@ -3,7 +3,6 @@ import Data.Time.Clock import Network.HTTP.Client.Internal-import Network.HTTP.Types import Test.Hspec main :: IO ()
test-nonet/Network/HTTP/Client/RequestBodySpec.hs view
@@ -7,8 +7,8 @@ import System.IO import Data.IORef import qualified Data.ByteString as BS-import Network.HTTP.Client (streamFile, parseUrl, requestBody)-import Network.HTTP.Client.Internal (dummyConnection, Connection, connectionWrite, requestBuilder)+import Network.HTTP.Client (streamFile, parseUrlThrow, requestBody)+import Network.HTTP.Client.Internal (dummyConnection, connectionWrite, requestBuilder) import System.Directory (getTemporaryDirectory) spec :: Spec@@ -19,11 +19,11 @@ withBinaryFile path ReadMode $ \h' -> do conn <- verifyFileConnection h' - req0 <- parseUrl "http://example.com"+ req0 <- parseUrlThrow "http://example.com" body <- streamFile path let req = req0 { requestBody = body } - requestBuilder req conn+ _ <- requestBuilder req conn hIsEOF h' `shouldReturn` True where withTmpFile = bracket getTmpFile closeTmpFile
test-nonet/Network/HTTP/Client/RequestSpec.hs view
@@ -2,12 +2,10 @@ module Network.HTTP.Client.RequestSpec where import Blaze.ByteString.Builder (fromByteString)-import Control.Applicative ((<$>))+import Control.Applicative as A ((<$>)) import Control.Monad (join, forM_, (<=<)) import Data.IORef import Data.Maybe (isJust, fromMaybe, fromJust)-import qualified Data.ByteString.Char8 as S8-import Network.HTTP.Client (parseUrl, requestHeaders, applyBasicProxyAuth) import Network.HTTP.Client.Internal import Network.URI (URI(..), URIAuth(..), parseURI) import Test.Hspec@@ -16,30 +14,30 @@ spec = do describe "case insensitive scheme" $ do forM_ ["http://example.com", "httP://example.com", "HttP://example.com", "HttPs://example.com"] $ \url ->- it url $ case parseUrl url of+ it url $ case parseUrlThrow url of Nothing -> error "failed" Just _ -> return () :: IO () forM_ ["ftp://example.com"] $ \url ->- it url $ case parseUrl url of+ it url $ case parseUrlThrow url of Nothing -> return () :: IO () Just req -> error $ show req describe "authentication in url" $ do it "passes validation" $ do- case parseUrl "http://agent:topsecret@example.com" of+ case parseUrlThrow "http://agent:topsecret@example.com" of Nothing -> error "failed" Just _ -> return () :: IO () it "add username/password to headers section" $ do- let request = parseUrl "http://user:pass@example.com"- field = join $ lookup "Authorization" . requestHeaders <$> request+ let request = parseUrlThrow "http://user:pass@example.com"+ field = join $ lookup "Authorization" . requestHeaders A.<$> request requestHostnameWithoutAuth = "example.com" (uriRegName $ fromJust $ uriAuthority $ getUri $ fromJust request) `shouldBe` requestHostnameWithoutAuth field `shouldSatisfy` isJust field `shouldBe` Just "Basic dXNlcjpwYXNz" describe "applyBasicProxyAuth" $ do- let request = applyBasicProxyAuth "user" "pass" <$> parseUrl "http://example.org"+ let request = applyBasicProxyAuth "user" "pass" <$> parseUrlThrow "http://example.org" field = join $ lookup "Proxy-Authorization" . requestHeaders <$> request it "Should add a proxy-authorization header" $ do field `shouldSatisfy` isJust@@ -67,16 +65,16 @@ describe "requestBuilder" $ do it "sends the full request, combining headers and body in the non-streaming case" $ do- let Just req = parseUrl "http://localhost"+ let Just req = parseUrlThrow "http://localhost" let req' = req { method = "PUT", path = "foo" } (conn, out, _) <- dummyConnection [] forM_ (bodies `zip` out1) $ \(b, o) -> do cont <- requestBuilder (req' { requestBody = b } ) conn- (const "<IO ()>" <$> cont) `shouldBe` Nothing+ (const ("<IO ()>" :: String) <$> cont) `shouldBe` Nothing out >>= (`shouldBe` o) it "sends only headers and returns an action for the body on 'Expect: 100-continue'" $ do- let Just req = parseUrl "http://localhost"+ let Just req = parseUrlThrow "http://localhost" let req' = req { requestHeaders = [("Expect", "100-continue")] , method = "PUT" , path = "foo"@@ -114,7 +112,7 @@ popper dat = do r <- newIORef dat- return . atomicModifyIORef' r $ \xs ->+ return . atomicModifyIORef r $ \xs -> case xs of (x:xs') -> (xs', x) [] -> ([], "")
test-nonet/Network/HTTP/Client/ResponseSpec.hs view
@@ -17,7 +17,7 @@ spec :: Spec spec = describe "ResponseSpec" $ do let getResponse' conn = getResponse (const $ return ()) Nothing req conn Nothing- Just req = parseUrl "http://localhost"+ req = parseRequest_ "http://localhost" it "basic" $ do (conn, _, _) <- dummyConnection [ "HTTP/1.1 200 OK\r\n"
test-nonet/Network/HTTP/ClientSpec.hs view
@@ -5,9 +5,10 @@ import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Async (withAsync) import qualified Control.Concurrent.Async as Async-import Control.Exception (bracket, catch, IOException)-import Control.Monad (forever, replicateM_, void)-import Network.HTTP.Client+import Control.Exception (bracket)+import Control.Monad (forever, replicateM_)+import Network.HTTP.Client hiding (port)+import qualified Network.HTTP.Client as NC import Network.HTTP.Types (status413) import Network.Socket (sClose) import Test.Hspec@@ -28,7 +29,7 @@ (const $ inner port) where app ad = do- forkIO $ forever $ N.appRead ad+ _ <- forkIO $ forever $ N.appRead ad forever $ do N.appWrite ad "HTTP/1.1 301 Redirect\r\nLocation: /\r\ncontent-length: 5\r\n\r\n" threadDelay 10000@@ -59,7 +60,7 @@ (const $ inner port) where app ad = do- forkIO $ forever $ N.appRead ad+ _ <- forkIO $ forever $ N.appRead ad forever $ do N.appWrite ad $ S.concat [ "HTTP/1.1 100 Continue\r\n"@@ -119,8 +120,7 @@ getChunkedResponse :: Int -> Manager -> IO (Response SL.ByteString) getChunkedResponse port' man = flip httpLbs man "http://localhost"- { port = port'- , checkStatus = \_ _ _ -> Nothing+ { NC.port = port' , requestBody = RequestBodyStreamChunked ($ return (S.replicate 100000 65)) } @@ -128,77 +128,82 @@ spec = describe "Client" $ do describe "fails on empty hostnames #40" $ do let test url = it url $ do- req <- parseUrl url+ req <- parseUrlThrow url man <- newManager defaultManagerSettings _ <- httpLbs req man `shouldThrow` \e -> case e of- InvalidDestinationHost "" -> True+ HttpExceptionRequest _ (InvalidDestinationHost "") -> True _ -> False return () mapM_ test ["http://", "https://", "http://:8000", "https://:8001"] it "redirecting #41" $ redirectServer $ \port -> do- req' <- parseUrl $ "http://127.0.0.1:" ++ show port+ req' <- parseUrlThrow $ "http://127.0.0.1:" ++ show port let req = req' { redirectCount = 1 }- withManager defaultManagerSettings $ \man -> replicateM_ 10 $ do+ man <- newManager defaultManagerSettings+ replicateM_ 10 $ do httpLbs req man `shouldThrow` \e -> case e of- TooManyRedirects _ -> True+ HttpExceptionRequest _ (TooManyRedirects _) -> True _ -> False it "redirectCount=0" $ redirectServer $ \port -> do- req' <- parseUrl $ "http://127.0.0.1:" ++ show port+ req' <- parseUrlThrow $ "http://127.0.0.1:" ++ show port let req = req' { redirectCount = 0 }- withManager defaultManagerSettings $ \man -> replicateM_ 10 $ do+ man <- newManager defaultManagerSettings+ replicateM_ 10 $ do httpLbs req man `shouldThrow` \e -> case e of- StatusCodeException{} -> True+ HttpExceptionRequest _ StatusCodeException{} -> True _ -> False it "connecting to missing server gives nice error message" $ do (port, socket) <- N.bindRandomPortTCP "*4" sClose socket- req <- parseUrl $ "http://127.0.0.1:" ++ show port- withManager defaultManagerSettings $ \man ->- httpLbs req man `shouldThrow` \e ->- case e of- FailedConnectionException2 "127.0.0.1" port' False _ -> port == port'- _ -> False+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ man <- newManager defaultManagerSettings+ httpLbs req man `shouldThrow` \e ->+ case e of+ HttpExceptionRequest req' (ConnectionFailure _)+ -> host req == host req'+ && NC.port req == NC.port req'+ _ -> False describe "extra headers after 100 #49" $ do let test x = it (show x) $ bad100Server x $ \port -> do- req <- parseUrl $ "http://127.0.0.1:" ++ show port- withManager defaultManagerSettings $ \man -> replicateM_ 10 $ do- x <- httpLbs req man- responseBody x `shouldBe` "hello"+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ man <- newManager defaultManagerSettings+ replicateM_ 10 $ do+ x' <- httpLbs req man+ responseBody x' `shouldBe` "hello" test False test True it "early close on a 413" $ earlyClose413 $ \port' -> do- withManager defaultManagerSettings $ \man -> do- res <- getChunkedResponse port' man- responseBody res `shouldBe` "goodbye"- responseStatus res `shouldBe` status413+ man <- newManager defaultManagerSettings+ res <- getChunkedResponse port' man+ responseBody res `shouldBe` "goodbye"+ responseStatus res `shouldBe` status413 it "length zero and chunking zero #108" $ lengthZeroAndChunkZero $ \port' -> do- withManager defaultManagerSettings $ \man -> do- res <- getChunkedResponse port' man- responseBody res `shouldBe` ""+ man <- newManager defaultManagerSettings+ res <- getChunkedResponse port' man+ responseBody res `shouldBe` "" it "length zero and chunking" $ lengthZeroAndChunked $ \port' -> do- withManager defaultManagerSettings $ \man -> do- res <- getChunkedResponse port' man- responseBody res `shouldBe` "Wikipedia in\r\n\r\nchunks."+ man <- newManager defaultManagerSettings+ res <- getChunkedResponse port' man+ responseBody res `shouldBe` "Wikipedia in\r\n\r\nchunks." it "length and chunking" $ lengthAndChunked $ \port' -> do- withManager defaultManagerSettings $ \man -> do- res <- getChunkedResponse port' man- responseBody res `shouldBe` "Wikipedia in\r\n\r\nchunks."+ man <- newManager defaultManagerSettings+ res <- getChunkedResponse port' man+ responseBody res `shouldBe` "Wikipedia in\r\n\r\nchunks." it "withResponseHistory and redirect" $ redirectCloseServer $ \port -> do -- see https://github.com/snoyberg/http-client/issues/169- req' <- parseUrl $ "http://127.0.0.1:" ++ show port+ req' <- parseUrlThrow $ "http://127.0.0.1:" ++ show port let req = req' {redirectCount = 1}- withManager defaultManagerSettings $ \man -> do- withResponseHistory req man (const $ return ())- `shouldThrow` \e ->- case e of- TooManyRedirects _ -> True- _ -> False+ man <- newManager defaultManagerSettings+ withResponseHistory req man (const $ return ())+ `shouldThrow` \e ->+ case e of+ HttpExceptionRequest _ (TooManyRedirects _) -> True+ _ -> False
test/Network/HTTP/ClientSpec.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.ClientSpec where -import Control.Exception (toException)-import Network (withSocketsDo)-import Network.HTTP.Client-import Network.HTTP.Types (found302, status200, status405)-import Test.Hspec-import Data.ByteString.Lazy.Char8 ()+import Network (withSocketsDo)+import Network.HTTP.Client+import Network.HTTP.Types (status200, status405)+import Test.Hspec+import Data.ByteString.Lazy.Char8 () -- orphan instance main :: IO () main = hspec spec@@ -14,46 +13,33 @@ spec :: Spec spec = describe "Client" $ do it "works" $ withSocketsDo $ do- req <- parseUrl "http://httpbin.org/"+ req <- parseUrlThrow "http://httpbin.org/" man <- newManager defaultManagerSettings res <- httpLbs req man responseStatus res `shouldBe` status200 describe "method in URL" $ do it "success" $ withSocketsDo $ do- req <- parseUrl "POST http://httpbin.org/post"+ req <- parseUrlThrow "POST http://httpbin.org/post" man <- newManager defaultManagerSettings res <- httpLbs req man responseStatus res `shouldBe` status200 it "failure" $ withSocketsDo $ do- req' <- parseUrl "PUT http://httpbin.org/post"- let req = req'- { checkStatus = \_ _ _ -> Nothing- }+ req <- parseRequest "PUT http://httpbin.org/post" man <- newManager defaultManagerSettings res <- httpLbs req man responseStatus res `shouldBe` status405 - describe "managerModifyRequest" $ do-- it "can set port to 80" $ do+ it "managerModifyRequest" $ do let modify req = return req { port = 80 } settings = defaultManagerSettings { managerModifyRequest = modify }- withManager settings $ \man -> do- res <- httpLbs "http://httpbin.org:1234" man- responseStatus res `shouldBe` status200-- it "can set 'checkStatus' to throw StatusCodeException" $ do- let modify req = return req { checkStatus = \s hs cj -> Just $ toException $ StatusCodeException s hs cj }- settings = defaultManagerSettings { managerModifyRequest = modify }- withManager settings $ \man ->- httpLbs "http://httpbin.org" man `shouldThrow` anyException+ man <- newManager settings+ res <- httpLbs "http://httpbin.org:1234" man+ responseStatus res `shouldBe` status200 - it "can set redirectCount to 0 to prevent following redirects" $ do- let modify req = return req { redirectCount = 0 }+ it "managerModifyRequestCheckStatus" $ do+ let modify req = return req { checkResponse = \_ _ -> error "some exception" } settings = defaultManagerSettings { managerModifyRequest = modify } man <- newManager settings- httpLbs "http://httpbin.org/redirect-to?url=foo" man `shouldThrow` ( \ (StatusCodeException s _ _) -> s == found302)--+ httpLbs "http://httpbin.org" man `shouldThrow` anyException