diff --git a/Network/HTTP/Conduit/Browser.hs b/Network/HTTP/Conduit/Browser.hs --- a/Network/HTTP/Conduit/Browser.hs +++ b/Network/HTTP/Conduit/Browser.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleContexts, OverloadedStrings #-} -- | 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 @@ -31,7 +31,7 @@ -- > import Data.Conduit -- > import Network.HTTP.Conduit -- > import Network.HTTP.Conduit.Browser --- > +-- > -- > -- The web request to log in to a service -- > req1 :: IO (Request (ResourceT IO)) -- > req1 = do @@ -39,23 +39,25 @@ -- > return $ urlEncodedBody [ (TE.encodeUtf8 "name", TE.encodeUtf8 "litherum") -- > , (TE.encodeUtf8 "pass", TE.encodeUtf8 "S33kRe7") -- > ] req --- > +-- > -- > -- Once authenticated, run this request -- > req2 :: IO (Request m') -- > req2 = parseUrl "http://www.myurl.com/main.php" --- > +-- > -- > -- Bind two BrowserActions together -- > action :: Request (ResourceT IO) -> Request (ResourceT IO) -> BrowserAction (Response LB.ByteString) -- > action r1 r2 = do -- > _ <- makeRequestLbs r1 -- > makeRequestLbs r2 --- > +-- > -- > main :: IO () -- > main = do -- > man <- newManager def -- > r1 <- req1 -- > r2 <- req2 --- > out <- runResourceT $ browse man $ action r1 r2 +-- > out <- runResourceT $ browse man $ do +-- > setDefaultHeader "User-Agent" $ Just "A very popular browser" +-- > action r1 r2 -- > TLIO.putStrLn $ TLE.decodeUtf8 $ responseBody out module Network.HTTP.Conduit.Browser @@ -76,7 +78,7 @@ , setBrowserState , withBrowserState -- ** Manager - -- | The active manager, managing the connection pool + -- | The active manager, managing the connection pool , getManager , setManager -- ** Location @@ -151,6 +153,26 @@ , setAuthorities , withAuthorities -- ** Headers + -- *** Default headers + -- | Specifies Headers that should be added to 'Request', + -- these will be overriden by any headers specified in 'requestHeaders'. + -- + -- > do insertDefaultHeader ("User-Agent", "dog") + -- > insertDefaultHeader ("Connection", "keep-alive") + -- > makeRequest def{requestHeaders = [("User-Agent", "kitten"), ("Accept", "x-animal/mouse")]} + -- > > User-Agent: kitten + -- > > Accept: x-animal/mouse + -- > > Connection: keep-alive + -- + -- default: @[(\"User-Agent\", \"http-conduit-browser\")]@ + , getDefaultHeaders + , setDefaultHeaders + , withDefaultHeaders + , getDefaultHeader + , setDefaultHeader + , insertDefaultHeader + , deleteDefaultHeader + , withDefaultHeader -- *** Override headers -- | Specifies Headers that should be added to 'Request', -- these will override Headers already specified in 'requestHeaders'. @@ -161,6 +183,8 @@ -- > > User-Agent: rat -- > > Accept: everything/digestible -- > > Connection: keep-alive + -- + -- default: @[]@ , getOverrideHeaders , setOverrideHeaders , withOverrideHeaders @@ -169,17 +193,6 @@ , 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' @@ -212,7 +225,6 @@ import Data.Time.Clock (getCurrentTime, UTCTime) import Data.CaseInsensitive (mk) import Data.List (partition) -import Data.String (fromString) import Web.Cookie (parseSetCookie) import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Map as Map @@ -236,9 +248,10 @@ , currentProxy :: Maybe Proxy , currentSocksProxy :: Maybe SocksConf , overrideHeaders :: Map.Map HT.HeaderName BS.ByteString + , defaultHeaders :: Map.Map HT.HeaderName BS.ByteString , browserCheckStatus :: Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException) , manager :: Manager - } + } defaultState :: Manager -> BrowserState defaultState m = BrowserState { currentLocation = Nothing @@ -250,7 +263,8 @@ , cookieJar = def , currentProxy = Nothing , currentSocksProxy = Nothing - , overrideHeaders = Map.singleton HT.hUserAgent (fromString "http-conduit") + , overrideHeaders = Map.empty + , defaultHeaders = Map.singleton HT.hUserAgent "http-conduit-browser" , browserCheckStatus = Nothing , manager = m } @@ -291,10 +305,13 @@ , timeout = time_out , currentProxy = current_proxy , currentSocksProxy = current_socks_proxy + , defaultHeaders = default_headers , overrideHeaders = override_headers , browserCheckStatus = current_check_status } <- get - retryHelper (applyOverrideHeaders override_headers $ + retryHelper + (applyOverrideHeaders override_headers $ + applyDefaultHeaders default_headers $ request { redirectCount = 0 , proxy = maybe (proxy request) Just current_proxy , socksProxy = maybe (socksProxy request) Just current_socks_proxy @@ -368,7 +385,7 @@ Just (i, bs') | BS.null bs' -> Just i _ -> Nothing sink = - case lookup (fromString "content-length") (responseHeaders res) >>= readMay of + case lookup "content-length" (responseHeaders res) >>= readMay of Just i | i > maxFlush -> return () _ -> CB.isolate maxFlush =$ sinkNull liftResourceT $ responseBody res $$+- sink @@ -382,7 +399,7 @@ -- 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. +-- 'makeRequest' directly. makeRequestLbs :: (MonadBaseControl IO m, MonadResource m) => Request (ResourceT IO) -> GenericBrowserAction m (Response L.ByteString) makeRequestLbs = liftResourceT . lbsResponse <=< makeRequest @@ -392,15 +409,19 @@ res <- makeRequest request liftResourceT $ responseBody res $$+- CB.sinkFile file +applyDefaultHeaders :: Map.Map HT.HeaderName BS.ByteString -> Request a -> Request a +applyDefaultHeaders dv request = request {requestHeaders = x $ requestHeaders request} + where x r = Map.toList $ Map.union (Map.fromList r) dv + applyOverrideHeaders :: Map.Map HT.HeaderName BS.ByteString -> Request a -> Request a -applyOverrideHeaders ov request' = request' {requestHeaders = x $ requestHeaders request'} +applyOverrideHeaders ov request = request {requestHeaders = x $ requestHeaders request} where x r = Map.toList $ Map.union ov (Map.fromList r) updateMyCookieJar :: Response a -> Request (ResourceT IO) -> UTCTime -> CookieJar -> (Request (ResourceT IO) -> Cookie -> IO Bool) -> IO (CookieJar, Response a) updateMyCookieJar response request' now cookie_jar cookie_filter = do filtered_cookies <- filterM (cookie_filter request') $ catMaybes $ map (\ sc -> generateCookie sc request' now True) set_cookies return (cookieJar' filtered_cookies, response {responseHeaders = other_headers}) - where (set_cookie_headers, other_headers) = partition ((== (mk $ fromString "Set-Cookie")) . fst) $ responseHeaders response + where (set_cookie_headers, other_headers) = partition ((== "Set-Cookie") . fst) $ responseHeaders response set_cookie_data = map snd set_cookie_headers set_cookies = map parseSetCookie set_cookie_data cookieJar' = foldl (\ cj c -> insertCheckedCookie c cj True) cookie_jar @@ -525,13 +546,38 @@ setCurrentSocksProxy current return out +getDefaultHeaders :: Monad m => GenericBrowserAction m HT.RequestHeaders +getDefaultHeaders = get >>= \ a -> return $ Map.toList $ defaultHeaders a +setDefaultHeaders :: Monad m => HT.RequestHeaders -> GenericBrowserAction m () +setDefaultHeaders b = get >>= \ a -> put a {defaultHeaders = Map.fromList b} +withDefaultHeaders:: Monad m => HT.RequestHeaders -> GenericBrowserAction m a -> GenericBrowserAction m a +withDefaultHeaders a b = do + current <- getDefaultHeaders + setDefaultHeaders a + out <- b + setDefaultHeaders current + return out +getDefaultHeader :: Monad m => HT.HeaderName -> GenericBrowserAction m (Maybe BS.ByteString) +getDefaultHeader b = get >>= \ a -> return $ Map.lookup b (defaultHeaders a) +setDefaultHeader :: Monad m => HT.HeaderName -> Maybe BS.ByteString -> GenericBrowserAction m () +setDefaultHeader b Nothing = deleteDefaultHeader b +setDefaultHeader b (Just c) = insertDefaultHeader (b, c) +insertDefaultHeader :: Monad m => HT.Header -> GenericBrowserAction m () +insertDefaultHeader (b, c) = get >>= \ a -> put a {defaultHeaders = Map.insert b c (defaultHeaders a)} +deleteDefaultHeader :: Monad m => HT.HeaderName -> GenericBrowserAction m () +deleteDefaultHeader b = get >>= \ a -> put a {defaultHeaders = Map.delete b (defaultHeaders a)} +withDefaultHeader :: Monad m => HT.Header -> GenericBrowserAction m a -> GenericBrowserAction m a +withDefaultHeader (a,b) c = do + current <- getDefaultHeader a + insertDefaultHeader (a,b) + out <- c + setDefaultHeader a current + return out + getOverrideHeaders :: Monad m => GenericBrowserAction m HT.RequestHeaders getOverrideHeaders = get >>= \ a -> return $ Map.toList $ overrideHeaders a 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 +setOverrideHeaders b = get >>= \ a -> put a {overrideHeaders = Map.fromList b} withOverrideHeaders:: Monad m => HT.RequestHeaders -> GenericBrowserAction m a -> GenericBrowserAction m a withOverrideHeaders a b = do current <- getOverrideHeaders @@ -554,19 +600,6 @@ insertOverrideHeader (a,b) out <- c setOverrideHeader a current - return out - -getUserAgent :: Monad m => GenericBrowserAction m (Maybe BS.ByteString) -getUserAgent = get >>= \ a -> return $ Map.lookup HT.hUserAgent (overrideHeaders a) -setUserAgent :: Monad m => Maybe BS.ByteString -> GenericBrowserAction m () -setUserAgent Nothing = deleteOverrideHeader HT.hUserAgent -setUserAgent (Just b) = insertOverrideHeader (HT.hUserAgent, b) -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 getCheckStatus :: Monad m => GenericBrowserAction m (Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException)) 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.7.2.1 +version: 1.8 license: BSD3 license-file: LICENSE author: Myles C. Maxfield @@ -27,7 +27,7 @@ , cookie , case-insensitive , time - , http-types + , http-types >= 0.7 , conduit , lifted-base , transformers diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -6,10 +6,12 @@ import Control.Applicative import Control.Monad import Control.Exception (Exception, toException) +import Data.Monoid import qualified Data.ByteString as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import Network.Wai hiding (requestBody) +import Network.Wai hiding (requestBody, requestHeaders) +import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (run) import Network.HTTP.Conduit import Network.HTTP.Conduit.Browser @@ -85,7 +87,7 @@ _ -> return $ responseLBS status404 [] "not found" where tastyCookie = (mk (utf8String "Set-Cookie"), utf8String "flavor=chocolate-chip;") - getHeader s = strictToLazy $ case lookup s $ Network.Wai.requestHeaders req of + getHeader s = strictToLazy $ case lookup s $ Wai.requestHeaders req of Just a -> a Nothing -> S.empty redir2 = (mk (utf8String "Location"), utf8String "/redir2") @@ -105,7 +107,7 @@ _ <- makeRequestLbs request1 makeRequestLbs request2 killThread tid - if (lazyToStrict $ responseBody elbs) /= utf8String "flavor=chocolate-chip" + if lazyToStrict (responseBody elbs) /= "flavor=chocolate-chip" then error "Should have gotten the cookie back!" else return () it "cookie filter can deny cookies" $ do @@ -118,7 +120,7 @@ _ <- makeRequestLbs request1 makeRequestLbs request2 killThread tid - if (lazyToStrict $ responseBody elbs) /= S.empty + if lazyToStrict (responseBody elbs) /= S.empty then error "Shouldn't have gotten the cookie back!" else return () it "user-defined cookies survive redirects" $ do @@ -133,7 +135,7 @@ setCookieJar =<< receiveSetCookie setCookie req default_time True <$> getCookieJar responseBody <$> makeRequestLbs req killThread tid - liftIO $ elbs @?= "nom-nom-nom" + elbs @?= "nom-nom-nom" {- http-conduit-1.9+ cookieJar it "user-defined cookies in req survive redirects" $ do tid <- forkIO $ run 3019 app @@ -154,69 +156,55 @@ tid <- forkIO $ run 3011 app request1 <- parseUrl "http://127.0.0.1:3011/cookies" request2 <- parseUrl "http://127.0.0.1:3011/print-cookies" - (elbs1, elbs2) <- withManager $ \manager -> do + (lbs1, lbs2) <- withManager $ \manager -> do browse manager $ do _ <- makeRequestLbs request1 cookie_jar <- getCookieJar setCookieJar def - elbs1 <- makeRequestLbs request2 + lbs1 <- responseBody <$> makeRequestLbs request2 setCookieJar cookie_jar - elbs2 <- makeRequestLbs request2 - return (elbs1, elbs2) + lbs2 <- responseBody <$> makeRequestLbs request2 + return (lbs1, lbs2) killThread tid - if (((lazyToStrict $ responseBody elbs1) /= S.empty) || - ((lazyToStrict $ responseBody elbs2) /= utf8String "flavor=chocolate-chip")) - then error "Cookie jar got garbled up!" - else return () + when (lbs1 /= "" || lbs2 /= "flavor=chocolate-chip") $ + error "Cookie jar got garbled up!" it "user agent sets correctly" $ do tid <- forkIO $ run 3012 app request <- parseUrl "http://127.0.0.1:3012/useragent" elbs <- withManager $ \manager -> do browse manager $ do - setUserAgent $ Just $ utf8String "abcd" + setDefaultHeader "User-Agent" $ Just "abcd" makeRequestLbs request killThread tid - if (lazyToStrict $ responseBody elbs) /= utf8String "abcd" - then error "Should have gotten the user agent back!" - else return () - it "user agent overrides" $ do + when (responseBody elbs /= "abcd") $ + error "Should have gotten the user agent back!" + it "default headers propagate" $ do tid <- forkIO $ run 3012 app request <- parseUrl "http://127.0.0.1:3012/useragent" elbs <- withManager $ \manager -> do browse manager $ do - setUserAgent $ Just $ utf8String "abcd" - makeRequestLbs request{Network.HTTP.Conduit.requestHeaders = [(hUserAgent, "bwahaha")]} + setDefaultHeader "User-Agent" $ Just "abcd" + makeRequestLbs request killThread tid - let a = lazyToStrict $ responseBody elbs - if a == utf8String "abcd" - then return () - else if a == utf8String "bwahaha" - then error "Should have overwriten request's own header!" - else error $ "Some kind of magic happened, User-Agent: \"" ++ show a ++ "\"." - it "zeroes overrideHeaders" $ do + responseBody elbs @?= "abcd" + it "default headers get overriden" $ do tid <- forkIO $ run 3012 app request <- parseUrl "http://127.0.0.1:3012/useragent" elbs <- withManager $ \manager -> do browse manager $ do - setUserAgent Nothing - setOverrideHeaders [] - makeRequestLbs request{Network.HTTP.Conduit.requestHeaders = [(hUserAgent, "bwahaha")]} + setDefaultHeader "User-Agent" $ Just "bwahaha" + makeRequestLbs request{requestHeaders = [(hUserAgent, "abcd")]} killThread tid - if (lazyToStrict $ responseBody elbs) /= utf8String "bwahaha" - then error "Shouldn't have deleted user-agent!" - else return () - it "setting overrideheaders doesn't unset useragent" $ do + responseBody elbs @?= "abcd" + it "user agent overrides" $ do tid <- forkIO $ run 3012 app request <- parseUrl "http://127.0.0.1:3012/useragent" elbs <- withManager $ \manager -> do browse manager $ do - setUserAgent $ Just "abcd" - setOverrideHeaders [] - makeRequestLbs request{Network.HTTP.Conduit.requestHeaders = [(hUserAgent, "bwahaha")]} + setOverrideHeader hUserAgent $ Just $ utf8String "abcd" + makeRequestLbs request{requestHeaders = [(hUserAgent, "bwahaha")]} killThread tid - if (lazyToStrict $ responseBody elbs) /= utf8String "abcd" - then error "Should have overrided user-agent!" - else return () + responseBody elbs @?= "abcd" it "doesn't override additional headers" $ do tid <- forkIO $ run 3012 app request <- parseUrl "http://127.0.0.1:3012/accept" @@ -224,40 +212,25 @@ browse manager $ do insertOverrideHeader ("User-Agent", "http-conduit") insertOverrideHeader ("Connection", "keep-alive") - makeRequestLbs request{Network.HTTP.Conduit.requestHeaders = [("User-Agent", "another agent"), ("Accept", "everything/digestible")]} + makeRequestLbs request{requestHeaders = [("User-Agent", "another agent"), ("Accept", "everything/digestible")]} killThread tid - if (lazyToStrict $ responseBody elbs) /= utf8String "everything/digestible" - then error "Shouldn't have deleted Accept header!" - else return () + when (responseBody elbs /= "everything/digestible") $ + error "Shouldn't have deleted Accept header!" it "withOverrideHeader: doesn't override additional headers" $ do tid <- forkIO $ run 3012 app request1 <- parseUrl "http://127.0.0.1:3012/accept" request2 <- parseUrl "http://127.0.0.1:3012/useragent" - (bs1, bs2) <- withManager $ flip browse $ do + (lbs1, lbs2) <- withManager $ flip browse $ do insertOverrideHeader ("User-Agent", "another agent") withOverrideHeader ("User-Agent", "http-conduit") $ insertOverrideHeader ("Accept", "everything/digestible") - (,) <$> (lazyToStrict . responseBody <$> makeRequestLbs request1) - <*> (lazyToStrict . responseBody <$> makeRequestLbs request2) - killThread tid - when (bs1 /= utf8String "everything/digestible") $ - error "Shouldn't have deleted Accept header!" - when (bs2 /= "another agent") $ - error "Shouldn't have overriden user agent!" - it "withUserAgent: doesn't override additional headers" $ do - tid <- forkIO $ run 3012 app - request1 <- parseUrl "http://127.0.0.1:3012/accept" - request2 <- parseUrl "http://127.0.0.1:3012/useragent" - (bs1, bs2) <- withManager $ flip browse $ do - setUserAgent $ Just "another agent" - withUserAgent (Just "different agent") $ - insertOverrideHeader ("Accept", "everything/digestible") - (,) <$> (lazyToStrict . responseBody <$> makeRequestLbs request1) - <*> (lazyToStrict . responseBody <$> makeRequestLbs request2) + r1 <- responseBody <$> makeRequestLbs request1 + r2 <- responseBody <$> makeRequestLbs request2 + return (r1,r2) killThread tid - when (bs1 /= utf8String "everything/digestible") $ + when (lbs1 /= "everything/digestible") $ error "Shouldn't have deleted Accept header!" - when (bs2 /= "another agent") $ + when (lbs2 /= "another agent") $ error "Shouldn't have overriden user agent!" it "authorities get set correctly" $ do tid <- forkIO $ run 3013 app @@ -267,7 +240,7 @@ setAuthorities $ const $ Just (user, pass) makeRequestLbs request killThread tid - if (lazyToStrict $ responseBody elbs) /= (utf8String "Basic " `S.append` (encode $ user `S.append` ":" `S.append` pass)) + if lazyToStrict (responseBody elbs) /= (utf8String "Basic " `mappend` (encode $ user `mappend` ":" `mappend` pass)) then error "Authorities didn't get set correctly!" else return () it "can follow redirects" $ do @@ -278,7 +251,7 @@ setMaxRedirects $ Just 2 makeRequestLbs request killThread tid - if (lazyToStrict $ responseBody elbs) /= dummy + if lazyToStrict (responseBody elbs) /= dummy then error "Should be able to follow 2 redirects" else return () it "max redirects fails correctly" $ do @@ -393,6 +366,6 @@ lbs2 <- makeRequestLbs request2 return (lbs1, lbs2) killThread tid - if (lazyToStrict $ responseBody elbs1) /= utf8String "homepage" || (lazyToStrict $ responseBody elbs2) /= dummy + if responseBody elbs1 /= "homepage" || lazyToStrict (responseBody elbs2) /= dummy then error "Should have followed the relative reference" else return ()