http-conduit 1.2.6 → 1.3.0

raw patch · 12 files changed

+143/−122 lines, 12 filesdep +resourcetdep ~attoparsec-conduitdep ~blaze-builder-conduitdep ~conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: resourcet

Dependency ranges changed: attoparsec-conduit, blaze-builder-conduit, conduit, zlib-conduit

API changes (from Hackage documentation)

Files

• Network/HTTP/Conduit.hs +16/−16
• Network/HTTP/Conduit/Browser.hs +11/−12
• Network/HTTP/Conduit/Chunk.hs +7/−9
• Network/HTTP/Conduit/ConnInfo.hs +8/−8
• Network/HTTP/Conduit/Cookies.hs +1/−1
• Network/HTTP/Conduit/Internal.hs +5/−0
• Network/HTTP/Conduit/Manager.hs +29/−27
• Network/HTTP/Conduit/Parser.hs +2/−2
• Network/HTTP/Conduit/Request.hs +1/−1
• Network/HTTP/Conduit/Response.hs +37/−39
• http-conduit.cabal +8/−5
• test/main.hs +18/−2

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

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

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

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

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

@@ -0,0 +1,5 @@+module Network.HTTP.Conduit.Internal+    ( module Network.HTTP.Conduit.Parser+    ) where++import Network.HTTP.Conduit.Parser

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

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

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

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

@@ -1,5 +1,5 @@ name:            http-conduit-version:         1.2.6+version:         1.3.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -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

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