diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -124,12 +124,12 @@ import Data.Default (def) import Control.Exception.Lifted (throwIO) -import Control.Monad.Base (liftBase) import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Conduit as C import Data.Conduit.Blaze (builderToByteString) -import Control.Monad.Trans.Resource (ResourceT, ResourceIO) +import Data.Conduit (MonadResource) import Control.Exception.Lifted (try, SomeException) import Data.Time.Clock @@ -160,12 +160,12 @@ -- Note: Unlike previous versions, this function will perform redirects, as -- specified by the 'redirectCount' setting. http - :: ResourceIO m + :: (MonadResource m, MonadBaseControl IO m) => Request m -> Manager - -> ResourceT m (Response (C.Source m S.ByteString)) + -> m (Response (C.Source m S.ByteString)) http req0 manager = do - res@(Response status hs body) <- + res@(Response status _version hs body) <- if redirectCount req0 == 0 then httpRaw req0 manager else go (redirectCount req0) req0 def @@ -173,24 +173,24 @@ Nothing -> return res Just exc -> do C.sourceClose body - liftBase $ throwIO exc + liftIO $ throwIO exc where - go 0 _ _ = liftBase $ throwIO TooManyRedirects + go 0 _ _ = liftIO $ throwIO TooManyRedirects go count req'' cookie_jar'' = do - now <- liftIO $ getCurrentTime + now <- liftIO getCurrentTime let (req', cookie_jar') = insertCookiesIntoRequest req'' (evictExpiredCookies cookie_jar'' now) now - res' <- httpRaw req' manager - let (cookie_jar, res) = updateCookieJar res' req' now cookie_jar' - case getRedirectedRequest req' (responseHeaders res) (W.statusCode (statusCode res)) of + res <- httpRaw req' manager + let (cookie_jar, _) = updateCookieJar res req' now cookie_jar' + case getRedirectedRequest req' (responseHeaders res) (W.statusCode (responseStatus res)) of Just req -> go (count - 1) req cookie_jar Nothing -> return res -- | Get a 'Response' without any redirect following. httpRaw - :: ResourceIO m + :: (MonadBaseControl IO m, MonadResource m) => Request m -> Manager - -> ResourceT m (Response (C.Source m S.ByteString)) + -> m (Response (C.Source m S.ByteString)) httpRaw req m = do (connRelease, ci, isManaged) <- getConn req m bsrc <- C.bufferSource $ connSource ci @@ -201,7 +201,7 @@ connRelease DontReuse http req m -- Not reused, so this is a real exception - (Left e, Fresh) -> liftBase $ throwIO e + (Left e, Fresh) -> liftIO $ throwIO e -- Everything went ok, so the connection is good. If any exceptions get -- thrown in the rest of the code, just throw them as normal. (Right (), _) -> getResponse connRelease req bsrc @@ -223,7 +223,7 @@ -- -- Note: Unlike previous versions, this function will perform redirects, as -- specified by the 'redirectCount' setting. -httpLbs :: ResourceIO m => Request m -> Manager -> ResourceT m (Response L.ByteString) +httpLbs :: (MonadBaseControl IO m, MonadResource m) => Request m -> Manager -> m (Response L.ByteString) httpLbs r = lbsResponse . http r -- | Download the specified URL, following any redirects, and @@ -241,5 +241,5 @@ -- 'httpRedirect' directly. simpleHttp :: MonadIO m => String -> m L.ByteString simpleHttp url = liftIO $ withManager $ \man -> do - url' <- liftBase $ parseUrl url + url' <- liftIO $ parseUrl url fmap responseBody $ httpLbs url' man 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 @@ -30,7 +30,6 @@ import Control.Monad.State import Control.Exception import qualified Control.Exception.Lifted as LE -import Control.Monad.Trans.Resource import Data.Conduit import Prelude hiding (catch) import qualified Network.HTTP.Types as HT @@ -51,8 +50,8 @@ data BrowserState = BrowserState { maxRedirects :: Int , maxRetryCount :: Int - , authorities :: Request IO -> Maybe (BS.ByteString, BS.ByteString) - , cookieFilter :: Request IO -> Cookie -> IO Bool + , authorities :: Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString) + , cookieFilter :: Request (ResourceT IO) -> Cookie -> IO Bool , cookieJar :: CookieJar , currentProxy :: Maybe Proxy , userAgent :: BS.ByteString @@ -77,7 +76,7 @@ browse m act = evalStateT act (defaultState m) -- | Make a request, using all the state in the current BrowserState -makeRequest :: Request IO -> BrowserAction (Response (Source IO BS.ByteString)) +makeRequest :: Request (ResourceT IO) -> BrowserAction (Response (Source (ResourceT IO) BS.ByteString)) makeRequest request = do BrowserState { maxRetryCount = max_retry_count @@ -97,9 +96,9 @@ BrowserState {maxRedirects = max_redirects} <- get resp <- LE.catch (runRedirectionChain request' max_redirects) (\ e' -> retryHelper request' (retry_count - 1) (Just (e' :: HttpException))) - let code = HT.statusCode $ HC.statusCode resp + let code = HT.statusCode $ HC.responseStatus resp if code < 200 || code >= 300 - then retryHelper request' (retry_count - 1) (Just $ HC.StatusCodeException (HC.statusCode resp) (HC.responseHeaders resp)) + then retryHelper request' (retry_count - 1) (Just $ HC.StatusCodeException (HC.responseStatus resp) (HC.responseHeaders resp)) else return resp runRedirectionChain request' redirect_count | redirect_count == 0 = throw TooManyRedirects @@ -116,7 +115,7 @@ res <- lift $ HC.http request'' manager' (cookie_jar'', response) <- liftIO $ updateCookieJar res request'' now cookie_jar' cookie_filter put $ s {cookieJar = cookie_jar''} - let code = HT.statusCode (HC.statusCode response) + let code = HT.statusCode (HC.responseStatus response) if code >= 300 && code < 400 then runRedirectionChain (case HC.getRedirectedRequest request'' (responseHeaders response) code of Just a -> a @@ -129,7 +128,7 @@ where hs = filter ((/= k) . fst) $ requestHeaders request' k = mk $ fromString "User-Agent" -updateCookieJar :: Response a -> Request IO -> UTCTime -> CookieJar -> (Request IO -> Cookie -> IO Bool) -> IO (CookieJar, Response a) +updateCookieJar :: Response a -> Request (ResourceT IO) -> UTCTime -> CookieJar -> (Request (ResourceT IO) -> Cookie -> IO Bool) -> IO (CookieJar, Response a) updateCookieJar 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 {HC.responseHeaders = other_headers}) @@ -164,15 +163,15 @@ -- | A user-provided function that provides optional authorities. -- This function gets run on all requests before they get sent out. -- The output of this function is applied to the request. -getAuthorities :: BrowserAction (Request IO -> Maybe (BS.ByteString, BS.ByteString)) +getAuthorities :: BrowserAction (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)) getAuthorities = get >>= \ a -> return $ authorities a -setAuthorities :: (Request IO -> Maybe (BS.ByteString, BS.ByteString)) -> BrowserAction () +setAuthorities :: (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)) -> BrowserAction () setAuthorities b = get >>= \ a -> put a {authorities = b} -- | Each new Set-Cookie the browser encounters will pass through this filter. -- Only cookies that pass the filter (and are already valid) will be allowed into the cookie jar -getCookieFilter :: BrowserAction (Request IO -> Cookie -> IO Bool) +getCookieFilter :: BrowserAction (Request (ResourceT IO) -> Cookie -> IO Bool) getCookieFilter = get >>= \ a -> return $ cookieFilter a -setCookieFilter :: (Request IO -> Cookie -> IO Bool) -> BrowserAction () +setCookieFilter :: (Request (ResourceT IO) -> Cookie -> IO Bool) -> BrowserAction () setCookieFilter b = get >>= \ a -> put a {cookieFilter = b} -- | All the cookies! getCookieJar :: BrowserAction CookieJar diff --git a/Network/HTTP/Conduit/Chunk.hs b/Network/HTTP/Conduit/Chunk.hs --- a/Network/HTTP/Conduit/Chunk.hs +++ b/Network/HTTP/Conduit/Chunk.hs @@ -7,8 +7,6 @@ import Control.Exception (assert) import Numeric (showHex) -import Control.Monad.Trans.Class (lift) - import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -28,7 +26,7 @@ | NeedNewline (S.ByteString -> A.Result ()) | Complete -chunkedConduit :: C.ResourceThrow m +chunkedConduit :: C.MonadThrow m => Bool -- ^ send the headers as well, necessary for a proxy -> C.Conduit S.ByteString m S.ByteString chunkedConduit sendHeaders = C.conduitState @@ -45,7 +43,7 @@ let addHeader = if sendHeaders then (header:) else id push (front . addHeader) (Isolate i) x' A.Partial f' -> return $ C.StateProducing (NeedHeader f') $ front [] - A.Fail _ contexts msg -> lift $ C.resourceThrow $ ParseError contexts msg + A.Fail _ contexts msg -> C.monadThrow $ ParseError contexts msg push front (Isolate i) x = do let (a, b) = S.splitAt i x i' = i - S.length a @@ -67,17 +65,17 @@ (NeedHeader $ A.parse parseChunkHeader) x' A.Partial f' -> return $ C.StateProducing (NeedNewline f') $ front [] - A.Fail _ contexts msg -> lift $ C.resourceThrow $ ParseError contexts msg + A.Fail _ contexts msg -> C.monadThrow $ ParseError contexts msg push front Complete leftover = do let end = if sendHeaders then [S8.pack "0\r\n"] else [] lo = if S.null leftover then Nothing else Just leftover return $ C.StateFinished lo $ front end close _ = return [] -chunkIt :: C.Resource m => C.Conduit Blaze.Builder m Blaze.Builder +chunkIt :: Monad m => C.Conduit Blaze.Builder m Blaze.Builder chunkIt = conduit where - conduit = C.Conduit push close - push xs = return $ C.Producing conduit [chunkedTransferEncoding xs] - close = return [chunkedTransferTerminator] + conduit = C.NeedInput push close + push xs = C.HaveOutput conduit (return ()) (chunkedTransferEncoding xs) + close = C.Open C.Closed (return ()) chunkedTransferTerminator diff --git a/Network/HTTP/Conduit/ConnInfo.hs b/Network/HTTP/Conduit/ConnInfo.hs --- a/Network/HTTP/Conduit/ConnInfo.hs +++ b/Network/HTTP/Conduit/ConnInfo.hs @@ -22,7 +22,7 @@ import Control.Exception (SomeException, throwIO, try) import System.IO (Handle, hClose) -import Control.Monad.Base (MonadBase, liftBase) +import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString as S @@ -55,23 +55,23 @@ , connClose :: IO () } -connSink :: C.ResourceIO m => ConnInfo -> C.Sink ByteString m () +connSink :: C.MonadResource m => ConnInfo -> C.Sink ByteString m () connSink ConnInfo { connWrite = write } = - C.SinkData push close + C.Processing push close where - push bss = liftBase (write bss) >> return (C.Processing push close) + push bss = C.SinkM $ liftIO (write bss) >> return (C.Processing push close) close = return () -connSource :: C.ResourceIO m => ConnInfo -> C.Source m ByteString +connSource :: C.MonadResource m => ConnInfo -> C.Source m ByteString connSource ConnInfo { connRead = read' } = src where - src = C.Source pull close + src = C.SourceM pull close pull = do - bs <- liftBase read' + bs <- liftIO read' if S.null bs then return C.Closed - else return $ C.Open src bs + else return $ C.Open src close bs close = return () #if DEBUG diff --git a/Network/HTTP/Conduit/Cookies.hs b/Network/HTTP/Conduit/Cookies.hs --- a/Network/HTTP/Conduit/Cookies.hs +++ b/Network/HTTP/Conduit/Cookies.hs @@ -258,7 +258,7 @@ getExpiryTime :: Maybe UTCTime -> Maybe DiffTime -> UTCTime getExpiryTime _ (Just t) = (fromRational $ toRational t) `addUTCTime` now getExpiryTime (Just t) Nothing = t - getExpiryTime Nothing Nothing= UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) + getExpiryTime Nothing Nothing = UTCTime (365000 `addDays` utctDay now) (secondsToDiffTime 0) getPath (Just p) = p getPath Nothing = defaultPath request getPersistent = isJust (setCookieExpires set_cookie) || isJust (setCookieMaxAge set_cookie) diff --git a/Network/HTTP/Conduit/Internal.hs b/Network/HTTP/Conduit/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Conduit/Internal.hs @@ -0,0 +1,5 @@ +module Network.HTTP.Conduit.Internal + ( module Network.HTTP.Conduit.Parser + ) where + +import Network.HTTP.Conduit.Parser diff --git a/Network/HTTP/Conduit/Manager.hs b/Network/HTTP/Conduit/Manager.hs --- a/Network/HTTP/Conduit/Manager.hs +++ b/Network/HTTP/Conduit/Manager.hs @@ -30,14 +30,12 @@ import Data.Text (Text) import qualified Data.Text as T -import Control.Monad.Base (liftBase) -import Control.Exception.Lifted (mask) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Exception (mask_, SomeException, catch) import Control.Monad.Trans.Resource - ( ResourceT, runResourceT, ResourceIO, withIO - , register, release - , newRef, readRef', writeRef - , safeFromIOBase + ( ResourceT, runResourceT, MonadResource (..) + , MonadThrow, MonadUnsafeIO ) import Control.Concurrent (forkIO, threadDelay) import Data.Time (UTCTime, getCurrentTime, addUTCTime) @@ -217,9 +215,13 @@ -- -- This function uses the default manager settings. For more control, use -- 'newManager'. -withManager :: ResourceIO m => (Manager -> ResourceT m a) -> m a +withManager :: ( MonadIO m + , MonadBaseControl IO m + , MonadThrow m + , MonadUnsafeIO m + ) => (Manager -> ResourceT m a) -> m a withManager f = runResourceT $ do - (_, manager) <- withIO (newManager def) closeManager + (_, manager) <- allocate (newManager def) closeManager f manager -- | Close all connections in a 'Manager'. Afterwards, the @@ -237,12 +239,12 @@ nonEmptyMapM_ f (Cons x _ _ l) = f x >> nonEmptyMapM_ f l getSocketConn - :: ResourceIO m + :: MonadResource m => Manager -> String -> Int -> Maybe SocksConf -- ^ optional socks proxy - -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn) + -> m (ConnRelease m, ConnInfo, ManagedConn) getSocketConn man host' port' socksProxy' = getManagedConn man (ConnKey (T.pack host') port' False) $ getSocket host' port' socksProxy' >>= socketConn desc @@ -252,13 +254,13 @@ socketDesc :: String -> Int -> String -> String socketDesc h p t = unwords [h, show p, t] -getSslConn :: ResourceIO m +getSslConn :: MonadResource m => ([X509] -> IO TLSCertificateUsage) -> Manager -> String -- ^ host -> Int -- ^ port -> Maybe SocksConf -- ^ optional socks proxy - -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn) + -> m (ConnRelease m, ConnInfo, ManagedConn) getSslConn checkCert man host' port' socksProxy' = getManagedConn man (ConnKey (T.pack host') port' True) $ (connectionTo host' (PortNumber $ fromIntegral port') socksProxy' >>= sslClientConn desc checkCert) @@ -266,7 +268,7 @@ desc = socketDesc host' port' "secured" getSslProxyConn - :: ResourceIO m + :: MonadResource m => ([X509] -> IO TLSCertificateUsage) -> S8.ByteString -- ^ Target host -> Int -- ^ Target port @@ -274,7 +276,7 @@ -> String -- ^ Proxy host -> Int -- ^ Proxy port -> Maybe SocksConf -- ^ optional SOCKS proxy - -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn) + -> m (ConnRelease m, ConnInfo, ManagedConn) getSslProxyConn checkCert thost tport man phost pport socksProxy' = getManagedConn man (ConnKey (T.pack phost) pport True) $ doConnect >>= sslClientConn desc checkCert @@ -306,21 +308,21 @@ -- via I\/O, and register it with the @ResourceT@ so it is guaranteed to be -- either released or returned to the manager. getManagedConn - :: ResourceIO m + :: MonadResource m => Manager -> ConnKey -> IO ConnInfo - -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn) + -> m (ConnRelease m, ConnInfo, ManagedConn) -- We want to avoid any holes caused by async exceptions, so let's mask. -getManagedConn man key open = mask $ \restore -> do +getManagedConn man key open = resourceMask $ \restore -> do -- Try to take the socket out of the manager. - mci <- liftBase $ takeSocket man key + mci <- liftIO $ takeSocket man key (ci, isManaged) <- case mci of -- There wasn't a matching connection in the manager, so create a -- new one. Nothing -> do - ci <- restore $ liftBase open + ci <- restore $ liftIO open return (ci, Fresh) -- Return the existing one Just ci -> return (ci, Reused) @@ -329,32 +331,32 @@ -- the manager) or not reuse it (close the socket). We set up a mutable -- reference to track what we want to do. By default, we say not to reuse -- it, that way if an exception is thrown, the connection won't be reused. - toReuseRef <- newRef DontReuse + toReuseRef <- liftIO $ I.newIORef DontReuse -- Now register our release action. releaseKey <- register $ do - toReuse <- readRef' toReuseRef + toReuse <- I.readIORef toReuseRef -- Determine what action to take based on the value stored in the -- toReuseRef variable. case toReuse of - Reuse -> safeFromIOBase $ putSocket man key ci - DontReuse -> safeFromIOBase $ connClose ci + Reuse -> putSocket man key ci + DontReuse -> connClose ci -- When the connection is explicitly released, we update our toReuseRef to -- indicate what action should be taken, and then call release. let connRelease x = do - writeRef toReuseRef x + liftIO $ I.writeIORef toReuseRef x release releaseKey return (connRelease, ci, isManaged) data ConnReuse = Reuse | DontReuse -type ConnRelease m = ConnReuse -> ResourceT m () +type ConnRelease m = ConnReuse -> m () -getConn :: ResourceIO m +getConn :: MonadResource m => Request m -> Manager - -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn) + -> m (ConnRelease m, ConnInfo, ManagedConn) getConn req m = go m connhost connport (socksProxy req) where diff --git a/Network/HTTP/Conduit/Parser.hs b/Network/HTTP/Conduit/Parser.hs --- a/Network/HTTP/Conduit/Parser.hs +++ b/Network/HTTP/Conduit/Parser.hs @@ -17,7 +17,7 @@ import Data.Attoparsec import Data.Conduit.Attoparsec (sinkParser) -import Data.Conduit (Sink, ResourceIO) +import Data.Conduit (Sink, MonadResource, MonadThrow) import Control.Monad (when) @@ -60,7 +60,7 @@ h <- manyTill parseHeader newline "Response headers" return (s, h) -sinkHeaders :: ResourceIO m => Sink S.ByteString m (Status, [Header]) +sinkHeaders :: (MonadThrow m, MonadResource m) => Sink S.ByteString m (Status, [Header]) sinkHeaders = sinkParser parseHeaders diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs --- a/Network/HTTP/Conduit/Request.hs +++ b/Network/HTTP/Conduit/Request.hs @@ -276,7 +276,7 @@ && decompress req (fromMaybe "" $ lookup "content-type" hs') requestBuilder - :: C.Resource m + :: Monad m => Request m -> C.Source m Builder requestBuilder req = diff --git a/Network/HTTP/Conduit/Response.hs b/Network/HTTP/Conduit/Response.hs --- a/Network/HTTP/Conduit/Response.hs +++ b/Network/HTTP/Conduit/Response.hs @@ -12,6 +12,7 @@ import Control.Arrow (first) import Data.Typeable (Typeable) import Data.Monoid (mempty) +import Control.Monad (liftM) import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO) @@ -21,7 +22,7 @@ import qualified Data.CaseInsensitive as CI -import Control.Monad.Trans.Resource (ResourceT, ResourceIO) +import Control.Monad.Trans.Resource (MonadResource) import qualified Data.Conduit as C import qualified Data.Conduit.Zlib as CZ import qualified Data.Conduit.Binary as CB @@ -37,7 +38,8 @@ -- | A simple representation of the HTTP response created by 'lbsConsumer'. data Response body = Response - { statusCode :: W.Status + { responseStatus :: W.Status + , responseVersion :: W.HttpVersion , responseHeaders :: W.ResponseHeaders , responseBody :: body } @@ -45,7 +47,7 @@ -- | Since 1.1.2. instance Functor Response where - fmap f (Response status headers body) = Response status headers (f body) + fmap f (Response status v headers body) = Response status v headers (f body) -- | If a request is a redirection (status code 3xx) this function will create -- a new request from the old request, the server headers returned with the @@ -97,9 +99,9 @@ -- | Convert a 'Response' that has a 'C.Source' body to one with a lazy -- 'L.ByteString' body. -lbsResponse :: C.Resource m - => ResourceT m (Response (C.Source m S8.ByteString)) - -> ResourceT m (Response L.ByteString) +lbsResponse :: Monad m + => m (Response (C.Source m S8.ByteString)) + -> m (Response L.ByteString) lbsResponse mres = do res <- mres bss <- responseBody res C.$$ CL.consume @@ -107,29 +109,27 @@ { responseBody = L.fromChunks bss } -checkHeaderLength :: ResourceIO m => Int -> C.Sink S8.ByteString m a -> C.Sink S8.ByteString m a -checkHeaderLength len0 (C.SinkData pushI0 closeI0) = - C.SinkData (push len0 pushI0) closeI0 - where - push len pushI bs = do - res <- pushI bs - case res of - C.Processing pushI' close - | len' <= 0 -> liftIO $ throwIO OverlongHeaders - | otherwise -> return $ C.Processing - (push len' pushI') close - C.Done a b -> return $ C.Done a b - where - len' = len - S8.length bs -checkHeaderLength _ _ = error "checkHeaderLength" +checkHeaderLength :: MonadResource m + => Int + -> C.Sink S8.ByteString m a + -> C.Sink S8.ByteString m a +checkHeaderLength len _ + | len <= 0 = C.SinkM $ liftIO $ throwIO OverlongHeaders +checkHeaderLength len (C.Processing pushI closeI) = C.Processing + (\bs -> checkHeaderLength + (len - S8.length bs) + (pushI bs)) closeI +checkHeaderLength len (C.SinkM msink) = C.SinkM $ liftM (checkHeaderLength len) msink +checkHeaderLength _ s@C.Done{} = s -getResponse :: ResourceIO m +getResponse :: MonadResource m => ConnRelease m -> Request m -> C.BufferedSource m S8.ByteString - -> ResourceT m (Response (C.Source m S8.ByteString)) + -> m (Response (C.Source m S8.ByteString)) getResponse connRelease req@(Request {..}) bsrc = do - ((_, sc, sm), hs) <- bsrc C.$$ checkHeaderLength 4096 sinkHeaders + ((vbs, sc, sm), hs) <- bsrc C.$$ checkHeaderLength 4096 sinkHeaders + let version = if vbs == "1.1" then W.http11 else W.http10 let s = W.Status sc sm let hs' = map (first CI.mk) hs let mcl = lookup "content-length" hs' >>= readDec . S8.unpack @@ -158,23 +158,21 @@ else bsrc' return $ addCleanup cleanup bsrc'' - return $ Response s hs' body + return $ Response s version hs' body -- | Add some cleanup code to the given 'C.Source'. General purpose -- function, could be included in conduit itself. -addCleanup :: C.ResourceIO m - => (Bool -> ResourceT m ()) +addCleanup :: Monad m + => (Bool -> m ()) -> C.Source m a -> C.Source m a -addCleanup cleanup src = src - { C.sourcePull = do - res <- C.sourcePull src - case res of - C.Closed -> cleanup True >> return C.Closed - C.Open src' val -> return $ C.Open - (addCleanup cleanup src') - val - , C.sourceClose = do - C.sourceClose src - cleanup False - } +addCleanup cleanup C.Closed = C.SourceM + (cleanup True >> return C.Closed) + (cleanup True) +addCleanup cleanup (C.Open src close x) = C.Open + (addCleanup cleanup src) + (cleanup False >> close) + x +addCleanup cleanup (C.SourceM msrc close) = C.SourceM + (liftM (addCleanup cleanup) msrc) + (cleanup False >> close) diff --git a/http-conduit.cabal b/http-conduit.cabal --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,5 +1,5 @@ name: http-conduit -version: 1.2.6 +version: 1.3.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -22,10 +22,11 @@ , bytestring >= 0.9.1.4 && < 0.10 , transformers >= 0.2 && < 0.3 , failure >= 0.1 - , conduit >= 0.2 - , zlib-conduit >= 0.2 && < 0.3 - , blaze-builder-conduit >= 0.2 && < 0.3 - , attoparsec-conduit >= 0.2 && < 0.3 + , resourcet >= 0.3 && < 0.4 + , conduit >= 0.3 && < 0.4 + , zlib-conduit >= 0.3 && < 0.4 + , blaze-builder-conduit >= 0.3 && < 0.4 + , attoparsec-conduit >= 0.3 && < 0.4 , attoparsec >= 0.8.0.2 && < 0.11 , utf8-string >= 0.3.4 && < 0.4 , blaze-builder >= 0.2.1 && < 0.4 @@ -55,6 +56,7 @@ build-depends: network >= 2.3 && < 2.4 exposed-modules: Network.HTTP.Conduit Network.HTTP.Conduit.Browser + Network.HTTP.Conduit.Internal other-modules: Network.HTTP.Conduit.Parser Network.HTTP.Conduit.ConnInfo Network.HTTP.Conduit.Request @@ -108,6 +110,7 @@ , cookie , regex-compat , network-conduit + , resourcet source-repository head type: git diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -11,18 +11,24 @@ import Control.Exception.Lifted (try, SomeException) import Network.HTTP.Conduit.ConnInfo import CookieTest (cookieTest) -import Data.Conduit.Network (runTCPServer, ServerSettings (..)) +import Data.Conduit.Network (runTCPServer, ServerSettings (..), HostPreference (HostAny)) import Data.Conduit (($$)) import Control.Monad.Trans.Resource (register) import Control.Monad.IO.Class (liftIO) +import Data.ByteString.UTF8 (fromString) import Data.Conduit.List (sourceList) +import Data.CaseInsensitive (mk) +import Data.List (partition) app :: Application app req = case pathInfo req of [] -> return $ responseLBS status200 [] "homepage" + ["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies" _ -> return $ responseLBS status404 [] "not found" + where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;") + main :: IO () main = hspecX $ do cookieTest @@ -39,6 +45,16 @@ case elbs of Left (_ :: SomeException) -> return () Right _ -> error "Expected an exception" + describe "httpLbs" $ do + it "preserves 'set-cookie' headers" $ do + tid <- forkIO $ run 3010 app + request <- parseUrl "http://localhost:3010/cookies" + withManager $ \manager -> do + Response _ _ headers _ <- httpLbs request manager + let setCookie = mk (fromString "Set-Cookie") + (setCookieHeaders, _) = partition ((== setCookie) . fst) headers + liftIO $ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 + killThread tid describe "manager" $ do it "closes all connections" $ do clearSocketsList @@ -66,7 +82,7 @@ _ -> error "Shouldn't have worked" overLongHeaders :: IO () -overLongHeaders = runTCPServer (ServerSettings 3004 Nothing) $ \_ sink -> +overLongHeaders = runTCPServer (ServerSettings 3004 HostAny) $ \_ sink -> src $$ sink where src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar"