diff --git a/Network/HTTP/Conduit/Browser.hs b/Network/HTTP/Conduit/Browser.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Conduit/Browser.hs @@ -0,0 +1,5 @@ +module Network.HTTP.Conduit.Browser + ( module Network.HTTP.Conduit.Browser2 + ) where + +import Network.HTTP.Conduit.Browser2 diff --git a/Network/HTTP/Conduit/Browser2.hs b/Network/HTTP/Conduit/Browser2.hs --- a/Network/HTTP/Conduit/Browser2.hs +++ b/Network/HTTP/Conduit/Browser2.hs @@ -90,6 +90,9 @@ , getCurrentProxy , setCurrentProxy , withCurrentProxy + , getCurrentSocksProxy + , setCurrentSocksProxy + , withCurrentSocksProxy , getOverrideHeaders , setOverrideHeaders , withOverrideHeaders @@ -99,6 +102,9 @@ , getUserAgent , setUserAgent , withUserAgent + , getCheckStatus + , setCheckStatus + , withCheckStatus , getManager , setManager ) @@ -115,6 +121,7 @@ #endif import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Types.Header as HT +import Network.Socks5 (SocksConf) import Data.Time.Clock (getCurrentTime, UTCTime) import Data.CaseInsensitive (mk) import Data.ByteString.UTF8 (fromString) @@ -133,7 +140,9 @@ , cookieFilter :: Request (ResourceT IO) -> Cookie -> IO Bool , cookieJar :: CookieJar , currentProxy :: Maybe Proxy + , currentSocksProxy :: Maybe SocksConf , overrideHeaders :: Map.Map HT.HeaderName BS.ByteString + , browserCheckStatus :: Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException) , manager :: Manager } @@ -145,7 +154,9 @@ , cookieFilter = \ _ _ -> return True , cookieJar = def , currentProxy = Nothing + , currentSocksProxy = Nothing , overrideHeaders = Map.singleton HT.hUserAgent (fromString "http-conduit") + , browserCheckStatus = Nothing , manager = m } @@ -163,15 +174,21 @@ , maxRedirects = max_redirects , timeout = time_out , currentProxy = current_proxy + , currentSocksProxy = current_socks_proxy , overrideHeaders = override_headers + , browserCheckStatus = current_check_status } <- get retryHelper (applyOverrideHeaders override_headers $ request { redirectCount = 0 , proxy = maybe (proxy request) Just current_proxy + , socksProxy = maybe (socksProxy request) Just current_socks_proxy , checkStatus = \ _ _ -> Nothing , responseTimeout = maybe (responseTimeout request) Just time_out - }) max_retry_count (fromMaybe (redirectCount request) max_redirects) Nothing - where retryHelper request' retry_count max_redirects e + }) max_retry_count + (fromMaybe (redirectCount request) max_redirects) + (fromMaybe (checkStatus request) current_check_status) + Nothing + where retryHelper request' retry_count max_redirects check_status e | retry_count == 0 = case e of Just e' -> throw e' Nothing -> throw TooManyRetries @@ -179,11 +196,10 @@ resp <- LE.catch (if max_redirects==0 then (\(_,a,_) -> a) `fmap` performRequest request' else runRedirectionChain request' max_redirects []) - (\ e' -> retryHelper request' (retry_count - 1) max_redirects (Just (e' :: HttpException))) - let code = HT.statusCode $ responseStatus resp - if code < 200 || code >= 300 - then retryHelper request' (retry_count - 1) max_redirects (Just $ StatusCodeException (responseStatus resp) (responseHeaders resp)) - else return resp + (\ e' -> retryHelper request' (retry_count - 1) max_redirects check_status (Just e')) + case check_status (responseStatus resp) (responseHeaders resp) of + Nothing -> return resp + Just e' -> retryHelper request' (retry_count - 1) max_redirects check_status (Just e') performRequest request' = do s@(BrowserState { manager = manager' , authorities = auths @@ -332,6 +348,19 @@ out <- b setCurrentProxy current return out +-- | An optional SOCKS proxy to send all requests through +-- if Nothing uses Request's 'socksProxy' +getCurrentSocksProxy :: BrowserAction (Maybe SocksConf) +getCurrentSocksProxy = get >>= \ a -> return $ currentSocksProxy a +setCurrentSocksProxy :: Maybe SocksConf -> BrowserAction () +setCurrentSocksProxy b = get >>= \ a -> put a {currentSocksProxy = b} +withCurrentSocksProxy :: Maybe SocksConf -> BrowserAction a -> BrowserAction a +withCurrentSocksProxy a b = do + current <- getCurrentSocksProxy + setCurrentSocksProxy a + out <- b + setCurrentSocksProxy current + return out -- | Specifies Headers that should be added to 'Request', -- these will override Headers already specified in 'requestHeaders'. -- @@ -354,6 +383,19 @@ setOverrideHeaders a out <- b setOverrideHeaders current + return out +-- | Function to check the status code. Note that this will run after all redirects are performed. +-- if Nothing uses Request's 'checkStatus' +getCheckStatus :: BrowserAction (Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException)) +getCheckStatus = get >>= \ a -> return $ browserCheckStatus a +setCheckStatus :: Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException) -> BrowserAction () +setCheckStatus b = get >>= \ a -> put a {browserCheckStatus = b} +withCheckStatus :: Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException) -> BrowserAction a -> BrowserAction a +withCheckStatus a b = do + current <- getCheckStatus + setCheckStatus a + out <- b + setCheckStatus current return out insertOverrideHeader :: HT.Header -> BrowserAction () insertOverrideHeader (b, c) = get >>= \ a -> put a {overrideHeaders = Map.insert b c (overrideHeaders a)} diff --git a/http-conduit-browser.cabal b/http-conduit-browser.cabal --- a/http-conduit-browser.cabal +++ b/http-conduit-browser.cabal @@ -1,5 +1,5 @@ name: http-conduit-browser -version: 1.6.1 +version: 1.6.2 license: BSD3 license-file: LICENSE author: Myles C. Maxfield @@ -15,15 +15,14 @@ stability: Stable cabal-version: >= 1.8 build-type: Simple -homepage: https://github.com/litherum/http-conduit/tree/http-conduit-browser +homepage: https://github.com/litherum/http-conduit-browser extra-source-files: test/main.hs -flag network-bytestring - default: False +flag new-http-conduit + default: True library build-depends: base >= 4 && < 5 - , http-conduit >= 1.6.1 && < 1.7 , data-default , cookie , utf8-string @@ -35,6 +34,12 @@ , mtl , bytestring , containers + , socks + if flag(new-http-conduit) + build-depends: http-conduit >= 1.7 && < 1.8 + exposed-modules: Network.HTTP.Conduit.Browser + else + build-depends: http-conduit >= 1.6.1 && < 1.7 exposed-modules: Network.HTTP.Conduit.Browser2 ghc-options: -Wall @@ -67,7 +72,8 @@ , mtl , warp , wai + , socks source-repository head type: git - location: git://github.com/litherum/http-conduit.git + location: git://github.com/litherum/http-conduit-browser.git diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,12 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} import Test.Hspec +import Control.Exception (Exception, toException) import qualified Data.ByteString as S import Network.Wai hiding (requestBody) import Network.Wai.Handler.Warp (run) import Network.HTTP.Conduit import Network.HTTP.Conduit.Browser2 import Data.ByteString.Base64 (encode) +import Data.Typeable (Typeable) import Control.Concurrent (forkIO, killThread) import Network.HTTP.Types import Control.Exception.Lifted (try) @@ -18,6 +21,11 @@ -- TODO tests for responseTimeout/Browser.timeout. +data TestException = TestException + deriving (Show, Typeable) + +instance Exception TestException + strictToLazy :: S.ByteString -> L.ByteString strictToLazy = L.fromChunks . replicate 1 @@ -267,3 +275,14 @@ case elbs of Left StatusCodeException{} -> return () _ -> error "redirectCount should be 0!" + it "uses checkStatus correctly" $ do + tid <- forkIO $ run 3012 app + request <- parseUrl "http://127.0.0.1:3012/useragent" + elbs <- try $ withManager $ \manager -> do + browse manager $ do + setCheckStatus $ Just $ \ _ _ -> Just $ toException TestException + makeRequestLbs request + killThread tid + case elbs of + Left TestException -> return () + _ -> error "Should have thrown an exception!"