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 @@ -33,7 +33,7 @@ -- > import Network.HTTP.Conduit.Browser -- > -- > -- The web request to log in to a service --- > req1 :: IO (Request (ResourceT IO)) +-- > req1 :: IO (Request) -- > req1 = do -- > req <- parseUrl "http://www.myurl.com/login.php" -- > return $ urlEncodedBody [ (TE.encodeUtf8 "name", TE.encodeUtf8 "litherum") @@ -45,7 +45,7 @@ -- > req2 = parseUrl "http://www.myurl.com/main.php" -- > -- > -- Bind two BrowserActions together --- > action :: Request (ResourceT IO) -> Request (ResourceT IO) -> BrowserAction (Response LB.ByteString) +-- > action :: Request -> Request -> BrowserAction (Response LB.ByteString) -- > action r1 r2 = do -- > _ <- makeRequestLbs r1 -- > makeRequestLbs r2 @@ -69,7 +69,7 @@ , parseRelativeUrl , makeRequest , makeRequestLbs - , downloadFile +-- , downloadFile -- * Browser state -- | You can save and restore the state at will , BrowserState @@ -116,14 +116,6 @@ , 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' @@ -156,13 +148,6 @@ , getAuthorities , setAuthorities , withAuthorities - -- ** Client certificates - -- | SSL client certificates - -- - -- default: @Nothing@ - , getClientCertificates - , setClientCertificates - , withClientCertificates -- ** Headers -- *** Default headers -- | Specifies Headers that should be added to 'Request', @@ -215,77 +200,68 @@ ) where +import Network.HTTP.Client import Network.HTTP.Conduit -import Network.HTTP.Conduit.Internal (httpRedirect - ,getUri - ,setUri - ,generateCookie - ,insertCheckedCookie - ) +import Network.HTTP.Client.Internal (setUri) import qualified Network.HTTP.Types as HT -import Network.Socks5 (SocksConf) import Network.URI (URI (..), parseRelativeReference, relativeTo) import Data.Time.Clock (getCurrentTime, UTCTime) import Web.Cookie (parseSetCookie) -import Data.Certificate.X509 (X509) -import Network.TLS (PrivateKey) import qualified Data.Conduit as C -import qualified Data.Conduit.Binary as CB import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L +import Data.Default import Data.Function (on) import Data.List (partition ,union ) import Data.Maybe (catMaybes, fromMaybe) import Control.Monad -import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.State -import Control.Monad.Trans.Resource (MonadResource, ResourceT, liftResourceT) +import Control.Monad.Trans.Resource (ResourceT, liftResourceT, MonadResource) import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Failure +import Control.Monad.IO.Class +import Control.Monad.Base +import Control.Monad.Catch (MonadThrow, throwM) import qualified Control.Exception.Lifted as LE import Control.Exception (SomeException ,toException) import qualified Data.Map as Map data BrowserState = BrowserState - { currentLocation :: Maybe URI - , maxRedirects :: Maybe Int - , maxRetryCount :: Int - , timeout :: Maybe Int - , authorities :: Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString) - , browserClientCertificates :: Maybe [(X509, Maybe PrivateKey)] - , cookieFilter :: Request (ResourceT IO) -> Cookie -> IO Bool - , browserCookieJar :: CookieJar - , 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 -> CookieJar -> Maybe SomeException) - , manager :: Manager + { currentLocation :: Maybe URI + , maxRedirects :: Maybe Int + , maxRetryCount :: Int + , timeout :: Maybe Int + , authorities :: Request -> Maybe (BS.ByteString, BS.ByteString) + , cookieFilter :: Request -> Cookie -> IO Bool + , browserCookieJar :: CookieJar + , currentProxy :: Maybe Proxy + , overrideHeaders :: Map.Map HT.HeaderName BS.ByteString + , defaultHeaders :: Map.Map HT.HeaderName BS.ByteString + , browserCheckStatus :: Maybe (HT.Status -> HT.ResponseHeaders -> CookieJar -> Maybe SomeException) + , manager :: Manager } defaultState :: Manager -> BrowserState -defaultState m = BrowserState { currentLocation = Nothing - , maxRedirects = Nothing - , maxRetryCount = 0 - , timeout = Nothing - , authorities = const Nothing - , browserClientCertificates = Nothing - , cookieFilter = const $ const $ return True - , browserCookieJar = def - , currentProxy = Nothing - , currentSocksProxy = Nothing - , overrideHeaders = Map.empty - , defaultHeaders = Map.singleton HT.hUserAgent "http-conduit-browser" - , browserCheckStatus = Nothing - , manager = m - } +defaultState m = BrowserState + { currentLocation = Nothing + , maxRedirects = Nothing + , maxRetryCount = 0 + , timeout = Nothing + , authorities = const Nothing + , cookieFilter = const $ const $ return True + , browserCookieJar = def + , currentProxy = Nothing + , overrideHeaders = Map.empty + , defaultHeaders = Map.singleton HT.hUserAgent "http-conduit-browser" + , browserCheckStatus = Nothing + , manager = m + } type BrowserAction = GenericBrowserAction (ResourceT IO) @@ -298,47 +274,50 @@ -- | 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 :: MonadThrow m => String -> GenericBrowserAction m Request parseRelativeUrl url = maybe err use =<< gets currentLocation - where err = lift $ failure $ InvalidUrlException url "Invalid URL" + where + err = lift $ throwM $ InvalidUrlException url "Invalid URL" use loc = maybe err (setUri def) $ do uri <- parseRelativeReference url relativeTo' uri loc -#if MIN_VERSION_network(2,4,0) relativeTo' x = Just . relativeTo x -#else - relativeTo' = relativeTo -#endif -- | Make a request, using all the state in the current BrowserState -makeRequest :: (MonadBaseControl IO m, MonadResource m) => Request (ResourceT IO) -> GenericBrowserAction m (Response (C.ResumableSource (ResourceT IO) BS.ByteString)) +makeRequest :: (MonadBaseControl IO m, MonadIO m, MonadResource m) => Request -> GenericBrowserAction m (Response (C.ResumableSource (ResourceT IO) BS.ByteString)) makeRequest req = do BrowserState { maxRetryCount = max_retry_count , maxRedirects = max_redirects , timeout = time_out , currentProxy = current_proxy - , currentSocksProxy = current_socks_proxy , defaultHeaders = default_headers , overrideHeaders = override_headers , browserCheckStatus = current_check_status - , browserClientCertificates = client_certificates } <- get retryHelper (applyOverrideHeaders override_headers $ applyDefaultHeaders default_headers $ req { redirectCount = 0 , proxy = maybe (proxy req) Just current_proxy - , socksProxy = maybe (socksProxy req) Just current_socks_proxy + --, socksProxy = maybe (socksProxy req) Just current_socks_proxy , checkStatus = \ _ _ _ -> Nothing , responseTimeout = maybe (responseTimeout req) Just time_out - , clientCertificates = fromMaybe (clientCertificates req) client_certificates + --, clientCertificates = fromMaybe (clientCertificates req) client_certificates }) max_retry_count (fromMaybe (redirectCount req) max_redirects) (fromMaybe (checkStatus req) current_check_status) Nothing where + retryHelper + :: (MonadBaseControl IO m, MonadIO m, MonadResource m) + => Request + -> Int + -> Int + -> (HT.Status -> HT.ResponseHeaders -> CookieJar -> Maybe SomeException) + -> Maybe SomeException + -> GenericBrowserAction m (Response (C.ResumableSource (ResourceT IO) BS.ByteString)) retryHelper request' retry_count max_redirects check_status e | retry_count < 0 = case e of Just e' -> LE.throwIO e' @@ -353,14 +332,17 @@ Nothing -> return res Just e' -> retryHelper request' (retry_count - 1) max_redirects check_status (Just e') runRedirectionChain request' redirect_count - = httpRedirect + = httpRedirectBase redirect_count (\request -> do res <- performRequest request let mreq = getRedirectedRequest request (responseHeaders res) (responseCookieJar res) (HT.statusCode $ responseStatus res) return (res, mreq)) - liftResourceT request' + performRequest + :: (MonadBaseControl IO m, MonadIO m, MonadResource m) + => Request + -> GenericBrowserAction m (Response (C.ResumableSource (ResourceT IO) BS.ByteString)) performRequest request'' = do s@(BrowserState { manager = manager' , authorities = auths @@ -374,7 +356,7 @@ cookie_jar' } res <- liftResourceT $ http request' manager' - (cookie_jar, _) <- liftIO $ do + (cookie_jar, _) <- liftBase $ do now <- getCurrentTime updateMyCookieJar res request' now cookie_jar' cookie_filter put $ s { browserCookieJar = cookie_jar @@ -382,17 +364,36 @@ } return res -applyAuthorities :: (Request a -> Maybe (BS.ByteString, BS.ByteString)) -> Request a -> Request a +httpRedirectBase + :: (MonadBaseControl IO m, MonadIO m, MonadResource m) + => Int -- ^ 'redirectCount' + -> (Request -> m (Response (C.ResumableSource (ResourceT IO) BS.ByteString), Maybe Request)) -- ^ function which performs a request and returns a response, and possibly another request if there's a redirect. + -> Request + -> m (Response (C.ResumableSource (ResourceT IO) BS.ByteString)) +httpRedirectBase count0 http' req0 = go count0 req0 [] + where + go count _ ress | count < 0 = LE.throwIO . TooManyRedirects =<< mapM (liftResourceT . lbsResponse) ress + go count req' ress = do + (res, mreq) <- http' req' + case mreq of + Just req -> do + liftIO $ responseClose res + + -- And now perform the actual redirect + go (count - 1) req (res:ress) + Nothing -> return res + +applyAuthorities :: (Request -> Maybe (BS.ByteString, BS.ByteString)) -> Request -> Request applyAuthorities auths request' = case auths request' of Just (user, pass) -> applyBasicAuth user pass request' Nothing -> request' -applyDefaultHeaders :: Map.Map HT.HeaderName BS.ByteString -> Request a -> Request a +applyDefaultHeaders :: Map.Map HT.HeaderName BS.ByteString -> Request -> Request 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 :: Map.Map HT.HeaderName BS.ByteString -> Request -> Request applyOverrideHeaders ov request = request {requestHeaders = x $ requestHeaders request} where x r = Map.toList $ Map.union ov (Map.fromList r) @@ -402,16 +403,19 @@ -- 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 :: (MonadIO m, MonadResource m, MonadBaseControl IO m) => Request -> 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 :: MonadBaseControl IO m => FilePath -> Request -> GenericBrowserAction m () downloadFile file request = do res <- makeRequest request - liftResourceT $ responseBody res C.$$+- CB.sinkFile file + liftBase $ C.runResourceT $ bodyReaderSource (responseBody res) C.$$ CB.sinkFile file +-} -updateMyCookieJar :: Response a -> Request (ResourceT IO) -> UTCTime -> CookieJar -> (Request (ResourceT IO) -> Cookie -> IO Bool) -> IO (CookieJar, Response a) +updateMyCookieJar :: Response a -> Request -> UTCTime -> CookieJar -> (Request -> 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}) @@ -458,17 +462,13 @@ GENERIC_FIELD(getTimeout, setTimeout, withTimeout, timeout, Maybe Int) -GENERIC_FIELD(getAuthorities, setAuthorities, withAuthorities, authorities, Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)) - -GENERIC_FIELD(getClientCertificates, setClientCertificates, withClientCertificates, browserClientCertificates, Maybe [(X509, Maybe PrivateKey)]) +GENERIC_FIELD(getAuthorities, setAuthorities, withAuthorities, authorities, Request -> Maybe (BS.ByteString, BS.ByteString)) -GENERIC_FIELD(getCookieFilter, setCookieFilter, withCookieFilter, cookieFilter, Request (ResourceT IO) -> Cookie -> IO Bool) +GENERIC_FIELD(getCookieFilter, setCookieFilter, withCookieFilter, cookieFilter, Request -> Cookie -> IO Bool) GENERIC_FIELD(getCookieJar, setCookieJar, withCookieJar, browserCookieJar, CookieJar) GENERIC_FIELD(getCurrentProxy, setCurrentProxy, withCurrentProxy, currentProxy, Maybe Proxy) - -GENERIC_FIELD(getCurrentSocksProxy, setCurrentSocksProxy, withCurrentSocksProxy, currentSocksProxy, Maybe SocksConf) GENERIC_FIELD(getCheckStatus, setCheckStatus, withCheckStatus, browserCheckStatus, Maybe (HT.Status -> HT.ResponseHeaders -> CookieJar -> 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,14 +1,16 @@ name: http-conduit-browser -version: 1.9.0.2 +version: 2.0.0.0 license: BSD3 license-file: LICENSE author: Myles C. Maxfield -maintainer: kudah +maintainer: synopsis: Browser interface to the http-conduit package description: This package creates a monad representing things that browsers do, letting you elegantly describe a browsing session. This package wraps the http-conduit package by Michael Snoyman. + + This package is abandoned and unsupported, use http://hackage.haskell.org/package/wreq category: Web, Conduit stability: Stable cabal-version: >= 1.8 @@ -22,23 +24,22 @@ library build-depends: base >= 4 && < 5 - , http-conduit >= 1.9 && < 1.10 + , http-client >= 0.3 && < 1 + , http-conduit >= 2.1.5 && < 3 + , exceptions , data-default , cookie - , case-insensitive , time , http-types >= 0.7 , conduit , lifted-base + , transformers-base , transformers , bytestring , containers - , socks - , network >= 2.3 - , failure >= 0.2 + , network-uri , monad-control - , resourcet >= 0.3 && < 0.5 - , certificate, tls + , resourcet >= 1 && < 2 exposed-modules: Network.HTTP.Conduit.Browser ghc-options: -Wall @@ -50,9 +51,10 @@ ghc-options: -Wall build-depends: http-conduit-browser - , base >= 4 && < 5 + , base >= 4 && < 5 , HUnit - , hspec >= 1.3 + , hspec >= 1.3 + , http-client , http-conduit , blaze-builder , bytestring @@ -63,16 +65,12 @@ , containers , transformers , resourcet - , network-conduit , lifted-base , http-types , base64-bytestring , cookie , time , warp - , wai - , socks - , network >= 2.3 - , failure + , wai == 2.* + , network >= 2.3 , monad-control - , certificate, tls diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -14,10 +14,8 @@ import Network.Wai hiding (requestBody, requestHeaders) import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (run) -import Network.HTTP.Conduit -#if MIN_VERSION_http_conduit(1,9,0) -import Network.HTTP.Conduit.Internal (receiveSetCookie) -#endif +import Network.HTTP.Client hiding (withManager) +import Network.HTTP.Conduit (withManager) import Network.HTTP.Conduit.Browser import Data.ByteString.Base64 (encode) import Data.Typeable (Typeable) @@ -140,7 +138,6 @@ responseBody <$> makeRequestLbs req killThread tid elbs @?= "nom-nom-nom" -#if MIN_VERSION_http_conduit(1,9,0) it "custom cookies in Request's cookie jar survive redirects" $ do tid <- forkIO $ run 3019 app req <- parseUrl "http://127.0.0.1:3019/cookie_redir2" @@ -171,7 +168,6 @@ responseBody <$> makeRequestLbs request killThread tid liftIO $ elbs @?= "nom-nom-nom" -#endif it "can save and load cookie jar" $ do tid <- forkIO $ run 3011 app request1 <- parseUrl "http://127.0.0.1:3011/cookies"