summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichaelSnoyman <>2012-03-21 15:40:28 (GMT)
committerhdiff <hdiff@luite.com>2012-03-21 15:40:28 (GMT)
commit33552224f652fc800af34a49726710db4f36ba7f (patch)
tree2bca758484e075524c62e95a9d45b9e5a34d2bda
parent24db393c99f4f23303a33fdac8aff92e737f827e (diff)
version 1.3.01.3.0
-rw-r--r--Network/HTTP/Conduit.hs32
-rw-r--r--Network/HTTP/Conduit/Browser.hs23
-rw-r--r--Network/HTTP/Conduit/Chunk.hs16
-rw-r--r--Network/HTTP/Conduit/ConnInfo.hs16
-rw-r--r--Network/HTTP/Conduit/Cookies.hs2
-rw-r--r--Network/HTTP/Conduit/Internal.hs5
-rw-r--r--Network/HTTP/Conduit/Manager.hs56
-rw-r--r--Network/HTTP/Conduit/Parser.hs4
-rw-r--r--Network/HTTP/Conduit/Request.hs2
-rw-r--r--Network/HTTP/Conduit/Response.hs78
-rw-r--r--http-conduit.cabal13
-rw-r--r--test/main.hs20
12 files changed, 144 insertions, 123 deletions
diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs
index 3545b09..f837ab5 100644
--- a/Network/HTTP/Conduit.hs
+++ b/Network/HTTP/Conduit.hs
@@ -124,12 +124,12 @@ import qualified Network.HTTP.Types as W
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 @@ import Network.HTTP.Conduit.Cookies
-- 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 @@ http req0 manager = do
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 @@ httpRaw req m = do
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 @@ httpRaw req m = do
--
-- 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 @@ httpLbs r = lbsResponse . http r
-- '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
index f46862e..21b97c9 100644
--- a/Network/HTTP/Conduit/Browser.hs
+++ b/Network/HTTP/Conduit/Browser.hs
@@ -30,7 +30,6 @@ import qualified Data.ByteString as BS
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 @@ import qualified Network.HTTP.Conduit as HC
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 :: Manager -> BrowserAction a -> ResourceT IO a
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 @@ makeRequest request = do
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 @@ makeRequest request = do
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 @@ makeRequest request = do
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 @@ setMaxRetryCount b = get >>= \ a -> put a {maxRetryCount = b}
-- | 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
index 1e5b03c..403753f 100644
--- a/Network/HTTP/Conduit/Chunk.hs
+++ b/Network/HTTP/Conduit/Chunk.hs
@@ -7,8 +7,6 @@ module Network.HTTP.Conduit.Chunk
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 @@ data CState = NeedHeader (S.ByteString -> A.Result Int)
| 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 @@ chunkedConduit sendHeaders = C.conduitState
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 @@ chunkedConduit sendHeaders = C.conduitState
(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
index 91dff59..d57be84 100644
--- a/Network/HTTP/Conduit/ConnInfo.hs
+++ b/Network/HTTP/Conduit/ConnInfo.hs
@@ -22,7 +22,7 @@ module Network.HTTP.Conduit.ConnInfo
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 @@ data ConnInfo = ConnInfo
, 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
index 8780b4a..2a67b9e 100644
--- a/Network/HTTP/Conduit/Cookies.hs
+++ b/Network/HTTP/Conduit/Cookies.hs
@@ -258,7 +258,7 @@ generateCookie set_cookie request now is_http_api = do
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
index 0000000..e17fea2
--- /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
index 67c704d..ae59e8b 100644
--- a/Network/HTTP/Conduit/Manager.hs
+++ b/Network/HTTP/Conduit/Manager.hs
@@ -30,14 +30,12 @@ import qualified Blaze.ByteString.Builder as Blaze
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 @@ neFromList xs =
--
-- 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 (One x _) = f x
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 @@ getSocketConn man host' port' socksProxy' =
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 @@ getSslConn checkCert man host' port' socksProxy' =
desc = socketDesc host' port' "secured"
getSslProxyConn
- :: ResourceIO m
+ :: MonadResource m
=> ([X509] -> IO TLSCertificateUsage)
-> S8.ByteString -- ^ Target host
-> Int -- ^ Target port
@@ -274,7 +276,7 @@ getSslProxyConn
-> 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 @@ data ManagedConn = Fresh | Reused
-- 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 @@ getManagedConn man key open = mask $ \restore -> do
-- 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
index 4c37f71..ef875fc 100644
--- a/Network/HTTP/Conduit/Parser.hs
+++ b/Network/HTTP/Conduit/Parser.hs
@@ -17,7 +17,7 @@ import qualified Data.ByteString.Char8 as S8
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 @@ parseHeaders = do
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
index 21679e0..da51cf0 100644
--- a/Network/HTTP/Conduit/Request.hs
+++ b/Network/HTTP/Conduit/Request.hs
@@ -276,7 +276,7 @@ needsGunzip req hs' =
&& 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
index c92bfd2..d7e2340 100644
--- a/Network/HTTP/Conduit/Response.hs
+++ b/Network/HTTP/Conduit/Response.hs
@@ -12,6 +12,7 @@ module Network.HTTP.Conduit.Response
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.ByteString.Lazy as L
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 @@ import Network.HTTP.Conduit.Chunk
-- | 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 @@ data Response body = Response
-- | 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 @@ getRedirectedRequest req hs code
-- | 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 @@ lbsResponse mres = do
{ 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"
-
-getResponse :: ResourceIO m
+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 :: 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 @@ getResponse connRelease req@(Request {..}) bsrc = do
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
index bd29471..f46fe7f 100644
--- 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 <michael@snoyman.com>
@@ -22,10 +22,11 @@ library
, 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 @@ library
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 @@ test-suite test
, cookie
, regex-compat
, network-conduit
+ , resourcet
source-repository head
type: git
diff --git a/test/main.hs b/test/main.hs
index a7d5c58..a544d6b 100644
--- a/test/main.hs
+++ b/test/main.hs
@@ -11,18 +11,24 @@ import Network.HTTP.Types
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 @@ main = hspecX $ do
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 @@ main = hspecX $ do
_ -> 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"