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 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleContexts #-} -- | This module is designed to work similarly to the Network.Browser module in the HTTP package. -- The idea is that there are two new types defined: 'BrowserState' and 'BrowserAction'. The -- purpose of this module is to make it easy to describe a browsing session, including navigating @@ -14,7 +14,7 @@ -- -- A special kind of modification of the current browser state is the action of making a HTTP -- request. This will do the request according to the params in the current BrowserState, as well --- as modifying the current state with, for example, an updated cookie jar. +-- as modifying the current state with, for example, an updated cookie jar and location. -- -- To use this module, you would bind together a series of BrowserActions (This simulates the user -- clicking on links or using a settings dialogue etc.) to describe your browsing session. When @@ -60,39 +60,106 @@ -- > putStrLn $ UB.toString $ B.concat $ LB.toChunks $ responseBody out module Network.HTTP.Conduit.Browser2 - ( BrowserState - , BrowserAction + ( + -- * Main + BrowserAction + , GenericBrowserAction , browse + , parseRelativeUrl , makeRequest , makeRequestLbs + -- * Browser state + , BrowserState , defaultState , getBrowserState , setBrowserState , withBrowserState + -- ** Manager + , Manager + , getManager + , setManager + -- ** Location + -- | The last visited url (similar to the location bar in mainstream browsers). + -- Location is updated on every request. + -- + -- default: @Nothing@ + , getLocation + , setLocation + , withLocation + -- ** Cookies + -- *** Cookie jar + -- | All the cookies! + , getCookieJar + , setCookieJar + , withCookieJar + -- *** Cookie filter + -- | Each new Set-Cookie the browser encounters will pass through this filter. + -- Only cookies that pass the filter (and are already valid) will be allowed into the cookie jar + -- + -- default: @const $ const $ return True@ + , getCookieFilter + , setCookieFilter + , withCookieFilter + -- ** Proxies + -- *** HTTP + -- | An optional proxy to send all requests through + -- if Nothing uses Request's 'proxy' + -- + -- default: @Nothing@ + , getCurrentProxy + , setCurrentProxy + , withCurrentProxy + -- *** SOCKS + -- | An optional SOCKS proxy to send all requests through + -- if Nothing uses Request's 'socksProxy' + -- + -- default: @Nothing@ + , getCurrentSocksProxy + , setCurrentSocksProxy + , withCurrentSocksProxy + -- ** Redirects + -- | The number of redirects to allow. + -- if Nothing uses Request's 'redirectCount' + -- + -- default: @Nothing@ , getMaxRedirects , setMaxRedirects , withMaxRedirects + -- ** Retries + -- | The number of times to retry a failed connection + -- + -- default: @0@ , getMaxRetryCount , setMaxRetryCount , withMaxRetryCount + -- ** Timeout + -- | Number of microseconds to wait for a response. + -- if Nothing uses Request's 'responseTimeout' + -- + -- default: @Nothing@ , getTimeout , setTimeout , withTimeout + -- ** Authorities + -- | A user-provided function that provides optional authorities. + -- This function gets run on all requests before they get sent out. + -- The output of this function is applied to the request. + -- + -- default: @const Nothing@ , getAuthorities , setAuthorities , withAuthorities - , getCookieFilter - , setCookieFilter - , withCookieFilter - , getCookieJar - , setCookieJar - , withCookieJar - , getCurrentProxy - , setCurrentProxy - , withCurrentProxy - , getCurrentSocksProxy - , setCurrentSocksProxy - , withCurrentSocksProxy + -- ** Headers + -- *** Override headers + -- | Specifies Headers that should be added to 'Request', + -- these will override Headers already specified in 'requestHeaders'. + -- + -- > do insertOverrideHeader ("User-Agent", "rat") + -- > insertOverrideHeader ("Connection", "keep-alive") + -- > makeRequest def{requestHeaders = [("User-Agent", "kitten"), ("Accept", "everything/digestible")]} + -- > > User-Agent: rat + -- > > Accept: everything/digestible + -- > > Connection: keep-alive , getOverrideHeaders , setOverrideHeaders , withOverrideHeaders @@ -101,18 +168,30 @@ , insertOverrideHeader , deleteOverrideHeader , withOverrideHeader + -- *** User agent + -- | What string to report our user-agent as. + -- if Nothing will not send user-agent unless one is specified in 'Request' + -- + -- > getUserAgent = lookup "User-Agent" overrideHeaders + -- > setUserAgent a = insertOverrideHeader ("User-Agent", a) + -- + -- default: @Just \"http-conduit\"@ , getUserAgent , setUserAgent , withUserAgent + -- ** Error handling + -- | Function to check the status code. Note that this will run after all redirects are performed. + -- if Nothing uses Request's 'checkStatus' + -- + -- default: @Nothing@ , getCheckStatus , setCheckStatus , withCheckStatus - , getManager - , setManager ) where import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as S8 (unpack) import qualified Data.ByteString.Lazy as L import Control.Monad.State import Control.Exception @@ -124,6 +203,7 @@ import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Types.Header as HT import Network.Socks5 (SocksConf) +import Network.URI (URI (..), URIAuth (..), parseRelativeReference, relativeTo, uriToString) import Data.Time.Clock (getCurrentTime, UTCTime) import Data.CaseInsensitive (mk) import Data.ByteString.UTF8 (fromString) @@ -133,9 +213,13 @@ import qualified Data.Map as Map import Network.HTTP.Conduit +import Control.Monad.Trans.Resource (liftResourceT) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Failure (Failure) data BrowserState = BrowserState - { maxRedirects :: Maybe Int + { currentLocation :: Maybe URI + , maxRedirects :: Maybe Int , maxRetryCount :: Int , timeout :: Maybe Int , authorities :: Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString) @@ -149,7 +233,8 @@ } defaultState :: Manager -> BrowserState -defaultState m = BrowserState { maxRedirects = Nothing +defaultState m = BrowserState { currentLocation = Nothing + , maxRedirects = Nothing , maxRetryCount = 0 , timeout = Nothing , authorities = const Nothing @@ -162,14 +247,25 @@ , manager = m } -type BrowserAction = StateT BrowserState (ResourceT IO) +type BrowserAction = GenericBrowserAction (ResourceT IO) +type GenericBrowserAction m = StateT BrowserState m + -- | Do the browser action with the given manager -browse :: Manager -> BrowserAction a -> ResourceT IO a +browse :: Monad m => Manager -> GenericBrowserAction m a -> m a browse m act = evalStateT act (defaultState m) +-- | Convert an URL relative to current Location into a 'Request' +-- +-- Will throw 'InvalidUrlException' on parse failures or if your Location is 'Nothing' (e.g. you haven't made any requests before) +parseRelativeUrl :: Failure HttpException m => String -> GenericBrowserAction m (Request m') +parseRelativeUrl url = maybe err (parseUrl . use) . currentLocation =<< get + where err = throw $ InvalidUrlException url "Invalid URL" + uri = fromMaybe err $ parseRelativeReference url + use = flip (uriToString id) "" . fromMaybe err . relativeTo uri + -- | Make a request, using all the state in the current BrowserState -makeRequest :: Request (ResourceT IO) -> BrowserAction (Response (ResumableSource (ResourceT IO) BS.ByteString)) +makeRequest :: (MonadBaseControl IO m, MonadResource m) => Request (ResourceT IO) -> GenericBrowserAction m (Response (ResumableSource (ResourceT IO) BS.ByteString)) makeRequest request = do BrowserState { maxRetryCount = max_retry_count @@ -212,9 +308,11 @@ let (request'', cookie_jar') = insertCookiesIntoRequest (applyAuthorities auths request') (evictExpiredCookies cookie_jar now) now - res <- lift $ http request'' manager' + res <- liftResourceT $ http request'' manager' (cookie_jar'', response) <- liftIO $ updateMyCookieJar res request'' now cookie_jar' cookie_filter - put $ s {cookieJar = cookie_jar''} + put $ s { cookieJar = cookie_jar'' + , currentLocation = Just $ getUri request'' + } return (request'', res, response) runRedirectionChain request' redirect_count ress | redirect_count == (-1) = throw . TooManyRedirects =<< mapM (liftIO . runResourceT . lbsResponse) ress @@ -231,7 +329,13 @@ Just (user, pass) -> applyBasicAuth user pass request' Nothing -> request' -makeRequestLbs :: Request (ResourceT IO) -> BrowserAction (Response L.ByteString) +-- | Make a request and pack the result as a lazy bytestring. +-- +-- Note: Even though this function returns a lazy bytestring, it does not +-- utilize lazy I/O, and therefore the entire response body will live in memory. +-- If you want constant memory usage, you'll need to use the conduit package and +-- 'makeRequest' directly. +makeRequestLbs :: (MonadBaseControl IO m, MonadResource m) => Request (ResourceT IO) -> GenericBrowserAction m (Response L.ByteString) makeRequestLbs = liftIO . runResourceT . lbsResponse <=< makeRequest applyOverrideHeaders :: Map.Map HT.HeaderName BS.ByteString -> Request a -> Request a @@ -248,11 +352,11 @@ cookieJar' = foldl (\ cj c -> insertCheckedCookie c cj True) cookie_jar -- | You can save and restore the state at will -getBrowserState :: BrowserAction BrowserState +getBrowserState :: Monad m => GenericBrowserAction m BrowserState getBrowserState = get -setBrowserState :: BrowserState -> BrowserAction () +setBrowserState :: Monad m => BrowserState -> GenericBrowserAction m () setBrowserState = put -withBrowserState :: BrowserState -> BrowserAction a -> BrowserAction a +withBrowserState :: Monad m => BrowserState -> GenericBrowserAction m a -> GenericBrowserAction m a withBrowserState s a = do current <- get put s @@ -260,190 +364,188 @@ put current return out --- | The number of redirects to allow. --- if Nothing uses Request's 'redirectCount' --- default: Nothing -getMaxRedirects :: BrowserAction (Maybe Int) +getLocation :: Monad m => GenericBrowserAction m (Maybe URI) +getLocation = get >>= \ a -> return $ currentLocation a +setLocation :: Monad m => Maybe URI -> GenericBrowserAction m () +setLocation b = get >>= \ a -> put a {currentLocation = b} +withLocation :: Monad m => Maybe URI -> GenericBrowserAction m a -> GenericBrowserAction m a +withLocation a b = do + current <- getLocation + setLocation a + out <- b + setLocation current + return out + +getMaxRedirects :: Monad m => GenericBrowserAction m (Maybe Int) getMaxRedirects = get >>= \ a -> return $ maxRedirects a -setMaxRedirects :: Maybe Int -> BrowserAction () +setMaxRedirects :: Monad m => Maybe Int -> GenericBrowserAction m () setMaxRedirects b = get >>= \ a -> put a {maxRedirects = b} -withMaxRedirects :: Maybe Int -> BrowserAction a -> BrowserAction a +withMaxRedirects :: Monad m => Maybe Int -> GenericBrowserAction m a -> GenericBrowserAction m a withMaxRedirects a b = do current <- getMaxRedirects setMaxRedirects a out <- b setMaxRedirects current return out --- | The number of times to retry a failed connection --- default: 0 -getMaxRetryCount :: BrowserAction Int + +getMaxRetryCount :: Monad m => GenericBrowserAction m Int getMaxRetryCount = get >>= \ a -> return $ maxRetryCount a -setMaxRetryCount :: Int -> BrowserAction () +setMaxRetryCount :: Monad m => Int -> GenericBrowserAction m () setMaxRetryCount b = get >>= \ a -> put a {maxRetryCount = b} -withMaxRetryCount :: Int -> BrowserAction a -> BrowserAction a +withMaxRetryCount :: Monad m => Int -> GenericBrowserAction m a -> GenericBrowserAction m a withMaxRetryCount a b = do current <- getMaxRetryCount setMaxRetryCount a out <- b setMaxRetryCount current return out --- | Number of microseconds to wait for a response. --- if Nothing uses Request's 'responseTimeout' --- default: Nothing -getTimeout :: BrowserAction (Maybe Int) + +getTimeout :: Monad m => GenericBrowserAction m (Maybe Int) getTimeout = get >>= \ a -> return $ timeout a -setTimeout :: Maybe Int -> BrowserAction () +setTimeout :: Monad m => Maybe Int -> GenericBrowserAction m () setTimeout b = get >>= \ a -> put a {timeout = b} -withTimeout :: Maybe Int -> BrowserAction a -> BrowserAction a +withTimeout :: Monad m => Maybe Int -> GenericBrowserAction m a -> GenericBrowserAction m a withTimeout a b = do current <- getTimeout setTimeout a out <- b setTimeout current return out --- | A user-provided function that provides optional authorities. --- This function gets run on all requests before they get sent out. --- The output of this function is applied to the request. --- default: const Nothing -getAuthorities :: BrowserAction (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)) + +getAuthorities :: Monad m => GenericBrowserAction m (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)) getAuthorities = get >>= \ a -> return $ authorities a -setAuthorities :: (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)) -> BrowserAction () +setAuthorities :: Monad m => (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)) -> GenericBrowserAction m () setAuthorities b = get >>= \ a -> put a {authorities = b} -withAuthorities :: (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)) -> BrowserAction a -> BrowserAction a +withAuthorities :: Monad m => (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)) -> GenericBrowserAction m a -> GenericBrowserAction m a withAuthorities a b = do current <- getAuthorities setAuthorities a out <- b setAuthorities current return out --- | Each new Set-Cookie the browser encounters will pass through this filter. --- Only cookies that pass the filter (and are already valid) will be allowed into the cookie jar --- default: const $ const $ return True -getCookieFilter :: BrowserAction (Request (ResourceT IO) -> Cookie -> IO Bool) + +getCookieFilter :: Monad m => GenericBrowserAction m (Request (ResourceT IO) -> Cookie -> IO Bool) getCookieFilter = get >>= \ a -> return $ cookieFilter a -setCookieFilter :: (Request (ResourceT IO) -> Cookie -> IO Bool) -> BrowserAction () +setCookieFilter :: Monad m => (Request (ResourceT IO) -> Cookie -> IO Bool) -> GenericBrowserAction m () setCookieFilter b = get >>= \ a -> put a {cookieFilter = b} -withCookieFilter :: (Request (ResourceT IO) -> Cookie -> IO Bool) -> BrowserAction a -> BrowserAction a +withCookieFilter :: Monad m => (Request (ResourceT IO) -> Cookie -> IO Bool) -> GenericBrowserAction m a -> GenericBrowserAction m a withCookieFilter a b = do current <- getCookieFilter setCookieFilter a out <- b setCookieFilter current return out --- | All the cookies! -getCookieJar :: BrowserAction CookieJar + +getCookieJar :: Monad m => GenericBrowserAction m CookieJar getCookieJar = get >>= \ a -> return $ cookieJar a -setCookieJar :: CookieJar -> BrowserAction () +setCookieJar :: Monad m => CookieJar -> GenericBrowserAction m () setCookieJar b = get >>= \ a -> put a {cookieJar = b} -withCookieJar :: CookieJar -> BrowserAction a -> BrowserAction a +withCookieJar :: Monad m => CookieJar -> GenericBrowserAction m a -> GenericBrowserAction m a withCookieJar a b = do current <- getCookieJar setCookieJar a out <- b setCookieJar current return out --- | An optional proxy to send all requests through --- if Nothing uses Request's 'proxy' --- default: Nothing -getCurrentProxy :: BrowserAction (Maybe Proxy) + +getCurrentProxy :: Monad m => GenericBrowserAction m (Maybe Proxy) getCurrentProxy = get >>= \ a -> return $ currentProxy a -setCurrentProxy :: Maybe Proxy -> BrowserAction () +setCurrentProxy :: Monad m => Maybe Proxy -> GenericBrowserAction m () setCurrentProxy b = get >>= \ a -> put a {currentProxy = b} -withCurrentProxy :: Maybe Proxy -> BrowserAction a -> BrowserAction a +withCurrentProxy :: Monad m => Maybe Proxy -> GenericBrowserAction m a -> GenericBrowserAction m a withCurrentProxy a b = do current <- getCurrentProxy setCurrentProxy a out <- b setCurrentProxy current return out --- | An optional SOCKS proxy to send all requests through --- if Nothing uses Request's 'socksProxy' --- default: Nothing -getCurrentSocksProxy :: BrowserAction (Maybe SocksConf) + +getCurrentSocksProxy :: Monad m => GenericBrowserAction m (Maybe SocksConf) getCurrentSocksProxy = get >>= \ a -> return $ currentSocksProxy a -setCurrentSocksProxy :: Maybe SocksConf -> BrowserAction () +setCurrentSocksProxy :: Monad m => Maybe SocksConf -> GenericBrowserAction m () setCurrentSocksProxy b = get >>= \ a -> put a {currentSocksProxy = b} -withCurrentSocksProxy :: Maybe SocksConf -> BrowserAction a -> BrowserAction a +withCurrentSocksProxy :: Monad m => Maybe SocksConf -> GenericBrowserAction m a -> GenericBrowserAction m 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'. --- --- > do insertOverrideHeader ("User-Agent", "rat") --- > insertOverrideHeader ("Connection", "keep-alive") --- > makeRequest def{requestHeaders = [("User-Agent", "kitten"), ("Accept", "everything/digestible")]} --- > > User-Agent: rat --- > > Accept: everything/digestible --- > > Connection: keep-alive -getOverrideHeaders :: BrowserAction HT.RequestHeaders + +getOverrideHeaders :: Monad m => GenericBrowserAction m HT.RequestHeaders getOverrideHeaders = get >>= \ a -> return $ Map.toList $ overrideHeaders a -setOverrideHeaders :: HT.RequestHeaders -> BrowserAction () +setOverrideHeaders :: Monad m => HT.RequestHeaders -> GenericBrowserAction m () setOverrideHeaders b = do current_user_agent <- getUserAgent get >>= \ a -> put a {overrideHeaders = Map.fromList b} setUserAgent current_user_agent -withOverrideHeaders:: HT.RequestHeaders -> BrowserAction a -> BrowserAction a +withOverrideHeaders:: Monad m => HT.RequestHeaders -> GenericBrowserAction m a -> GenericBrowserAction m a withOverrideHeaders a b = do current <- getOverrideHeaders setOverrideHeaders a out <- b setOverrideHeaders current return out -getOverrideHeader :: HT.HeaderName -> BrowserAction (Maybe BS.ByteString) +getOverrideHeader :: Monad m => HT.HeaderName -> GenericBrowserAction m (Maybe BS.ByteString) getOverrideHeader b = get >>= \ a -> return $ Map.lookup b (overrideHeaders a) -setOverrideHeader :: HT.HeaderName -> Maybe BS.ByteString -> BrowserAction () +setOverrideHeader :: Monad m => HT.HeaderName -> Maybe BS.ByteString -> GenericBrowserAction m () setOverrideHeader b Nothing = deleteOverrideHeader b setOverrideHeader b (Just c) = insertOverrideHeader (b, c) -insertOverrideHeader :: HT.Header -> BrowserAction () +insertOverrideHeader :: Monad m => HT.Header -> GenericBrowserAction m () insertOverrideHeader (b, c) = get >>= \ a -> put a {overrideHeaders = Map.insert b c (overrideHeaders a)} -deleteOverrideHeader :: HT.HeaderName -> BrowserAction () +deleteOverrideHeader :: Monad m => HT.HeaderName -> GenericBrowserAction m () deleteOverrideHeader b = get >>= \ a -> put a {overrideHeaders = Map.delete b (overrideHeaders a)} -withOverrideHeader :: HT.Header -> BrowserAction a -> BrowserAction a +withOverrideHeader :: Monad m => HT.Header -> GenericBrowserAction m a -> GenericBrowserAction m a withOverrideHeader (a,b) c = do current <- getOverrideHeader a insertOverrideHeader (a,b) out <- c setOverrideHeader a current return out --- | What string to report our user-agent as. --- if Nothing will not send user-agent unless one is specified in 'Request' --- --- > getUserAgent = lookup hUserAgent overrideHeaders --- > setUserAgent a = insertOverrideHeader (hUserAgent, a) --- --- default: Just "http-conduit" -getUserAgent :: BrowserAction (Maybe BS.ByteString) + +getUserAgent :: Monad m => GenericBrowserAction m (Maybe BS.ByteString) getUserAgent = get >>= \ a -> return $ Map.lookup HT.hUserAgent (overrideHeaders a) -setUserAgent :: Maybe BS.ByteString -> BrowserAction () +setUserAgent :: Monad m => Maybe BS.ByteString -> GenericBrowserAction m () setUserAgent Nothing = deleteOverrideHeader HT.hUserAgent setUserAgent (Just b) = insertOverrideHeader (HT.hUserAgent, b) -withUserAgent :: Maybe BS.ByteString -> BrowserAction a -> BrowserAction a +withUserAgent :: Monad m => Maybe BS.ByteString -> GenericBrowserAction m a -> GenericBrowserAction m a withUserAgent a b = do current <- getUserAgent setUserAgent a out <- b setUserAgent 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' --- default: Nothing -getCheckStatus :: BrowserAction (Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException)) + +getCheckStatus :: Monad m => GenericBrowserAction m (Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException)) getCheckStatus = get >>= \ a -> return $ browserCheckStatus a -setCheckStatus :: Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException) -> BrowserAction () +setCheckStatus :: Monad m => Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException) -> GenericBrowserAction m () setCheckStatus b = get >>= \ a -> put a {browserCheckStatus = b} -withCheckStatus :: Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException) -> BrowserAction a -> BrowserAction a +withCheckStatus :: Monad m => Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException) -> GenericBrowserAction m a -> GenericBrowserAction m a withCheckStatus a b = do current <- getCheckStatus setCheckStatus a out <- b setCheckStatus current return out --- | The active manager, managing the connection pool -getManager :: BrowserAction Manager + +getManager :: Monad m => GenericBrowserAction m Manager getManager = get >>= \ a -> return $ manager a -setManager :: Manager -> BrowserAction () +setManager :: Monad m => Manager -> GenericBrowserAction m () setManager b = get >>= \ a -> put a {manager = b} + +-- | Extract a 'URI' from the request. +-- Canibalised from Network.HTTP.Conduit.Request, should be made visible there. +getUri :: Request m' -> URI +getUri req = URI + { uriScheme = if secure req + then "https:" + else "http:" + , uriAuthority = Just URIAuth + { uriUserInfo = "" + , uriRegName = S8.unpack $ host req + , uriPort = ':' : show (port req) + } + , uriPath = S8.unpack $ path req + , uriQuery = S8.unpack $ queryString req + , uriFragment = "" + } 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.5 +version: 1.6.6 license: BSD3 license-file: LICENSE author: Myles C. Maxfield @@ -39,6 +39,10 @@ , bytestring , containers , socks + , network >= 2.3 + , failure + , monad-control + , resourcet >= 0.3 && < 0.5 if flag(new-http-conduit) build-depends: http-conduit >= 1.7 && < 1.9 exposed-modules: Network.HTTP.Conduit.Browser @@ -77,3 +81,6 @@ , warp , wai , socks + , network >= 2.3 + , failure + , monad-control diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -318,3 +318,39 @@ case elbs of Left TestException -> return () _ -> error "Should have thrown an exception!" + it "updates location" $ do + tid <- forkIO $ run 3014 app + request <- parseUrl "http://127.0.0.1:3014/" + loc <- withManager $ \manager -> do + browse manager $ do + _ <- makeRequestLbs request + getLocation + killThread tid + if (maybe "" show loc) /= "http://127.0.0.1:3014/" + then error "Should have set the location" + else return () + it "updates location while following redirections" $ do + tid <- forkIO $ run 3014 app + request <- parseUrl "http://127.0.0.1:3014/redir1" + loc <- withManager $ \manager -> do + browse manager $ do + setMaxRedirects $ Just 2 + _ <- makeRequestLbs request + getLocation + killThread tid + if (maybe "" show loc) /= "http://127.0.0.1:3014/redir3" + then error "Should have updated the location when following 2 redirects" + else return () + it "follows relative references" $ do + tid <- forkIO $ run 3014 app + request1 <- parseUrl "http://127.0.0.1:3014/" + (elbs1, elbs2) <- withManager $ \manager -> do + browse manager $ do + lbs1 <- makeRequestLbs request1 + request2 <- parseRelativeUrl "redir3" + lbs2 <- makeRequestLbs request2 + return (lbs1, lbs2) + killThread tid + if (lazyToStrict $ responseBody elbs1) /= fromString "homepage" || (lazyToStrict $ responseBody elbs2) /= dummy + then error "Should have followed the relative reference" + else return ()