http-conduit-browser 1.7.1.2 → 1.7.2
raw patch · 3 files changed
+92/−60 lines, 3 filesdep −mtldep −utf8-stringPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: mtl, utf8-string
API changes (from Hackage documentation)
- Network.HTTP.Conduit.Browser: data Manager :: *
+ Network.HTTP.Conduit.Browser: downloadFile :: (MonadResource m, MonadBaseControl IO m) => FilePath -> Request (ResourceT IO) -> GenericBrowserAction m ()
Files
- Network/HTTP/Conduit/Browser.hs +68/−37
- http-conduit-browser.cabal +2/−5
- test/main.hs +22/−18
Network/HTTP/Conduit/Browser.hs view
@@ -23,9 +23,11 @@ -- -- Here is an example program: ----- > import qualified Data.ByteString as B+-- > {-# LANGUAGE OverloadedStrings #-} -- > import qualified Data.ByteString.Lazy as LB--- > import qualified Data.ByteString.UTF8 as UB+-- > import qualified Data.Text.Encoding as TE+-- > import qualified Data.Text.Lazy.Encoding as TLE+-- > import qualified Data.Text.Lazy.IO as TLIO -- > import Data.Conduit -- > import Network.HTTP.Conduit -- > import Network.HTTP.Conduit.Browser@@ -34,8 +36,8 @@ -- > req1 :: IO (Request (ResourceT IO)) -- > req1 = do -- > req <- parseUrl "http://www.myurl.com/login.php"--- > return $ urlEncodedBody [ (UB.fromString "name", UB.fromString "litherum")--- > , (UB.fromString "pass", UB.fromString "S33kRe7")+-- > return $ urlEncodedBody [ (TE.encodeUtf8 "name", TE.encodeUtf8 "litherum")+-- > , (TE.encodeUtf8 "pass", TE.encodeUtf8 "S33kRe7") -- > ] req -- > -- > -- Once authenticated, run this request@@ -54,7 +56,7 @@ -- > r1 <- req1 -- > r2 <- req2 -- > out <- runResourceT $ browse man $ action r1 r2--- > putStrLn $ UB.toString $ B.concat $ LB.toChunks $ responseBody out+-- > TLIO.putStrLn $ TLE.decodeUtf8 $ responseBody out module Network.HTTP.Conduit.Browser (@@ -65,14 +67,16 @@ , parseRelativeUrl , makeRequest , makeRequestLbs+ , downloadFile -- * Browser state+ -- | You can save and restore the state at will , BrowserState , defaultState , getBrowserState , setBrowserState , withBrowserState -- ** Manager- , Manager+ -- | The active manager, managing the connection pool , getManager , setManager -- ** Location@@ -190,7 +194,9 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L-import Control.Monad.State+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.State import Control.Exception import qualified Control.Exception.Lifted as LE import Data.Conduit@@ -205,14 +211,16 @@ import Network.URI (URI (..), URIAuth (..), parseRelativeReference, relativeTo, uriToString) import Data.Time.Clock (getCurrentTime, UTCTime) import Data.CaseInsensitive (mk)-import Data.ByteString.UTF8 (fromString) import Data.List (partition)-import qualified Data.String as IsString (fromString)+import Data.String (fromString) import Web.Cookie (parseSetCookie) import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Map as Map import Network.HTTP.Conduit+#if MIN_VERSION_http_conduit(1,8,5)+import Network.HTTP.Conduit.Internal (httpRedirect, getUri, setUri)+#endif import Control.Monad.Trans.Resource (liftResourceT) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Failure (Failure)@@ -259,15 +267,20 @@ -- -- 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+parseRelativeUrl url = maybe err (parse . use) =<< gets currentLocation where err = throw $ InvalidUrlException url "Invalid URL" uri = fromMaybe err $ parseRelativeReference url- use = flip (uriToString id) "" . fromMaybe err . relativeTo' uri+ use = fromMaybe err . relativeTo' uri #if MIN_VERSION_network(2,4,0) relativeTo' x = Just . relativeTo x #else relativeTo' = relativeTo #endif+#if MIN_VERSION_http_conduit(1,8,5)+ parse = setUri def+#else+ parse = parseUrl . flip (uriToString id) ""+#endif -- | Make a request, using all the state in the current BrowserState makeRequest :: (MonadBaseControl IO m, MonadResource m) => Request (ResourceT IO) -> GenericBrowserAction m (Response (ResumableSource (ResourceT IO) BS.ByteString))@@ -303,6 +316,9 @@ case check_status (responseStatus resp) (responseHeaders resp) of Nothing -> return resp Just e' -> retryHelper request' (retry_count - 1) max_redirects check_status (Just e')+ applyAuthorities auths request' = case auths request' of+ Just (user, pass) -> applyBasicAuth user pass request'+ Nothing -> request' performRequest request' = do s@(BrowserState { manager = manager' , authorities = auths@@ -319,36 +335,44 @@ , currentLocation = Just $ getUri request'' } return (request'', res, response)+#if MIN_VERSION_http_conduit(1,8,5)+ runRedirectionChain request0 redirect_count _+ = httpRedirect+ redirect_count+ (\request' -> do+ (request'', res, response) <- performRequest request'+ let mreq = getRedirectedRequest request'' (responseHeaders response) (HT.statusCode (responseStatus response))+ return (res, mreq))+ liftResourceT+ request0+#else runRedirectionChain request' redirect_count ress | redirect_count == (-1) = LE.throwIO . TooManyRedirects =<< mapM (liftResourceT . lbsResponse) ress | otherwise = do (request'', res, response) <- performRequest request'- let code = HT.statusCode (responseStatus response)- if code >= 300 && code < 400- then do request''' <- case getRedirectedRequest request'' (responseHeaders response) code of- Just a -> return a- Nothing -> LE.throwIO . UnparseableRedirect =<< (liftResourceT $ lbsResponse response)- -- Canibalised from Network.HTTP.Conduit, should be made visible there.- -- Allow the original connection to return to the- -- connection pool immediately by flushing the body.- -- If the response body is too large, don't flush, but- -- instead just close the connection.- let maxFlush = 1024- readMay bs =- case S8.readInt bs of- Just (i, bs') | BS.null bs' -> Just i- _ -> Nothing- sink =- case lookup (IsString.fromString "content-length") (responseHeaders res) >>= readMay of- Just i | i > maxFlush -> return ()- _ -> CB.isolate maxFlush =$ sinkNull- liftResourceT $ responseBody res $$+- sink- runRedirectionChain request''' (redirect_count - 1) (res:ress)- else return res- applyAuthorities auths request' = case auths request' of- Just (user, pass) -> applyBasicAuth user pass request'- Nothing -> request'+ case getRedirectedRequest request'' (responseHeaders response) (HT.statusCode (responseStatus response)) of+ Nothing -> return res+ Just request''' -> do+ -- Canibalised from Network.HTTP.Conduit, should be made visible there.+ -- Allow the original connection to return to the+ -- connection pool immediately by flushing the body.+ -- If the response body is too large, don't flush, but+ -- instead just close the connection.+ let maxFlush = 1024+ readMay bs =+ case S8.readInt bs of+ Just (i, bs') | BS.null bs' -> Just i+ _ -> Nothing+ sink =+ case lookup (fromString "content-length") (responseHeaders res) >>= readMay of+ Just i | i > maxFlush -> return ()+ _ -> CB.isolate maxFlush =$ sinkNull+ liftResourceT $ responseBody res $$+- sink + -- And now perform the actual redirect+ runRedirectionChain request''' (redirect_count - 1) (res:ress)+#endif+ -- | Make a request and pack the result as a lazy bytestring. -- -- Note: Even though this function returns a lazy bytestring, it does not@@ -358,6 +382,12 @@ makeRequestLbs :: (MonadBaseControl IO m, MonadResource m) => Request (ResourceT IO) -> GenericBrowserAction m (Response L.ByteString) makeRequestLbs = liftResourceT . lbsResponse <=< makeRequest +-- | Make a request and sink the 'responseBody' to a file.+downloadFile :: (MonadResource m, MonadBaseControl IO m) => FilePath -> Request (ResourceT IO) -> GenericBrowserAction m ()+downloadFile file request = do+ res <- makeRequest request+ liftResourceT $ responseBody res $$+- CB.sinkFile file+ applyOverrideHeaders :: Map.Map HT.HeaderName BS.ByteString -> Request a -> Request a applyOverrideHeaders ov request' = request' {requestHeaders = x $ requestHeaders request'} where x r = Map.toList $ Map.union ov (Map.fromList r)@@ -371,7 +401,6 @@ set_cookies = map parseSetCookie set_cookie_data cookieJar' = foldl (\ cj c -> insertCheckedCookie c cj True) cookie_jar --- | You can save and restore the state at will getBrowserState :: Monad m => GenericBrowserAction m BrowserState getBrowserState = get setBrowserState :: Monad m => BrowserState -> GenericBrowserAction m ()@@ -553,6 +582,7 @@ setManager :: Monad m => Manager -> GenericBrowserAction m () setManager b = get >>= \ a -> put a {manager = b} +#if !MIN_VERSION_http_conduit(1,8,5) -- | Extract a 'URI' from the request. -- Canibalised from Network.HTTP.Conduit.Request, should be made visible there. getUri :: Request m' -> URI@@ -569,3 +599,4 @@ , uriQuery = S8.unpack $ queryString req , uriFragment = "" }+#endif
http-conduit-browser.cabal view
@@ -1,5 +1,5 @@ name: http-conduit-browser-version: 1.7.1.2+version: 1.7.2 license: BSD3 license-file: LICENSE author: Myles C. Maxfield <myles.maxfield@gmail.com>@@ -25,13 +25,12 @@ , http-conduit >= 1.7.0 , data-default , cookie- , utf8-string , case-insensitive , time , http-types , conduit , lifted-base- , mtl+ , transformers , bytestring , containers , socks@@ -59,7 +58,6 @@ , conduit , case-insensitive , containers- , utf8-string , transformers , resourcet , network-conduit@@ -68,7 +66,6 @@ , base64-bytestring , cookie , time- , mtl , warp , wai , socks
test/main.hs view
@@ -6,6 +6,8 @@ import Control.Monad import Control.Exception (Exception, toException) 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.Handler.Warp (run) import Network.HTTP.Conduit@@ -15,7 +17,6 @@ import Control.Concurrent (forkIO, killThread) import Network.HTTP.Types import Control.Exception.Lifted (try)-import Data.ByteString.UTF8 (fromString) import Data.CaseInsensitive (mk) import qualified Data.ByteString.Lazy as L import Data.IORef@@ -28,6 +29,9 @@ instance Exception TestException +utf8String :: String -> S.ByteString+utf8String = TE.encodeUtf8 . T.pack+ strictToLazy :: S.ByteString -> L.ByteString strictToLazy = L.fromChunks . replicate 1 @@ -71,12 +75,12 @@ ["redir3"] -> return $ responseLBS status200 [] $ strictToLazy dummy _ -> return $ responseLBS status404 [] "not found" - where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;")+ where tastyCookie = (mk (utf8String "Set-Cookie"), utf8String "flavor=chocolate-chip;") getHeader s = strictToLazy $ case lookup s $ Network.Wai.requestHeaders req of Just a -> a Nothing -> S.empty- redir2 = (mk (fromString "Location"), fromString "/redir2")- redir3 = (mk (fromString "Location"), fromString "/redir3")+ redir2 = (mk (utf8String "Location"), utf8String "/redir2")+ redir3 = (mk (utf8String "Location"), utf8String "/redir3") main :: IO () main = do@@ -92,7 +96,7 @@ _ <- makeRequestLbs request1 makeRequestLbs request2 killThread tid- if (lazyToStrict $ responseBody elbs) /= fromString "flavor=chocolate-chip"+ if (lazyToStrict $ responseBody elbs) /= utf8String "flavor=chocolate-chip" then error "Should have gotten the cookie back!" else return () it "cookie filter can deny cookies" $ do@@ -123,7 +127,7 @@ return (elbs1, elbs2) killThread tid if (((lazyToStrict $ responseBody elbs1) /= S.empty) ||- ((lazyToStrict $ responseBody elbs2) /= fromString "flavor=chocolate-chip"))+ ((lazyToStrict $ responseBody elbs2) /= utf8String "flavor=chocolate-chip")) then error "Cookie jar got garbled up!" else return () it "user agent sets correctly" $ do@@ -131,10 +135,10 @@ request <- parseUrl "http://127.0.0.1:3012/useragent" elbs <- withManager $ \manager -> do browse manager $ do- setUserAgent $ Just $ fromString "abcd"+ setUserAgent $ Just $ utf8String "abcd" makeRequestLbs request killThread tid- if (lazyToStrict $ responseBody elbs) /= fromString "abcd"+ if (lazyToStrict $ responseBody elbs) /= utf8String "abcd" then error "Should have gotten the user agent back!" else return () it "user agent overrides" $ do@@ -142,13 +146,13 @@ request <- parseUrl "http://127.0.0.1:3012/useragent" elbs <- withManager $ \manager -> do browse manager $ do- setUserAgent $ Just $ fromString "abcd"+ setUserAgent $ Just $ utf8String "abcd" makeRequestLbs request{Network.HTTP.Conduit.requestHeaders = [(hUserAgent, "bwahaha")]} killThread tid let a = lazyToStrict $ responseBody elbs- if a == fromString "abcd"+ if a == utf8String "abcd" then return ()- else if a == fromString "bwahaha"+ 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@@ -160,7 +164,7 @@ setOverrideHeaders [] makeRequestLbs request{Network.HTTP.Conduit.requestHeaders = [(hUserAgent, "bwahaha")]} killThread tid- if (lazyToStrict $ responseBody elbs) /= fromString "bwahaha"+ if (lazyToStrict $ responseBody elbs) /= utf8String "bwahaha" then error "Shouldn't have deleted user-agent!" else return () it "setting overrideheaders doesn't unset useragent" $ do@@ -172,7 +176,7 @@ setOverrideHeaders [] makeRequestLbs request{Network.HTTP.Conduit.requestHeaders = [(hUserAgent, "bwahaha")]} killThread tid- if (lazyToStrict $ responseBody elbs) /= fromString "abcd"+ if (lazyToStrict $ responseBody elbs) /= utf8String "abcd" then error "Should have overrided user-agent!" else return () it "doesn't override additional headers" $ do@@ -184,7 +188,7 @@ insertOverrideHeader ("Connection", "keep-alive") makeRequestLbs request{Network.HTTP.Conduit.requestHeaders = [("User-Agent", "another agent"), ("Accept", "everything/digestible")]} killThread tid- if (lazyToStrict $ responseBody elbs) /= fromString "everything/digestible"+ if (lazyToStrict $ responseBody elbs) /= utf8String "everything/digestible" then error "Shouldn't have deleted Accept header!" else return () it "withOverrideHeader: doesn't override additional headers" $ do@@ -198,7 +202,7 @@ (,) <$> (lazyToStrict . responseBody <$> makeRequestLbs request1) <*> (lazyToStrict . responseBody <$> makeRequestLbs request2) killThread tid- when (bs1 /= fromString "everything/digestible") $+ when (bs1 /= utf8String "everything/digestible") $ error "Shouldn't have deleted Accept header!" when (bs2 /= "another agent") $ error "Shouldn't have overriden user agent!"@@ -213,7 +217,7 @@ (,) <$> (lazyToStrict . responseBody <$> makeRequestLbs request1) <*> (lazyToStrict . responseBody <$> makeRequestLbs request2) killThread tid- when (bs1 /= fromString "everything/digestible") $+ when (bs1 /= utf8String "everything/digestible") $ error "Shouldn't have deleted Accept header!" when (bs2 /= "another agent") $ error "Shouldn't have overriden user agent!"@@ -225,7 +229,7 @@ setAuthorities $ const $ Just (user, pass) makeRequestLbs request killThread tid- if (lazyToStrict $ responseBody elbs) /= (fromString "Basic " `S.append` (encode $ user `S.append` ":" `S.append` pass))+ if (lazyToStrict $ responseBody elbs) /= (utf8String "Basic " `S.append` (encode $ user `S.append` ":" `S.append` pass)) then error "Authorities didn't get set correctly!" else return () it "can follow redirects" $ do@@ -351,6 +355,6 @@ lbs2 <- makeRequestLbs request2 return (lbs1, lbs2) killThread tid- if (lazyToStrict $ responseBody elbs1) /= fromString "homepage" || (lazyToStrict $ responseBody elbs2) /= dummy+ if (lazyToStrict $ responseBody elbs1) /= utf8String "homepage" || (lazyToStrict $ responseBody elbs2) /= dummy then error "Should have followed the relative reference" else return ()