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 @@ -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 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.1.2 +version: 1.7.2 license: BSD3 license-file: LICENSE author: Myles C. Maxfield @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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 ()