diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Network/HTTP/Client.hs b/Network/HTTP/Client.hs --- a/Network/HTTP/Client.hs +++ b/Network/HTTP/Client.hs @@ -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 diff --git a/Network/HTTP/Client/Body.hs b/Network/HTTP/Client/Body.hs --- a/Network/HTTP/Client/Body.hs +++ b/Network/HTTP/Client/Body.hs @@ -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 diff --git a/Network/HTTP/Client/Connection.hs b/Network/HTTP/Client/Connection.hs --- a/Network/HTTP/Client/Connection.hs +++ b/Network/HTTP/Client/Connection.hs @@ -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 }] diff --git a/Network/HTTP/Client/Cookies.hs b/Network/HTTP/Client/Cookies.hs --- a/Network/HTTP/Client/Cookies.hs +++ b/Network/HTTP/Client/Cookies.hs @@ -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 = diff --git a/Network/HTTP/Client/Core.hs b/Network/HTTP/Client/Core.hs --- a/Network/HTTP/Client/Core.hs +++ b/Network/HTTP/Client/Core.hs @@ -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 diff --git a/Network/HTTP/Client/Headers.hs b/Network/HTTP/Client/Headers.hs --- a/Network/HTTP/Client/Headers.hs +++ b/Network/HTTP/Client/Headers.hs @@ -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) diff --git a/Network/HTTP/Client/Manager.hs b/Network/HTTP/Client/Manager.hs --- a/Network/HTTP/Client/Manager.hs +++ b/Network/HTTP/Client/Manager.hs @@ -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')) diff --git a/Network/HTTP/Client/MultipartFormData.hs b/Network/HTTP/Client/MultipartFormData.hs --- a/Network/HTTP/Client/MultipartFormData.hs +++ b/Network/HTTP/Client/MultipartFormData.hs @@ -107,7 +107,7 @@ partBS :: Text -- ^ Name of the corresponding \. -> 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 ": " diff --git a/Network/HTTP/Client/Request.hs b/Network/HTTP/Client/Request.hs --- a/Network/HTTP/Client/Request.hs +++ b/Network/HTTP/Client/Request.hs @@ -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. -- diff --git a/Network/HTTP/Client/Response.hs b/Network/HTTP/Client/Response.hs --- a/Network/HTTP/Client/Response.hs +++ b/Network/HTTP/Client/Response.hs @@ -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) } diff --git a/Network/HTTP/Client/Types.hs b/Network/HTTP/Client/Types.hs --- a/Network/HTTP/Client/Types.hs +++ b/Network/HTTP/Client/Types.hs @@ -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. -- - -- - | 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 diff --git a/Network/HTTP/Client/Util.hs b/Network/HTTP/Client/Util.hs --- a/Network/HTTP/Client/Util.hs +++ b/Network/HTTP/Client/Util.hs @@ -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 = diff --git a/http-client.cabal b/http-client.cabal --- a/http-client.cabal +++ b/http-client.cabal @@ -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: . 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 diff --git a/publicsuffixlist/Network/PublicSuffixList/Serialize.hs b/publicsuffixlist/Network/PublicSuffixList/Serialize.hs --- a/publicsuffixlist/Network/PublicSuffixList/Serialize.hs +++ b/publicsuffixlist/Network/PublicSuffixList/Serialize.hs @@ -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 diff --git a/test-nonet/Network/HTTP/Client/BodySpec.hs b/test-nonet/Network/HTTP/Client/BodySpec.hs --- a/test-nonet/Network/HTTP/Client/BodySpec.hs +++ b/test-nonet/Network/HTTP/Client/BodySpec.hs @@ -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 diff --git a/test-nonet/Network/HTTP/Client/CookieSpec.hs b/test-nonet/Network/HTTP/Client/CookieSpec.hs --- a/test-nonet/Network/HTTP/Client/CookieSpec.hs +++ b/test-nonet/Network/HTTP/Client/CookieSpec.hs @@ -3,7 +3,6 @@ import Data.Time.Clock import Network.HTTP.Client.Internal -import Network.HTTP.Types import Test.Hspec main :: IO () diff --git a/test-nonet/Network/HTTP/Client/RequestBodySpec.hs b/test-nonet/Network/HTTP/Client/RequestBodySpec.hs --- a/test-nonet/Network/HTTP/Client/RequestBodySpec.hs +++ b/test-nonet/Network/HTTP/Client/RequestBodySpec.hs @@ -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 diff --git a/test-nonet/Network/HTTP/Client/RequestSpec.hs b/test-nonet/Network/HTTP/Client/RequestSpec.hs --- a/test-nonet/Network/HTTP/Client/RequestSpec.hs +++ b/test-nonet/Network/HTTP/Client/RequestSpec.hs @@ -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 "" <$> cont) `shouldBe` Nothing + (const ("" :: 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) [] -> ([], "") diff --git a/test-nonet/Network/HTTP/Client/ResponseSpec.hs b/test-nonet/Network/HTTP/Client/ResponseSpec.hs --- a/test-nonet/Network/HTTP/Client/ResponseSpec.hs +++ b/test-nonet/Network/HTTP/Client/ResponseSpec.hs @@ -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" diff --git a/test-nonet/Network/HTTP/ClientSpec.hs b/test-nonet/Network/HTTP/ClientSpec.hs --- a/test-nonet/Network/HTTP/ClientSpec.hs +++ b/test-nonet/Network/HTTP/ClientSpec.hs @@ -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 diff --git a/test/Network/HTTP/ClientSpec.hs b/test/Network/HTTP/ClientSpec.hs --- a/test/Network/HTTP/ClientSpec.hs +++ b/test/Network/HTTP/ClientSpec.hs @@ -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