http-conduit-browser 1.7.2.1 → 1.8

raw patch · 3 files changed

+118/−112 lines, 3 filesdep ~http-typesPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: http-types

API changes (from Hackage documentation)

Files

• Network/HTTP/Conduit/Browser.hs +76/−43
• http-conduit-browser.cabal +2/−2
• test/main.hs +40/−67

@@ -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))

@@ -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 <myles.maxfield@gmail.com>@@ -27,7 +27,7 @@                  , cookie                  , case-insensitive                  , time-                 , http-types+                 , http-types            >= 0.7                  , conduit                  , lifted-base                  , transformers

@@ -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 ()