summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichaelSnoyman <>2012-01-15 10:05:28 (GMT)
committerhdiff <hdiff@luite.com>2012-01-15 10:05:28 (GMT)
commit5ce40cb90c6a74089b7dd8eeed3e53ba75df076f (patch)
tree47c21c61d1a26eb9249a0687cdb080d06a218ac6
parent55c3761f850099b9345c3eb068649c9c59f7efe7 (diff)
version 1.1.11.1.1
-rw-r--r--LICENSE50
-rw-r--r--Network/HTTP/Conduit.hs505
-rw-r--r--Network/HTTP/Conduit/Chunk.hs164
-rw-r--r--Network/HTTP/Conduit/ConnInfo.hs324
-rw-r--r--Network/HTTP/Conduit/Manager.hs530
-rw-r--r--Network/HTTP/Conduit/Parser.hs244
-rw-r--r--Network/HTTP/Conduit/Request.hs688
-rw-r--r--Network/HTTP/Conduit/Response.hs208
-rw-r--r--Network/HTTP/Conduit/Util.hs142
-rw-r--r--Setup.lhs16
-rw-r--r--http-conduit.cabal165
-rw-r--r--test/main.hs49
12 files changed, 1647 insertions, 1438 deletions
diff --git a/LICENSE b/LICENSE
index 8643e5d..27d2fd3 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,25 +1,25 @@
-The following license covers this documentation, and the source code, except
-where otherwise indicated.
-
-Copyright 2010, Michael Snoyman. All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
-* Redistributions of source code must retain the above copyright notice, this
- list of conditions and the following disclaimer.
-
-* Redistributions in binary form must reproduce the above copyright notice,
- this list of conditions and the following disclaimer in the documentation
- and/or other materials provided with the distribution.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2010, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs
index 995a904..9ddbbdf 100644
--- a/Network/HTTP/Conduit.hs
+++ b/Network/HTTP/Conduit.hs
@@ -1,251 +1,254 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE CPP #-}
--- | This module contains everything you need to initiate HTTP connections. If
--- you want a simple interface based on URLs, you can use 'simpleHttp'. If you
--- want raw power, 'http' is the underlying workhorse of this package. Some
--- examples:
---
--- > -- Just download an HTML document and print it.
--- > import Network.HTTP.Conduit
--- > import qualified Data.ByteString.Lazy as L
--- >
--- > main = simpleHttp "http://www.haskell.org/" >>= L.putStr
---
--- This example uses interleaved IO to write the response body to a file in
--- constant memory space.
---
--- > import Data.Conduit.Binary (sinkFile)
--- > import Network.HTTP.Conduit
--- > import System.IO
--- > import qualified Data.Conduit as C
--- >
--- > main :: IO ()
--- > main = do
--- > request <- parseUrl "http://google.com/"
--- > withManager $ \manager -> do
--- > Response _ _ bsrc <- http request handler manager
--- > bsrc C.$$ sinkFile "google.html"
---
--- The following headers are automatically set by this module, and should not
--- be added to 'requestHeaders':
---
--- * Content-Length
---
--- * Host
---
--- * Accept-Encoding (not currently set, but client usage of this variable /will/ cause breakage).
---
--- Any network code on Windows requires some initialization, and the network
--- library provides withSocketsDo to perform it. Therefore, proper usage of
--- this library will always involve calling that function at some point. The
--- best approach is to simply call them at the beginning of your main function,
--- such as:
---
--- > import Network.HTTP.Conduit
--- > import qualified Data.ByteString.Lazy as L
--- > import Network (withSocketsDo)
--- >
--- > main = withSocketsDo
--- > $ simpleHttp "http://www.haskell.org/" >>= L.putStr
-module Network.HTTP.Conduit
- ( -- * Perform a request
- simpleHttp
- , httpLbs
- , http
- -- * Datatypes
- , Proxy (..)
- , RequestBody (..)
- , Response (..)
- -- ** Request
- , Request
- , def
- , method
- , secure
- , checkCerts
- , host
- , port
- , path
- , queryString
- , requestHeaders
- , requestBody
- , proxy
- , rawBody
- , decompress
- , redirectCount
- , checkStatus
- -- *** Defaults
- , defaultCheckCerts
- -- * Manager
- , Manager
- , newManager
- , withManager
- -- * Utility functions
- , parseUrl
- , applyBasicAuth
- , addProxy
- -- * Decompression predicates
- , alwaysDecompress
- , browserDecompress
- -- * Request bodies
- , urlEncodedBody
- -- * Exceptions
- , HttpException (..)
-#if DEBUG
- -- * Debug
- , printOpenSockets
-#endif
- ) where
-
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.Char8 as S8
-
-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 qualified Data.Conduit as C
-import Data.Conduit.Blaze (builderToByteString)
-import Control.Monad.Trans.Resource (ResourceT, runResourceT, ResourceIO)
-import Control.Exception.Lifted (try, SomeException)
-
-import Network.HTTP.Conduit.Request
-import Network.HTTP.Conduit.Response
-import Network.HTTP.Conduit.Manager
-import Network.HTTP.Conduit.ConnInfo
-
--- | The most low-level function for initiating an HTTP request.
---
--- The first argument to this function gives a full specification
--- on the request: the host to connect to, whether to use SSL,
--- headers, etc. Please see 'Request' for full details. The
--- second argument specifies which 'Manager' should be used.
---
--- This function then returns a 'Response' with a
--- 'C.BufferedSource'. The 'Response' contains the status code
--- and headers that were sent back to us, and the
--- 'C.BufferedSource' contains the body of the request. Note
--- that this 'C.BufferedSource' allows you to have fully
--- interleaved IO actions during your HTTP download, making it
--- possible to download very large responses in constant memory.
--- You may also directly connect the returned 'C.BufferedSource'
--- into a 'C.Sink', perhaps a file or another socket.
---
--- Note: Unlike previous versions, this function will perform redirects, as
--- specified by the 'redirectCount' setting.
-http
- :: ResourceIO m
- => Request m
- -> Manager
- -> ResourceT m (Response (C.BufferedSource m S.ByteString))
-http req0 manager = do
- res@(Response status hs body) <-
- if redirectCount req0 == 0
- then httpRaw req0 manager
- else go (redirectCount req0) req0
- case checkStatus req0 status hs of
- Nothing -> return res
- Just exc -> do
- C.bsourceClose body
- liftBase $ throwIO exc
- where
- go 0 _ = liftBase $ throwIO TooManyRedirects
- go count req = do
- res@(Response (W.Status code _) hs _) <- httpRaw req manager
- case (300 <= code && code < 400, lookup "location" hs) of
- (True, Just l'') -> do
- -- Prepend scheme, host and port if missing
- let l' =
- case S8.uncons l'' of
- Just ('/', _) -> concat
- [ "http"
- , if secure req then "s" else ""
- , "://"
- , S8.unpack $ host req
- , ":"
- , show $ port req
- , S8.unpack l''
- ]
- _ -> S8.unpack l''
- l <- liftBase $ parseUrl l'
- let req' = req
- { host = host l
- , port = port l
- , secure = secure l
- , path = path l
- , queryString = queryString l
- , method =
- -- According to the spec, this should *only* be for
- -- status code 303. However, almost all clients
- -- mistakenly implement it for 302 as well. So we
- -- have to be wrong like everyone else...
- if code == 302 || code == 303
- then "GET"
- else method l
- }
- go (count - 1) req'
- _ -> return res
-
--- | Get a 'Response' without any redirect following.
-httpRaw
- :: ResourceIO m
- => Request m
- -> Manager
- -> ResourceT m (Response (C.BufferedSource m S.ByteString))
-httpRaw req m = do
- (connRelease, ci, isManaged) <- getConn req m
- bsrc <- C.bufferSource $ connSource ci
- ex <- try $ requestBuilder req C.$$ builderToByteString C.=$ connSink ci
- case (ex :: Either SomeException (), isManaged) of
- -- Connection was reused, and might be been closed. Try again
- (Left _, Reused) -> do
- connRelease DontReuse
- http req m
- -- Not reused, so this is a real exception
- (Left e, Fresh) -> liftBase $ 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
-
--- | Download the specified 'Request', returning the results as a 'Response'.
---
--- This is a simplified version of 'http' for the common case where you simply
--- want the response data as a simple datatype. If you want more power, such as
--- interleaved actions on the response body during download, you'll need to use
--- 'http' directly. This function is defined as:
---
--- @httpLbs = 'lbsResponse' . 'http'@
---
--- Even though the 'Response' contains a lazy bytestring, this
--- function does /not/ 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 @conduit@ packages's
--- 'C.BufferedSource' returned by 'http'.
---
--- 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 r = lbsResponse . http r
-
--- | Download the specified URL, following any redirects, and
--- return the response body.
---
--- This function will 'throwIO' an 'HttpException' for any
--- response with a non-2xx status code (besides 3xx redirects up
--- to a limit of 10 redirects). It uses 'parseUrl' to parse the
--- input. This function essentially wraps 'httpLbsRedirect'.
---
--- Note: Even though this function returns a lazy bytestring, it
--- does /not/ 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 'http' or
--- 'httpRedirect' directly.
-simpleHttp :: MonadIO m => String -> m L.ByteString
-simpleHttp url = liftIO $ runResourceT $ do
- url' <- liftBase $ parseUrl url
- man <- newManager
- fmap responseBody $ httpLbs url' man
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+-- | This module contains everything you need to initiate HTTP connections. If
+-- you want a simple interface based on URLs, you can use 'simpleHttp'. If you
+-- want raw power, 'http' is the underlying workhorse of this package. Some
+-- examples:
+--
+-- > -- Just download an HTML document and print it.
+-- > import Network.HTTP.Conduit
+-- > import qualified Data.ByteString.Lazy as L
+-- >
+-- > main = simpleHttp "http://www.haskell.org/" >>= L.putStr
+--
+-- This example uses interleaved IO to write the response body to a file in
+-- constant memory space.
+--
+-- > import Data.Conduit.Binary (sinkFile)
+-- > import Network.HTTP.Conduit
+-- > import System.IO
+-- > import qualified Data.Conduit as C
+-- >
+-- > main :: IO ()
+-- > main = do
+-- > request <- parseUrl "http://google.com/"
+-- > withManager $ \manager -> do
+-- > Response _ _ bsrc <- http request handler manager
+-- > bsrc C.$$ sinkFile "google.html"
+--
+-- The following headers are automatically set by this module, and should not
+-- be added to 'requestHeaders':
+--
+-- * Content-Length
+--
+-- * Host
+--
+-- * Accept-Encoding (not currently set, but client usage of this variable /will/ cause breakage).
+--
+-- Any network code on Windows requires some initialization, and the network
+-- library provides withSocketsDo to perform it. Therefore, proper usage of
+-- this library will always involve calling that function at some point. The
+-- best approach is to simply call them at the beginning of your main function,
+-- such as:
+--
+-- > import Network.HTTP.Conduit
+-- > import qualified Data.ByteString.Lazy as L
+-- > import Network (withSocketsDo)
+-- >
+-- > main = withSocketsDo
+-- > $ simpleHttp "http://www.haskell.org/" >>= L.putStr
+module Network.HTTP.Conduit
+ ( -- * Perform a request
+ simpleHttp
+ , httpLbs
+ , http
+ -- * Datatypes
+ , Proxy (..)
+ , RequestBody (..)
+ , Response (..)
+ -- ** Request
+ , Request
+ , def
+ , method
+ , secure
+ , checkCerts
+ , host
+ , port
+ , path
+ , queryString
+ , requestHeaders
+ , requestBody
+ , proxy
+ , rawBody
+ , decompress
+ , redirectCount
+ , checkStatus
+ -- *** Defaults
+ , defaultCheckCerts
+ -- * Manager
+ , Manager
+ , newManager
+ , newManagerCount
+ , newManagerIO
+ , withManager
+ -- * Utility functions
+ , parseUrl
+ , applyBasicAuth
+ , addProxy
+ , lbsResponse
+ -- * Decompression predicates
+ , alwaysDecompress
+ , browserDecompress
+ -- * Request bodies
+ , urlEncodedBody
+ -- * Exceptions
+ , HttpException (..)
+#if DEBUG
+ -- * Debug
+ , printOpenSockets
+#endif
+ ) where
+
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Char8 as S8
+
+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 qualified Data.Conduit as C
+import Data.Conduit.Blaze (builderToByteString)
+import Control.Monad.Trans.Resource (ResourceT, runResourceT, ResourceIO)
+import Control.Exception.Lifted (try, SomeException)
+
+import Network.HTTP.Conduit.Request
+import Network.HTTP.Conduit.Response
+import Network.HTTP.Conduit.Manager
+import Network.HTTP.Conduit.ConnInfo
+
+-- | The most low-level function for initiating an HTTP request.
+--
+-- The first argument to this function gives a full specification
+-- on the request: the host to connect to, whether to use SSL,
+-- headers, etc. Please see 'Request' for full details. The
+-- second argument specifies which 'Manager' should be used.
+--
+-- This function then returns a 'Response' with a
+-- 'C.BufferedSource'. The 'Response' contains the status code
+-- and headers that were sent back to us, and the
+-- 'C.BufferedSource' contains the body of the request. Note
+-- that this 'C.BufferedSource' allows you to have fully
+-- interleaved IO actions during your HTTP download, making it
+-- possible to download very large responses in constant memory.
+-- You may also directly connect the returned 'C.BufferedSource'
+-- into a 'C.Sink', perhaps a file or another socket.
+--
+-- Note: Unlike previous versions, this function will perform redirects, as
+-- specified by the 'redirectCount' setting.
+http
+ :: ResourceIO m
+ => Request m
+ -> Manager
+ -> ResourceT m (Response (C.BufferedSource m S.ByteString))
+http req0 manager = do
+ res@(Response status hs body) <-
+ if redirectCount req0 == 0
+ then httpRaw req0 manager
+ else go (redirectCount req0) req0
+ case checkStatus req0 status hs of
+ Nothing -> return res
+ Just exc -> do
+ C.bsourceClose body
+ liftBase $ throwIO exc
+ where
+ go 0 _ = liftBase $ throwIO TooManyRedirects
+ go count req = do
+ res@(Response (W.Status code _) hs _) <- httpRaw req manager
+ case (300 <= code && code < 400, lookup "location" hs) of
+ (True, Just l'') -> do
+ -- Prepend scheme, host and port if missing
+ let l' =
+ case S8.uncons l'' of
+ Just ('/', _) -> concat
+ [ "http"
+ , if secure req then "s" else ""
+ , "://"
+ , S8.unpack $ host req
+ , ":"
+ , show $ port req
+ , S8.unpack l''
+ ]
+ _ -> S8.unpack l''
+ l <- liftBase $ parseUrl l'
+ let req' = req
+ { host = host l
+ , port = port l
+ , secure = secure l
+ , path = path l
+ , queryString = queryString l
+ , method =
+ -- According to the spec, this should *only* be for
+ -- status code 303. However, almost all clients
+ -- mistakenly implement it for 302 as well. So we
+ -- have to be wrong like everyone else...
+ if code == 302 || code == 303
+ then "GET"
+ else method l
+ }
+ go (count - 1) req'
+ _ -> return res
+
+-- | Get a 'Response' without any redirect following.
+httpRaw
+ :: ResourceIO m
+ => Request m
+ -> Manager
+ -> ResourceT m (Response (C.BufferedSource m S.ByteString))
+httpRaw req m = do
+ (connRelease, ci, isManaged) <- getConn req m
+ bsrc <- C.bufferSource $ connSource ci
+ ex <- try $ requestBuilder req C.$$ builderToByteString C.=$ connSink ci
+ case (ex :: Either SomeException (), isManaged) of
+ -- Connection was reused, and might be been closed. Try again
+ (Left _, Reused) -> do
+ connRelease DontReuse
+ http req m
+ -- Not reused, so this is a real exception
+ (Left e, Fresh) -> liftBase $ 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
+
+-- | Download the specified 'Request', returning the results as a 'Response'.
+--
+-- This is a simplified version of 'http' for the common case where you simply
+-- want the response data as a simple datatype. If you want more power, such as
+-- interleaved actions on the response body during download, you'll need to use
+-- 'http' directly. This function is defined as:
+--
+-- @httpLbs = 'lbsResponse' . 'http'@
+--
+-- Even though the 'Response' contains a lazy bytestring, this
+-- function does /not/ 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 @conduit@ packages's
+-- 'C.BufferedSource' returned by 'http'.
+--
+-- 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 r = lbsResponse . http r
+
+-- | Download the specified URL, following any redirects, and
+-- return the response body.
+--
+-- This function will 'throwIO' an 'HttpException' for any
+-- response with a non-2xx status code (besides 3xx redirects up
+-- to a limit of 10 redirects). It uses 'parseUrl' to parse the
+-- input. This function essentially wraps 'httpLbsRedirect'.
+--
+-- Note: Even though this function returns a lazy bytestring, it
+-- does /not/ 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 'http' or
+-- 'httpRedirect' directly.
+simpleHttp :: MonadIO m => String -> m L.ByteString
+simpleHttp url = liftIO $ runResourceT $ do
+ url' <- liftBase $ parseUrl url
+ man <- newManager
+ fmap responseBody $ httpLbs url' man
diff --git a/Network/HTTP/Conduit/Chunk.hs b/Network/HTTP/Conduit/Chunk.hs
index 0e0638c..c0d253b 100644
--- a/Network/HTTP/Conduit/Chunk.hs
+++ b/Network/HTTP/Conduit/Chunk.hs
@@ -1,82 +1,82 @@
-{-# LANGUAGE FlexibleContexts #-}
-module Network.HTTP.Conduit.Chunk
- ( chunkedConduit
- , chunkIt
- ) where
-
-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
-
-import Blaze.ByteString.Builder.HTTP
-import qualified Blaze.ByteString.Builder as Blaze
-
-import qualified Data.Attoparsec.ByteString as A
-
-import qualified Data.Conduit as C
-import Data.Conduit.Attoparsec (ParseError (ParseError))
-
-import Network.HTTP.Conduit.Parser
-
-
-data CState = NeedHeader (S.ByteString -> A.Result Int)
- | Isolate Int
- | NeedNewline (S.ByteString -> A.Result ())
- | Complete
-
-chunkedConduit :: C.ResourceThrow m
- => Bool -- ^ send the headers as well, necessary for a proxy
- -> C.Conduit S.ByteString m S.ByteString
-chunkedConduit sendHeaders = C.conduitState
- (NeedHeader $ A.parse parseChunkHeader)
- (push id)
- close
- where
- push front (NeedHeader f) x =
- case f x of
- A.Done x' i
- | i == 0 -> push front Complete x'
- | otherwise -> do
- let header = S8.pack $ showHex i "\r\n"
- let addHeader = if sendHeaders then (header:) else id
- push (front . addHeader) (Isolate i) x'
- A.Partial f' -> return (NeedHeader f', C.Producing $ front [])
- A.Fail _ contexts msg -> lift $ C.resourceThrow $ ParseError contexts msg
- push front (Isolate i) x = do
- let (a, b) = S.splitAt i x
- i' = i - S.length a
- if i' == 0
- then push
- (front . (a:))
- (NeedNewline $ A.parse newline)
- b
- else assert (S.null b) $ return
- ( Isolate i'
- , C.Producing (front [a])
- )
- push front (NeedNewline f) x =
- case f x of
- A.Done x' () -> do
- let header = S8.pack "\r\n"
- let addHeader = if sendHeaders then (header:) else id
- push
- (front . addHeader)
- (NeedHeader $ A.parse parseChunkHeader)
- x'
- A.Partial f' -> return (NeedNewline f', C.Producing $ front [])
- A.Fail _ contexts msg -> lift $ C.resourceThrow $ 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 (Complete, C.Finished lo $ front end)
- close _ = return []
-
-chunkIt :: C.Resource m => C.Conduit Blaze.Builder m Blaze.Builder
-chunkIt = C.Conduit $ return $ C.PreparedConduit
- { C.conduitPush = \xs -> return $ C.Producing [chunkedTransferEncoding xs]
- , C.conduitClose = return [chunkedTransferTerminator]
- }
+{-# LANGUAGE FlexibleContexts #-}
+module Network.HTTP.Conduit.Chunk
+ ( chunkedConduit
+ , chunkIt
+ ) where
+
+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
+
+import Blaze.ByteString.Builder.HTTP
+import qualified Blaze.ByteString.Builder as Blaze
+
+import qualified Data.Attoparsec.ByteString as A
+
+import qualified Data.Conduit as C
+import Data.Conduit.Attoparsec (ParseError (ParseError))
+
+import Network.HTTP.Conduit.Parser
+
+
+data CState = NeedHeader (S.ByteString -> A.Result Int)
+ | Isolate Int
+ | NeedNewline (S.ByteString -> A.Result ())
+ | Complete
+
+chunkedConduit :: C.ResourceThrow m
+ => Bool -- ^ send the headers as well, necessary for a proxy
+ -> C.Conduit S.ByteString m S.ByteString
+chunkedConduit sendHeaders = C.conduitState
+ (NeedHeader $ A.parse parseChunkHeader)
+ (push id)
+ close
+ where
+ push front (NeedHeader f) x =
+ case f x of
+ A.Done x' i
+ | i == 0 -> push front Complete x'
+ | otherwise -> do
+ let header = S8.pack $ showHex i "\r\n"
+ let addHeader = if sendHeaders then (header:) else id
+ push (front . addHeader) (Isolate i) x'
+ A.Partial f' -> return (NeedHeader f', C.Producing $ front [])
+ A.Fail _ contexts msg -> lift $ C.resourceThrow $ ParseError contexts msg
+ push front (Isolate i) x = do
+ let (a, b) = S.splitAt i x
+ i' = i - S.length a
+ if i' == 0
+ then push
+ (front . (a:))
+ (NeedNewline $ A.parse newline)
+ b
+ else assert (S.null b) $ return
+ ( Isolate i'
+ , C.Producing (front [a])
+ )
+ push front (NeedNewline f) x =
+ case f x of
+ A.Done x' () -> do
+ let header = S8.pack "\r\n"
+ let addHeader = if sendHeaders then (header:) else id
+ push
+ (front . addHeader)
+ (NeedHeader $ A.parse parseChunkHeader)
+ x'
+ A.Partial f' -> return (NeedNewline f', C.Producing $ front [])
+ A.Fail _ contexts msg -> lift $ C.resourceThrow $ 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 (Complete, C.Finished lo $ front end)
+ close _ = return []
+
+chunkIt :: C.Resource m => C.Conduit Blaze.Builder m Blaze.Builder
+chunkIt = C.Conduit $ return $ C.PreparedConduit
+ { C.conduitPush = \xs -> return $ C.Producing [chunkedTransferEncoding xs]
+ , C.conduitClose = return [chunkedTransferTerminator]
+ }
diff --git a/Network/HTTP/Conduit/ConnInfo.hs b/Network/HTTP/Conduit/ConnInfo.hs
index 0d1ed29..62b185e 100644
--- a/Network/HTTP/Conduit/ConnInfo.hs
+++ b/Network/HTTP/Conduit/ConnInfo.hs
@@ -1,155 +1,169 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE CPP #-}
-module Network.HTTP.Conduit.ConnInfo
- ( ConnInfo
- , connClose
- , connSink
- , connSource
- , sslClientConn
- , socketConn
- , TLSCertificateRejectReason(..)
- , TLSCertificateUsage(..)
- , getSocket
-#if DEBUG
- , printOpenSockets
-#endif
- ) where
-
-import Control.Exception (SomeException, throwIO, try)
-import System.IO (Handle, hClose)
-
-import Control.Monad.Base (MonadBase, liftBase)
-
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as L
-
-import Network.Socket (Socket, sClose)
-import Network.Socket.ByteString (recv, sendAll)
-import qualified Network.Socket as NS
-
-import Network.TLS
-import Network.TLS.Extra (ciphersuite_all)
-
-import Data.Certificate.X509 (X509)
-
-import Crypto.Random.AESCtr (makeSystem)
-
-import qualified Data.Conduit as C
-
-#if DEBUG
-import qualified Data.IntMap as IntMap
-import qualified Data.IORef as I
-import System.IO.Unsafe (unsafePerformIO)
-#endif
-
-data ConnInfo = ConnInfo
- { connRead :: IO ByteString
- , connWrite :: ByteString -> IO ()
- , connClose :: IO ()
- }
-
-connSink :: C.ResourceIO m => ConnInfo -> C.Sink ByteString m ()
-connSink ConnInfo { connWrite = write } = C.Sink $ return $ C.SinkData
- { C.sinkPush = \bss -> liftBase (write bss) >> return C.Processing
- , C.sinkClose = return ()
- }
-
-connSource :: C.ResourceIO m => ConnInfo -> C.Source m ByteString
-connSource ConnInfo { connRead = read' } = C.Source $ return $ C.PreparedSource
- { C.sourcePull = do
- bs <- liftBase read'
- if S.null bs
- then return C.Closed
- else return $ C.Open bs
- , C.sourceClose = return ()
- }
-
-#if DEBUG
-allOpenSockets :: I.IORef (Int, IntMap.IntMap String)
-allOpenSockets = unsafePerformIO $ I.newIORef (0, IntMap.empty)
-
-addSocket :: String -> IO Int
-addSocket desc = I.atomicModifyIORef allOpenSockets $ \(next, m) ->
- ((next + 1, IntMap.insert next desc m), next)
-
-removeSocket :: Int -> IO ()
-removeSocket i = I.atomicModifyIORef allOpenSockets $ \(next, m) ->
- ((next, IntMap.delete i m), ())
-
-printOpenSockets :: IO ()
-printOpenSockets = do
- (_, m) <- I.readIORef allOpenSockets
- putStrLn "\n\nOpen sockets:"
- if IntMap.null m
- then putStrLn "** No open sockets!"
- else mapM_ putStrLn $ IntMap.elems m
-#endif
-
-socketConn :: String -> Socket -> IO ConnInfo
-socketConn _desc sock = do
-#if DEBUG
- i <- addSocket _desc
-#endif
- return ConnInfo
- { connRead = recv sock 4096
- , connWrite = sendAll sock
- , connClose = do
-#if DEBUG
- removeSocket i
-#endif
- sClose sock
- }
-
-sslClientConn :: String -> ([X509] -> IO TLSCertificateUsage) -> Handle -> IO ConnInfo
-sslClientConn _desc onCerts h = do
-#if DEBUG
- i <- addSocket _desc
-#endif
- let tcp = defaultParams
- { pConnectVersion = TLS10
- , pAllowedVersions = [ TLS10, TLS11 ]
- , pCiphers = ciphersuite_all
- , onCertificatesRecv = onCerts
- }
- gen <- makeSystem
- istate <- client tcp gen h
- _ <- handshake istate
- return ConnInfo
- { connRead = recvD istate
- , connWrite = sendData istate . L.fromChunks . (:[])
- , connClose = do
-#if DEBUG
- removeSocket i
-#endif
- bye istate
- hClose h
- }
- where
- recvD istate = do
- x <- recvData istate
- if L.null x
- then recvD istate
- else return $ S.concat $ L.toChunks x
- -- Although a 'concat' seems like a bad idea, at
- -- least on tls-0.8.4 it's guaranteed to always
- -- return a lazy bytestring with a single chunk.
-
-getSocket :: String -> Int -> IO NS.Socket
-getSocket host' port' = do
- let hints = NS.defaultHints {
- NS.addrFlags = [NS.AI_ADDRCONFIG]
- , NS.addrSocketType = NS.Stream
- }
- (addr:_) <- NS.getAddrInfo (Just hints) (Just host') (Just $ show port')
- sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)
- (NS.addrProtocol addr)
- ee <- try' $ NS.connect sock (NS.addrAddress addr)
- case ee of
- Left e -> NS.sClose sock >> throwIO e
- Right () -> return sock
- where
- try' :: IO a -> IO (Either SomeException a)
- try' = try
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
+module Network.HTTP.Conduit.ConnInfo
+ ( ConnInfo
+ , connClose
+ , connSink
+ , connSource
+ , sslClientConn
+ , socketConn
+ , TLSCertificateRejectReason(..)
+ , TLSCertificateUsage(..)
+ , getSocket
+#if DEBUG
+ , printOpenSockets
+ , requireAllSocketsClosed
+ , clearSocketsList
+#endif
+ ) where
+
+import Control.Exception (SomeException, throwIO, try)
+import System.IO (Handle, hClose)
+
+import Control.Monad.Base (MonadBase, liftBase)
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+
+import Network.Socket (Socket, sClose)
+import Network.Socket.ByteString (recv, sendAll)
+import qualified Network.Socket as NS
+
+import Network.TLS
+import Network.TLS.Extra (ciphersuite_all)
+
+import Data.Certificate.X509 (X509)
+
+import Crypto.Random.AESCtr (makeSystem)
+
+import qualified Data.Conduit as C
+
+#if DEBUG
+import qualified Data.IntMap as IntMap
+import qualified Data.IORef as I
+import System.IO.Unsafe (unsafePerformIO)
+#endif
+
+data ConnInfo = ConnInfo
+ { connRead :: IO ByteString
+ , connWrite :: ByteString -> IO ()
+ , connClose :: IO ()
+ }
+
+connSink :: C.ResourceIO m => ConnInfo -> C.Sink ByteString m ()
+connSink ConnInfo { connWrite = write } = C.Sink $ return $ C.SinkData
+ { C.sinkPush = \bss -> liftBase (write bss) >> return C.Processing
+ , C.sinkClose = return ()
+ }
+
+connSource :: C.ResourceIO m => ConnInfo -> C.Source m ByteString
+connSource ConnInfo { connRead = read' } = C.Source $ return $ C.PreparedSource
+ { C.sourcePull = do
+ bs <- liftBase read'
+ if S.null bs
+ then return C.Closed
+ else return $ C.Open bs
+ , C.sourceClose = return ()
+ }
+
+#if DEBUG
+allOpenSockets :: I.IORef (Int, IntMap.IntMap String)
+allOpenSockets = unsafePerformIO $ I.newIORef (0, IntMap.empty)
+
+addSocket :: String -> IO Int
+addSocket desc = I.atomicModifyIORef allOpenSockets $ \(next, m) ->
+ ((next + 1, IntMap.insert next desc m), next)
+
+removeSocket :: Int -> IO ()
+removeSocket i = I.atomicModifyIORef allOpenSockets $ \(next, m) ->
+ ((next, IntMap.delete i m), ())
+
+printOpenSockets :: IO ()
+printOpenSockets = do
+ (_, m) <- I.readIORef allOpenSockets
+ putStrLn "\n\nOpen sockets:"
+ if IntMap.null m
+ then putStrLn "** No open sockets!"
+ else mapM_ putStrLn $ IntMap.elems m
+
+requireAllSocketsClosed :: IO ()
+requireAllSocketsClosed = do
+ (_, m) <- I.readIORef allOpenSockets
+ if IntMap.null m
+ then return ()
+ else error $ unlines
+ $ "requireAllSocketsClosed: there are open sockets"
+ : IntMap.elems m
+
+clearSocketsList :: IO ()
+clearSocketsList = I.writeIORef allOpenSockets (0, IntMap.empty)
+#endif
+
+socketConn :: String -> Socket -> IO ConnInfo
+socketConn _desc sock = do
+#if DEBUG
+ i <- addSocket _desc
+#endif
+ return ConnInfo
+ { connRead = recv sock 4096
+ , connWrite = sendAll sock
+ , connClose = do
+#if DEBUG
+ removeSocket i
+#endif
+ sClose sock
+ }
+
+sslClientConn :: String -> ([X509] -> IO TLSCertificateUsage) -> Handle -> IO ConnInfo
+sslClientConn _desc onCerts h = do
+#if DEBUG
+ i <- addSocket _desc
+#endif
+ let tcp = defaultParams
+ { pConnectVersion = TLS10
+ , pAllowedVersions = [ TLS10, TLS11 ]
+ , pCiphers = ciphersuite_all
+ , onCertificatesRecv = onCerts
+ }
+ gen <- makeSystem
+ istate <- client tcp gen h
+ _ <- handshake istate
+ return ConnInfo
+ { connRead = recvD istate
+ , connWrite = sendData istate . L.fromChunks . (:[])
+ , connClose = do
+#if DEBUG
+ removeSocket i
+#endif
+ bye istate
+ hClose h
+ }
+ where
+ recvD istate = do
+ x <- recvData istate
+ if L.null x
+ then recvD istate
+ else return $ S.concat $ L.toChunks x
+ -- Although a 'concat' seems like a bad idea, at
+ -- least on tls-0.8.4 it's guaranteed to always
+ -- return a lazy bytestring with a single chunk.
+
+getSocket :: String -> Int -> IO NS.Socket
+getSocket host' port' = do
+ let hints = NS.defaultHints {
+ NS.addrFlags = [NS.AI_ADDRCONFIG]
+ , NS.addrSocketType = NS.Stream
+ }
+ (addr:_) <- NS.getAddrInfo (Just hints) (Just host') (Just $ show port')
+ sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)
+ (NS.addrProtocol addr)
+ ee <- try' $ NS.connect sock (NS.addrAddress addr)
+ case ee of
+ Left e -> NS.sClose sock >> throwIO e
+ Right () -> return sock
+ where
+ try' :: IO a -> IO (Either SomeException a)
+ try' = try
diff --git a/Network/HTTP/Conduit/Manager.hs b/Network/HTTP/Conduit/Manager.hs
index 5cebc9c..7871357 100644
--- a/Network/HTTP/Conduit/Manager.hs
+++ b/Network/HTTP/Conduit/Manager.hs
@@ -1,214 +1,316 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Network.HTTP.Conduit.Manager
- ( Manager
- , ConnKey (..)
- , newManager
- , getConn
- , ConnReuse (..)
- , withManager
- , ConnRelease
- , ManagedConn (..)
- ) where
-
-import Control.Applicative ((<$>))
-import Data.Monoid (mappend)
-import System.IO (hClose, hFlush)
-import qualified Data.IORef as I
-import qualified Data.Map as Map
-
-import qualified Data.ByteString.Char8 as S8
-import qualified Data.ByteString.Lazy as L
-
-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.Resource
- ( ResourceT, runResourceT, ResourceIO, withIO
- , register, release
- , newRef, readRef', writeRef
- , safeFromIOBase
- )
-
-import Network (connectTo, PortID (PortNumber))
-import Data.Certificate.X509 (X509)
-
-import Network.HTTP.Conduit.ConnInfo
-import Network.HTTP.Conduit.Util (hGetSome)
-import Network.HTTP.Conduit.Parser (parserHeadersFromByteString)
-import Network.HTTP.Conduit.Request
-
-
--- | Keeps track of open connections for keep-alive. May be used
--- concurrently by multiple threads.
-newtype Manager = Manager
- { mConns :: I.IORef (Map.Map ConnKey ConnInfo)
- }
-
--- | @ConnKey@ consists of a hostname, a port and a @Bool@
--- specifying whether to use keepalive.
-data ConnKey = ConnKey !Text !Int !Bool
- deriving (Eq, Show, Ord)
-
-takeSocket :: Manager -> ConnKey -> IO (Maybe ConnInfo)
-takeSocket man key =
- I.atomicModifyIORef (mConns man) go
- where
- go m = (Map.delete key m, Map.lookup key m)
-
-putSocket :: Manager -> ConnKey -> ConnInfo -> IO ()
-putSocket man key ci = do
- msock <- I.atomicModifyIORef (mConns man) go
- maybe (return ()) connClose msock
- where
- go m = (Map.insert key ci m, Map.lookup key m)
-
--- | Create a new 'Manager' with no open connections.
-newManager :: ResourceIO m => ResourceT m Manager
-newManager = snd <$> withIO
- (Manager <$> I.newIORef Map.empty)
- closeManager
-
-withManager :: ResourceIO m => (Manager -> ResourceT m a) -> m a
-withManager f = runResourceT $ newManager >>= f
-
--- | Close all connections in a 'Manager'. Afterwards, the
--- 'Manager' can be reused if desired.
-closeManager :: Manager -> IO ()
-closeManager (Manager i) = do
- m <- I.atomicModifyIORef i $ \x -> (Map.empty, x)
- mapM_ connClose $ Map.elems m
-
-getSocketConn
- :: ResourceIO m
- => Manager
- -> String
- -> Int
- -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn)
-getSocketConn man host' port' =
- getManagedConn man (ConnKey (T.pack host') port' False) $
- getSocket host' port' >>= socketConn desc
- where
- desc = socketDesc host' port' "unsecured"
-
-socketDesc :: String -> Int -> String -> String
-socketDesc h p t = unwords [h, show p, t]
-
-getSslConn :: ResourceIO m
- => ([X509] -> IO TLSCertificateUsage)
- -> Manager
- -> String -- ^ host
- -> Int -- ^ port
- -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn)
-getSslConn checkCert man host' port' =
- getManagedConn man (ConnKey (T.pack host') port' True) $
- (connectTo host' (PortNumber $ fromIntegral port') >>= sslClientConn desc checkCert)
- where
- desc = socketDesc host' port' "secured"
-
-getSslProxyConn
- :: ResourceIO m
- => ([X509] -> IO TLSCertificateUsage)
- -> S8.ByteString -- ^ Target host
- -> Int -- ^ Target port
- -> Manager
- -> String -- ^ Proxy host
- -> Int -- ^ Proxy port
- -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn)
-getSslProxyConn checkCert thost tport man phost pport =
- getManagedConn man (ConnKey (T.pack phost) pport True) $
- doConnect >>= sslClientConn desc checkCert
- where
- desc = socketDesc phost pport "secured-proxy"
- doConnect = do
- h <- connectTo phost (PortNumber $ fromIntegral pport)
- L.hPutStr h $ Blaze.toLazyByteString connectRequest
- hFlush h
- r <- hGetSome h 2048
- res <- parserHeadersFromByteString r
- case res of
- Right ((_, 200, _), _) -> return h
- Right ((_, _, msg), _) -> hClose h >> proxyError (S8.unpack msg)
- Left s -> hClose h >> proxyError s
-
- connectRequest =
- Blaze.fromByteString "CONNECT "
- `mappend` Blaze.fromByteString thost
- `mappend` Blaze.fromByteString (S8.pack (':' : show tport))
- `mappend` Blaze.fromByteString " HTTP/1.1\r\n\r\n"
- proxyError s =
- error $ "Proxy failed to CONNECT to '"
- ++ S8.unpack thost ++ ":" ++ show tport ++ "' : " ++ s
-
-data ManagedConn = Fresh | Reused
-
--- | This function needs to acquire a @ConnInfo@- either from the @Manager@ or
--- 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
- => Manager
- -> ConnKey
- -> IO ConnInfo
- -> ResourceT 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
- -- Try to take the socket out of the manager.
- mci <- liftBase $ 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
- return (ci, Fresh)
- -- Return the existing one
- Just ci -> return (ci, Reused)
-
- -- When we release this connection, we can either reuse it (put it back in
- -- 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
-
- -- Now register our release action.
- releaseKey <- register $ do
- toReuse <- readRef' 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
-
- -- 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
- release releaseKey
- return (connRelease, ci, isManaged)
-
-data ConnReuse = Reuse | DontReuse
-
-type ConnRelease m = ConnReuse -> ResourceT m ()
-
-getConn :: ResourceIO m
- => Request m
- -> Manager
- -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn)
-getConn req m =
- go m connhost connport
- where
- h = host req
- (useProxy, connhost, connport) =
- case proxy req of
- Just p -> (True, S8.unpack (proxyHost p), proxyPort p)
- Nothing -> (False, S8.unpack h, port req)
- go =
- case (secure req, useProxy) of
- (False, _) -> getSocketConn
- (True, False) -> getSslConn $ checkCerts req h
- (True, True) -> getSslProxyConn (checkCerts req h) h (port req)
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Network.HTTP.Conduit.Manager
+ ( Manager
+ , ConnKey (..)
+ , newManager
+ , newManagerCount
+ , newManagerIO
+ , getConn
+ , ConnReuse (..)
+ , withManager
+ , ConnRelease
+ , ManagedConn (..)
+ ) where
+
+import Prelude hiding (catch)
+import Control.Applicative ((<$>))
+import Data.Monoid (mappend)
+import System.IO (hClose, hFlush)
+import qualified Data.IORef as I
+import qualified Data.Map as Map
+
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Lazy as L
+
+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.Exception (mask_, SomeException, catch)
+import Control.Monad.Trans.Resource
+ ( ResourceT, runResourceT, ResourceIO, withIO
+ , register, release
+ , newRef, readRef', writeRef
+ , safeFromIOBase
+ )
+import Control.Concurrent (forkIO, threadDelay)
+import Data.Time (UTCTime, getCurrentTime, addUTCTime)
+
+import Network (connectTo, PortID (PortNumber))
+import Data.Certificate.X509 (X509)
+
+import Network.HTTP.Conduit.ConnInfo
+import Network.HTTP.Conduit.Util (hGetSome)
+import Network.HTTP.Conduit.Parser (parserHeadersFromByteString)
+import Network.HTTP.Conduit.Request
+
+-- | Keeps track of open connections for keep-alive. May be used
+-- concurrently by multiple threads.
+data Manager = Manager
+ { mConns :: !(I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo))))
+ -- ^ @Nothing@ indicates that the manager is closed.
+ , mMaxConns :: !Int
+ -- ^ This is a per-@ConnKey@ value.
+ }
+
+data NonEmptyList a =
+ One !a !UTCTime |
+ Cons !a !Int !UTCTime !(NonEmptyList a)
+
+-- | @ConnKey@ consists of a hostname, a port and a @Bool@
+-- specifying whether to use keepalive.
+data ConnKey = ConnKey !Text !Int !Bool
+ deriving (Eq, Show, Ord)
+
+takeSocket :: Manager -> ConnKey -> IO (Maybe ConnInfo)
+takeSocket man key =
+ I.atomicModifyIORef (mConns man) go
+ where
+ go Nothing = (Nothing, Nothing)
+ go (Just m) =
+ case Map.lookup key m of
+ Nothing -> (Just m, Nothing)
+ Just (One a _) -> (Just $ Map.delete key m, Just a)
+ Just (Cons a _ _ rest) -> (Just $ Map.insert key rest m, Just a)
+
+putSocket :: Manager -> ConnKey -> ConnInfo -> IO ()
+putSocket man key ci = do
+ now <- getCurrentTime
+ msock <- I.atomicModifyIORef (mConns man) (go now)
+ maybe (return ()) connClose msock
+ where
+ go _ Nothing = (Nothing, Just ci)
+ go now (Just m) =
+ case Map.lookup key m of
+ Nothing -> (Just $ Map.insert key (One ci now) m, Nothing)
+ Just l ->
+ let (l', mx) = addToList now (mMaxConns man) ci l
+ in (Just $ Map.insert key l' m, mx)
+
+-- | Add a new element to the list, up to the given maximum number. If we're
+-- already at the maximum, return the new value as leftover.
+addToList :: UTCTime -> Int -> a -> NonEmptyList a -> (NonEmptyList a, Maybe a)
+addToList _ i x l | i <= 1 = (l, Just x)
+addToList now _ x l@One{} = (Cons x 2 now l, Nothing)
+addToList now maxCount x l@(Cons _ currCount _ _)
+ | maxCount > currCount = (Cons x (currCount + 1) now l, Nothing)
+ | otherwise = (l, Just x)
+
+-- | Create a new 'Manager' with no open connections and a maximum of 10 open connections..
+newManager :: ResourceIO m => ResourceT m Manager
+newManager = newManagerCount 10
+
+-- | Create a new 'Manager' with the specified max connection count.
+newManagerCount :: ResourceIO m => Int -> ResourceT m Manager
+newManagerCount count = snd <$> withIO (newManagerIO count) closeManager
+
+-- | Create a 'Manager' which will never be destroyed.
+newManagerIO :: Int -> IO Manager
+newManagerIO count = do
+ mapRef <- I.newIORef (Just Map.empty)
+ _ <- forkIO $ reap mapRef
+ return $ Manager mapRef count
+
+-- | Collect and destroy any stale connections.
+reap :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo))) -> IO ()
+reap mapRef =
+ mask_ loop
+ where
+ loop = do
+ threadDelay (5 * 1000 * 1000)
+ now <- getCurrentTime
+ let isNotStale time = 30 `addUTCTime` time >= now
+ mtoDestroy <- I.atomicModifyIORef mapRef (findStaleWrap isNotStale)
+ case mtoDestroy of
+ Nothing -> return () -- manager is closed
+ Just toDestroy -> do
+ mapM_ safeConnClose toDestroy
+ loop
+ findStaleWrap _ Nothing = (Nothing, Nothing)
+ findStaleWrap isNotStale (Just m) =
+ let (x, y) = findStale isNotStale m
+ in (Just x, Just y)
+ findStale isNotStale =
+ findStale' id id . Map.toList
+ where
+ findStale' destroy keep [] = (Map.fromList $ keep [], destroy [])
+ findStale' destroy keep ((connkey, nelist):rest) =
+ findStale' destroy' keep' rest
+ where
+ -- Note: By definition, the timestamps must be in descending order,
+ -- so we don't need to traverse the whole list.
+ (notStale, stale) = span (isNotStale . fst) $ neToList nelist
+ destroy' = destroy . (map snd stale++)
+ keep' =
+ case neFromList notStale of
+ Nothing -> keep
+ Just x -> keep . ((connkey, x):)
+
+neToList :: NonEmptyList a -> [(UTCTime, a)]
+neToList (One a t) = [(t, a)]
+neToList (Cons a _ t nelist) = (t, a) : neToList nelist
+
+neFromList :: [(UTCTime, a)] -> Maybe (NonEmptyList a)
+neFromList [] = Nothing
+neFromList [(t, a)] = Just (One a t)
+neFromList xs =
+ Just . snd . go $ xs
+ where
+ go [] = error "neFromList.go []"
+ go [(t, a)] = (2, One a t)
+ go ((t, a):rest) =
+ let (i, rest') = go rest
+ i' = i + 1
+ in i' `seq` (i', Cons a i t rest')
+
+withManager :: ResourceIO m => (Manager -> ResourceT m a) -> m a
+withManager f = runResourceT $ newManager >>= f
+
+-- | Close all connections in a 'Manager'. Afterwards, the
+-- 'Manager' can be reused if desired.
+closeManager :: Manager -> IO ()
+closeManager manager = mask_ $ do
+ m <- I.atomicModifyIORef (mConns manager) $ \x -> (Nothing, x)
+ mapM_ (nonEmptyMapM_ safeConnClose) $ maybe [] Map.elems m
+
+safeConnClose :: ConnInfo -> IO ()
+safeConnClose ci = connClose ci `catch` \(_::SomeException) -> return ()
+
+nonEmptyMapM_ :: Monad m => (a -> m ()) -> NonEmptyList a -> m ()
+nonEmptyMapM_ f (One x _) = f x
+nonEmptyMapM_ f (Cons x _ _ l) = f x >> nonEmptyMapM_ f l
+
+getSocketConn
+ :: ResourceIO m
+ => Manager
+ -> String
+ -> Int
+ -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn)
+getSocketConn man host' port' =
+ getManagedConn man (ConnKey (T.pack host') port' False) $
+ getSocket host' port' >>= socketConn desc
+ where
+ desc = socketDesc host' port' "unsecured"
+
+socketDesc :: String -> Int -> String -> String
+socketDesc h p t = unwords [h, show p, t]
+
+getSslConn :: ResourceIO m
+ => ([X509] -> IO TLSCertificateUsage)
+ -> Manager
+ -> String -- ^ host
+ -> Int -- ^ port
+ -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn)
+getSslConn checkCert man host' port' =
+ getManagedConn man (ConnKey (T.pack host') port' True) $
+ (connectTo host' (PortNumber $ fromIntegral port') >>= sslClientConn desc checkCert)
+ where
+ desc = socketDesc host' port' "secured"
+
+getSslProxyConn
+ :: ResourceIO m
+ => ([X509] -> IO TLSCertificateUsage)
+ -> S8.ByteString -- ^ Target host
+ -> Int -- ^ Target port
+ -> Manager
+ -> String -- ^ Proxy host
+ -> Int -- ^ Proxy port
+ -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn)
+getSslProxyConn checkCert thost tport man phost pport =
+ getManagedConn man (ConnKey (T.pack phost) pport True) $
+ doConnect >>= sslClientConn desc checkCert
+ where
+ desc = socketDesc phost pport "secured-proxy"
+ doConnect = do
+ h <- connectTo phost (PortNumber $ fromIntegral pport)
+ L.hPutStr h $ Blaze.toLazyByteString connectRequest
+ hFlush h
+ r <- hGetSome h 2048
+ res <- parserHeadersFromByteString r
+ case res of
+ Right ((_, 200, _), _) -> return h
+ Right ((_, _, msg), _) -> hClose h >> proxyError (S8.unpack msg)
+ Left s -> hClose h >> proxyError s
+
+ connectRequest =
+ Blaze.fromByteString "CONNECT "
+ `mappend` Blaze.fromByteString thost
+ `mappend` Blaze.fromByteString (S8.pack (':' : show tport))
+ `mappend` Blaze.fromByteString " HTTP/1.1\r\n\r\n"
+ proxyError s =
+ error $ "Proxy failed to CONNECT to '"
+ ++ S8.unpack thost ++ ":" ++ show tport ++ "' : " ++ s
+
+data ManagedConn = Fresh | Reused
+
+-- | This function needs to acquire a @ConnInfo@- either from the @Manager@ or
+-- 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
+ => Manager
+ -> ConnKey
+ -> IO ConnInfo
+ -> ResourceT 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
+ -- Try to take the socket out of the manager.
+ mci <- liftBase $ 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
+ return (ci, Fresh)
+ -- Return the existing one
+ Just ci -> return (ci, Reused)
+
+ -- When we release this connection, we can either reuse it (put it back in
+ -- 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
+
+ -- Now register our release action.
+ releaseKey <- register $ do
+ toReuse <- readRef' 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
+
+ -- 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
+ release releaseKey
+ return (connRelease, ci, isManaged)
+
+data ConnReuse = Reuse | DontReuse
+
+type ConnRelease m = ConnReuse -> ResourceT m ()
+
+getConn :: ResourceIO m
+ => Request m
+ -> Manager
+ -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn)
+getConn req m =
+ go m connhost connport
+ where
+ h = host req
+ (useProxy, connhost, connport) =
+ case proxy req of
+ Just p -> (True, S8.unpack (proxyHost p), proxyPort p)
+ Nothing -> (False, S8.unpack h, port req)
+ go =
+ case (secure req, useProxy) of
+ (False, _) -> getSocketConn
+ (True, False) -> getSslConn $ checkCerts req h
+ (True, True) -> getSslProxyConn (checkCerts req h) h (port req)
diff --git a/Network/HTTP/Conduit/Parser.hs b/Network/HTTP/Conduit/Parser.hs
index 4c37f71..5ca62f0 100644
--- a/Network/HTTP/Conduit/Parser.hs
+++ b/Network/HTTP/Conduit/Parser.hs
@@ -1,122 +1,122 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-module Network.HTTP.Conduit.Parser
- ( sinkHeaders
- , newline
- , parserHeadersFromByteString
- , parseChunkHeader
- ) where
-
-import Prelude hiding (take, takeWhile)
-import Control.Applicative
-import Data.Word (Word8)
-
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Char8 as S8
-
-import Data.Attoparsec
-
-import Data.Conduit.Attoparsec (sinkParser)
-import Data.Conduit (Sink, ResourceIO)
-import Control.Monad (when)
-
-
-type Header = (S.ByteString, S.ByteString)
-
-parseHeader :: Parser Header
-parseHeader = do
- k <- takeWhile1 notNewlineColon
- _ <- word8 58 -- colon
- skipWhile isSpace
- v <- takeWhile notNewline
- newline
- return (k, v)
-
-notNewlineColon, isSpace, notNewline :: Word8 -> Bool
-
-notNewlineColon 10 = False -- LF
-notNewlineColon 13 = False -- CR
-notNewlineColon 58 = False -- colon
-notNewlineColon _ = True
-
-isSpace 32 = True
-isSpace _ = False
-
-notNewline 10 = False
-notNewline 13 = False
-notNewline _ = True
-
-newline :: Parser ()
-newline =
- lf <|> (cr >> lf)
- where
- word8' x = word8 x >> return ()
- lf = word8' 10
- cr = word8' 13
-
-parseHeaders :: Parser (Status, [Header])
-parseHeaders = do
- s <- parseStatus <?> "HTTP status line"
- h <- manyTill parseHeader newline <?> "Response headers"
- return (s, h)
-
-sinkHeaders :: ResourceIO m => Sink S.ByteString m (Status, [Header])
-sinkHeaders = sinkParser parseHeaders
-
-
-parserHeadersFromByteString :: Monad m => S.ByteString -> m (Either String (Status, [Header]))
-parserHeadersFromByteString s = return $ parseOnly parseHeaders s
-
-
-type Status = (S.ByteString, Int, S.ByteString)
-
-parseStatus :: Parser Status
-parseStatus = do
- end <- atEnd
- when end $ fail "EOF reached"
- _ <- manyTill (take 1 >> return ()) (try $ string "HTTP/") <?> "HTTP/"
- ver <- takeWhile1 $ not . isSpace
- _ <- word8 32 -- space
- statCode <- takeWhile1 $ not . isSpace
- statCode' <-
- case reads $ S8.unpack statCode of
- [] -> fail $ "Invalid status code: " ++ S8.unpack statCode
- (x, _):_ -> return x
- _ <- word8 32
- statMsg <- takeWhile1 $ notNewline
- newline
- if (statCode == "100")
- then newline >> parseStatus
- else return (ver, statCode', statMsg)
-
-parseChunkHeader :: Parser Int
-parseChunkHeader = do
- len <- hexs
- skipWhile isSpace
- newline <|> attribs
- return len
-
-attribs :: Parser ()
-attribs = do
- _ <- word8 59 -- colon
- skipWhile notNewline
- newline
-
-hexs :: Parser Int
-hexs = do
- ws <- many1 hex
- return $ foldl1 (\a b -> a * 16 + b) $ map fromIntegral ws
-
-hex :: Parser Word8
-hex =
- (digit <|> upper <|> lower) <?> "Hexadecimal digit"
- where
- digit = do
- d <- satisfy $ \w -> (w >= 48 && w <= 57)
- return $ d - 48
- upper = do
- d <- satisfy $ \w -> (w >= 65 && w <= 70)
- return $ d - 55
- lower = do
- d <- satisfy $ \w -> (w >= 97 && w <= 102)
- return $ d - 87
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Network.HTTP.Conduit.Parser
+ ( sinkHeaders
+ , newline
+ , parserHeadersFromByteString
+ , parseChunkHeader
+ ) where
+
+import Prelude hiding (take, takeWhile)
+import Control.Applicative
+import Data.Word (Word8)
+
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
+
+import Data.Attoparsec
+
+import Data.Conduit.Attoparsec (sinkParser)
+import Data.Conduit (Sink, ResourceIO)
+import Control.Monad (when)
+
+
+type Header = (S.ByteString, S.ByteString)
+
+parseHeader :: Parser Header
+parseHeader = do
+ k <- takeWhile1 notNewlineColon
+ _ <- word8 58 -- colon
+ skipWhile isSpace
+ v <- takeWhile notNewline
+ newline
+ return (k, v)
+
+notNewlineColon, isSpace, notNewline :: Word8 -> Bool
+
+notNewlineColon 10 = False -- LF
+notNewlineColon 13 = False -- CR
+notNewlineColon 58 = False -- colon
+notNewlineColon _ = True
+
+isSpace 32 = True
+isSpace _ = False
+
+notNewline 10 = False
+notNewline 13 = False
+notNewline _ = True
+
+newline :: Parser ()
+newline =
+ lf <|> (cr >> lf)
+ where
+ word8' x = word8 x >> return ()
+ lf = word8' 10
+ cr = word8' 13
+
+parseHeaders :: Parser (Status, [Header])
+parseHeaders = do
+ s <- parseStatus <?> "HTTP status line"
+ h <- manyTill parseHeader newline <?> "Response headers"
+ return (s, h)
+
+sinkHeaders :: ResourceIO m => Sink S.ByteString m (Status, [Header])
+sinkHeaders = sinkParser parseHeaders
+
+
+parserHeadersFromByteString :: Monad m => S.ByteString -> m (Either String (Status, [Header]))
+parserHeadersFromByteString s = return $ parseOnly parseHeaders s
+
+
+type Status = (S.ByteString, Int, S.ByteString)
+
+parseStatus :: Parser Status
+parseStatus = do
+ end <- atEnd
+ when end $ fail "EOF reached"
+ _ <- manyTill (take 1 >> return ()) (try $ string "HTTP/") <?> "HTTP/"
+ ver <- takeWhile1 $ not . isSpace
+ _ <- word8 32 -- space
+ statCode <- takeWhile1 $ not . isSpace
+ statCode' <-
+ case reads $ S8.unpack statCode of
+ [] -> fail $ "Invalid status code: " ++ S8.unpack statCode
+ (x, _):_ -> return x
+ _ <- word8 32
+ statMsg <- takeWhile1 $ notNewline
+ newline
+ if (statCode == "100")
+ then newline >> parseStatus
+ else return (ver, statCode', statMsg)
+
+parseChunkHeader :: Parser Int
+parseChunkHeader = do
+ len <- hexs
+ skipWhile isSpace
+ newline <|> attribs
+ return len
+
+attribs :: Parser ()
+attribs = do
+ _ <- word8 59 -- colon
+ skipWhile notNewline
+ newline
+
+hexs :: Parser Int
+hexs = do
+ ws <- many1 hex
+ return $ foldl1 (\a b -> a * 16 + b) $ map fromIntegral ws
+
+hex :: Parser Word8
+hex =
+ (digit <|> upper <|> lower) <?> "Hexadecimal digit"
+ where
+ digit = do
+ d <- satisfy $ \w -> (w >= 48 && w <= 57)
+ return $ d - 48
+ upper = do
+ d <- satisfy $ \w -> (w >= 65 && w <= 70)
+ return $ d - 55
+ lower = do
+ d <- satisfy $ \w -> (w >= 97 && w <= 102)
+ return $ d - 87
diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs
index f21cb97..847d443 100644
--- a/Network/HTTP/Conduit/Request.hs
+++ b/Network/HTTP/Conduit/Request.hs
@@ -1,344 +1,344 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Network.HTTP.Conduit.Request
- ( Request (..)
- , RequestBody (..)
- , ContentType
- , Proxy (..)
- , parseUrl
- , browserDecompress
- , HttpException (..)
- , defaultCheckCerts
- , alwaysDecompress
- , addProxy
- , applyBasicAuth
- , urlEncodedBody
- , needsGunzip
- , requestBuilder
- ) where
-
-import Data.Int (Int64)
-import Data.Maybe (fromMaybe)
-import Data.Monoid (mempty, mappend)
-import Data.Typeable (Typeable)
-
-import Data.Default (Default (def))
-
-import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
-import Blaze.ByteString.Builder.Char8 (fromChar)
-import qualified Blaze.ByteString.Builder as Blaze
-
-import qualified Data.Conduit as C
-import qualified Data.Conduit.List as CL
-
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Char8 as S8
-import qualified Data.ByteString.Lazy as L
-
-import qualified Network.HTTP.Types as W
-import Data.Certificate.X509 (X509)
-
-import Network.TLS (TLSCertificateUsage (CertificateUsageAccept))
-import Network.TLS.Extra (certificateVerifyChain, certificateVerifyDomain)
-
-import Control.Exception (Exception, SomeException, toException)
-import Control.Failure (Failure (failure))
-import Codec.Binary.UTF8.String (encodeString)
-import qualified Data.CaseInsensitive as CI
-import qualified Data.ByteString.Base64 as B64
-
-import Network.HTTP.Conduit.Chunk (chunkIt)
-import Network.HTTP.Conduit.Util (readDec, (<>))
-
-type ContentType = S.ByteString
-
--- | All information on how to connect to a host and what should be sent in the
--- HTTP request.
---
--- If you simply wish to download from a URL, see 'parseUrl'.
---
--- The constructor for this data type is not exposed. Instead, you should use
--- either the 'def' method to retrieve a default instance, or 'parseUrl' to
--- construct from a URL, and then use the records below to make modifications.
--- This approach allows http-conduit to add configuration options without
--- breaking backwards compatibility.
-data Request m = Request
- { method :: W.Method
- -- ^ HTTP request method, eg GET, POST.
- , secure :: Bool
- -- ^ Whether to use HTTPS (ie, SSL).
- , checkCerts :: W.Ascii -> [X509] -> IO TLSCertificateUsage
- -- ^ Check if the server certificate is valid. Only relevant for HTTPS.
- , host :: W.Ascii
- , port :: Int
- , path :: W.Ascii
- -- ^ Everything from the host to the query string.
- , queryString :: W.Ascii
- , requestHeaders :: W.RequestHeaders
- , requestBody :: RequestBody m
- , proxy :: Maybe Proxy
- -- ^ Optional HTTP proxy.
- , rawBody :: Bool
- -- ^ If @True@, a chunked and\/or gzipped body will not be
- -- decoded. Use with caution.
- , decompress :: ContentType -> Bool
- -- ^ Predicate to specify whether gzipped data should be
- -- decompressed on the fly (see 'alwaysDecompress' and
- -- 'browserDecompress'). Default: browserDecompress.
- , redirectCount :: Int
- -- ^ How many redirects to follow when getting a resource. 0 means follow
- -- no redirects. Default value: 10.
- , checkStatus :: W.Status -> W.ResponseHeaders -> Maybe SomeException
- -- ^ Check the status code. Note that this will run after all redirects are
- -- performed. Default: return a @StatusCodeException@ on non-2XX responses.
- }
-
--- | When using one of the
--- 'RequestBodySource'\/'RequestBodySourceChunked' constructors
--- and any function which calls 'redirectIter', you must ensure
--- that the 'Source' can be called multiple times. Usually this
--- is not a problem.
---
--- The 'RequestBodySourceChunked' will send a chunked request
--- body, note that not all servers support this. Only use
--- 'RequestBodySourceChunked' if you know the server you're
--- sending to supports chunked request bodies.
-data RequestBody m
- = RequestBodyLBS L.ByteString
- | RequestBodyBS S.ByteString
- | RequestBodyBuilder Int64 Blaze.Builder
- | RequestBodySource Int64 (C.Source m Blaze.Builder)
- | RequestBodySourceChunked (C.Source m Blaze.Builder)
-
--- | Define a HTTP proxy, consisting of a hostname and port number.
-
-data Proxy = Proxy
- { proxyHost :: W.Ascii -- ^ The host name of the HTTP proxy.
- , proxyPort :: Int -- ^ The port number of the HTTP proxy.
- }
-
-encodeUrlCharPI :: Char -> String
-encodeUrlCharPI '/' = "/"
-encodeUrlCharPI c = encodeUrlChar c
-
-encodeUrlChar :: Char -> String
-encodeUrlChar c
- -- List of unreserved characters per RFC 3986
- -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding
- | 'A' <= c && c <= 'Z' = [c]
- | 'a' <= c && c <= 'z' = [c]
- | '0' <= c && c <= '9' = [c]
-encodeUrlChar c@'-' = [c]
-encodeUrlChar c@'_' = [c]
-encodeUrlChar c@'.' = [c]
-encodeUrlChar c@'~' = [c]
-encodeUrlChar y =
- let (a, c) = fromEnum y `divMod` 16
- b = a `mod` 16
- showHex' x
- | x < 10 = toEnum $ x + (fromEnum '0')
- | x < 16 = toEnum $ x - 10 + (fromEnum 'A')
- | otherwise = error $ "Invalid argument to showHex: " ++ show x
- in ['%', showHex' b, showHex' c]
-
--- | Convert a URL into a 'Request'.
---
--- This defaults some of the values in 'Request', such as setting 'method' to
--- GET and 'requestHeaders' to @[]@.
---
--- Since this function uses 'Failure', the return monad can be anything that is
--- an instance of 'Failure', such as 'IO' or 'Maybe'.
-parseUrl :: Failure HttpException m => String -> m (Request m')
-parseUrl s@('h':'t':'t':'p':':':'/':'/':rest) = parseUrl1 s False rest
-parseUrl s@('h':'t':'t':'p':'s':':':'/':'/':rest) = parseUrl1 s True rest
-parseUrl x = failure $ InvalidUrlException x "Invalid scheme"
-
-parseUrl1 :: Failure HttpException m
- => String -> Bool -> String -> m (Request m')
-parseUrl1 full sec s =
- parseUrl2 full sec s'
- where
- s' = encodeString s
-
-defaultCheckCerts :: W.Ascii -> [X509] -> IO TLSCertificateUsage
-defaultCheckCerts host' certs =
- case certificateVerifyDomain (S8.unpack host') certs of
- CertificateUsageAccept -> certificateVerifyChain certs
- _ -> return CertificateUsageAccept
-
-instance Default (Request m) where
- def = Request
- { host = "localhost"
- , port = 80
- , secure = False
- , checkCerts = defaultCheckCerts
- , requestHeaders = []
- , path = "/"
- , queryString = S8.empty
- , requestBody = RequestBodyLBS L.empty
- , method = "GET"
- , proxy = Nothing
- , rawBody = False
- , decompress = browserDecompress
- , redirectCount = 10
- , checkStatus = \s@(W.Status sci _) hs ->
- if 200 <= sci && sci < 300
- then Nothing
- else Just $ toException $ StatusCodeException s hs
- }
-
-parseUrl2 :: Failure HttpException m
- => String -> Bool -> String -> m (Request m')
-parseUrl2 full sec s = do
- port' <- mport
- return def
- { host = S8.pack hostname
- , port = port'
- , secure = sec
- , path = S8.pack
- $ if null path''
- then "/"
- else concatMap encodeUrlCharPI path''
- , queryString = S8.pack qstring
- }
- where
- (beforeSlash, afterSlash) = break (== '/') s
- (hostname, portStr) = break (== ':') beforeSlash
- (path', qstring') = break (== '?') afterSlash
- path'' = path'
- qstring'' = case qstring' of
- '?':x -> x
- _ -> qstring'
- qstring = takeWhile (/= '#') qstring''
- mport =
- case (portStr, sec) of
- ("", False) -> return 80
- ("", True) -> return 443
- (':':rest, _) -> maybe
- (failure $ InvalidUrlException full "Invalid port")
- return
- (readDec rest)
- x -> error $ "parseUrl1: this should never happen: " ++ show x
-
-data HttpException = StatusCodeException W.Status W.ResponseHeaders
- | InvalidUrlException String String
- | TooManyRedirects
- | HttpParserException String
- deriving (Show, Typeable)
-instance Exception HttpException
-
--- | Always decompress a compressed stream.
-alwaysDecompress :: ContentType -> Bool
-alwaysDecompress = const True
-
--- | Decompress a compressed stream unless the content-type is 'application/x-tar'.
-browserDecompress :: ContentType -> Bool
-browserDecompress = (/= "application/x-tar")
-
--- | Add a Basic Auth header (with the specified user name and password) to the
--- given Request. Ignore error handling:
---
--- applyBasicAuth "user" "pass" $ fromJust $ parseUrl url
-
-applyBasicAuth :: S.ByteString -> S.ByteString -> Request m -> Request m
-applyBasicAuth user passwd req =
- req { requestHeaders = authHeader : requestHeaders req }
- where
- authHeader = (CI.mk "Authorization", basic)
- basic = S8.append "Basic " (B64.encode $ S8.concat [ user, ":", passwd ])
-
-
--- | Add a proxy to the the Request so that the Request when executed will use
--- the provided proxy.
-addProxy :: S.ByteString -> Int -> Request m -> Request m
-addProxy hst prt req =
- req { proxy = Just $ Proxy hst prt }
-
--- FIXME add a helper for generating POST bodies
-
--- | Add url-encoded paramters to the 'Request'.
---
--- This sets a new 'requestBody', adds a content-type request header and
--- changes the 'method' to POST.
-urlEncodedBody :: Monad m => [(S.ByteString, S.ByteString)] -> Request m' -> Request m
-urlEncodedBody headers req = req
- { requestBody = RequestBodyLBS body
- , method = "POST"
- , requestHeaders =
- (ct, "application/x-www-form-urlencoded")
- : filter (\(x, _) -> x /= ct) (requestHeaders req)
- }
- where
- ct = "Content-Type"
- body = L.fromChunks . return $ W.renderSimpleQuery False headers
-
-needsGunzip :: Request m
- -> [W.Header] -- ^ response headers
- -> Bool
-needsGunzip req hs' =
- not (rawBody req)
- && ("content-encoding", "gzip") `elem` hs'
- && decompress req (fromMaybe "" $ lookup "content-type" hs')
-
-requestBuilder
- :: C.Resource m
- => Request m
- -> C.Source m Builder
-requestBuilder req =
- CL.sourceList [builder] `mappend` bodySource
- where
- sourceSingle = CL.sourceList . return
-
- (contentLength, bodySource) =
- case requestBody req of
- RequestBodyLBS lbs -> (Just $ L.length lbs, sourceSingle $ fromLazyByteString lbs)
- RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, sourceSingle $ fromByteString bs)
- RequestBodyBuilder i b -> (Just $ i, sourceSingle b)
- RequestBodySource i source -> (Just i, source)
- RequestBodySourceChunked source -> (Nothing, source C.$= chunkIt)
-
- hh
- | port req == 80 && not (secure req) = host req
- | port req == 443 && secure req = host req
- | otherwise = host req <> S8.pack (':' : show (port req))
-
- contentLengthHeader (Just contentLength') =
- if method req `elem` ["GET", "HEAD"] && contentLength' == 0
- then id
- else (:) ("Content-Length", S8.pack $ show contentLength')
- contentLengthHeader Nothing = (:) ("Transfer-Encoding", "chunked")
-
- headerPairs :: W.RequestHeaders
- headerPairs
- = ("Host", hh)
- : ("Accept-Encoding", "gzip")
- : (contentLengthHeader contentLength)
- (requestHeaders req)
-
- builder :: Builder
- builder =
- fromByteString (method req)
- <> fromByteString " "
- <> (case proxy req of
- Just{} ->
- fromByteString (if secure req then "https://" else "http://")
- <> fromByteString hh
- Nothing -> mempty)
- <> (case S8.uncons $ path req of
- Just ('/', _) -> fromByteString $ path req
- _ -> fromByteString "/" <> fromByteString (path req))
- <> (if S8.null (queryString req)
- then mempty
- else fromChar '?' <> fromByteString (queryString req))
- <> fromByteString " HTTP/1.1\r\n"
- <> foldr
- (\a b -> headerPairToBuilder a <> b)
- (fromByteString "\r\n")
- headerPairs
-
- headerPairToBuilder (k, v) =
- fromByteString (CI.original k)
- <> fromByteString ": "
- <> fromByteString v
- <> fromByteString "\r\n"
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Network.HTTP.Conduit.Request
+ ( Request (..)
+ , RequestBody (..)
+ , ContentType
+ , Proxy (..)
+ , parseUrl
+ , browserDecompress
+ , HttpException (..)
+ , defaultCheckCerts
+ , alwaysDecompress
+ , addProxy
+ , applyBasicAuth
+ , urlEncodedBody
+ , needsGunzip
+ , requestBuilder
+ ) where
+
+import Data.Int (Int64)
+import Data.Maybe (fromMaybe)
+import Data.Monoid (mempty, mappend)
+import Data.Typeable (Typeable)
+
+import Data.Default (Default (def))
+
+import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
+import Blaze.ByteString.Builder.Char8 (fromChar)
+import qualified Blaze.ByteString.Builder as Blaze
+
+import qualified Data.Conduit as C
+import qualified Data.Conduit.List as CL
+
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Lazy as L
+
+import qualified Network.HTTP.Types as W
+import Data.Certificate.X509 (X509)
+
+import Network.TLS (TLSCertificateUsage (CertificateUsageAccept))
+import Network.TLS.Extra (certificateVerifyChain, certificateVerifyDomain)
+
+import Control.Exception (Exception, SomeException, toException)
+import Control.Failure (Failure (failure))
+import Codec.Binary.UTF8.String (encodeString)
+import qualified Data.CaseInsensitive as CI
+import qualified Data.ByteString.Base64 as B64
+
+import Network.HTTP.Conduit.Chunk (chunkIt)
+import Network.HTTP.Conduit.Util (readDec, (<>))
+
+type ContentType = S.ByteString
+
+-- | All information on how to connect to a host and what should be sent in the
+-- HTTP request.
+--
+-- If you simply wish to download from a URL, see 'parseUrl'.
+--
+-- The constructor for this data type is not exposed. Instead, you should use
+-- either the 'def' method to retrieve a default instance, or 'parseUrl' to
+-- construct from a URL, and then use the records below to make modifications.
+-- This approach allows http-conduit to add configuration options without
+-- breaking backwards compatibility.
+data Request m = Request
+ { method :: W.Method
+ -- ^ HTTP request method, eg GET, POST.
+ , secure :: Bool
+ -- ^ Whether to use HTTPS (ie, SSL).
+ , checkCerts :: W.Ascii -> [X509] -> IO TLSCertificateUsage
+ -- ^ Check if the server certificate is valid. Only relevant for HTTPS.
+ , host :: W.Ascii
+ , port :: Int
+ , path :: W.Ascii
+ -- ^ Everything from the host to the query string.
+ , queryString :: W.Ascii
+ , requestHeaders :: W.RequestHeaders
+ , requestBody :: RequestBody m
+ , proxy :: Maybe Proxy
+ -- ^ Optional HTTP proxy.
+ , rawBody :: Bool
+ -- ^ If @True@, a chunked and\/or gzipped body will not be
+ -- decoded. Use with caution.
+ , decompress :: ContentType -> Bool
+ -- ^ Predicate to specify whether gzipped data should be
+ -- decompressed on the fly (see 'alwaysDecompress' and
+ -- 'browserDecompress'). Default: browserDecompress.
+ , redirectCount :: Int
+ -- ^ How many redirects to follow when getting a resource. 0 means follow
+ -- no redirects. Default value: 10.
+ , checkStatus :: W.Status -> W.ResponseHeaders -> Maybe SomeException
+ -- ^ Check the status code. Note that this will run after all redirects are
+ -- performed. Default: return a @StatusCodeException@ on non-2XX responses.
+ }
+
+-- | When using one of the
+-- 'RequestBodySource'\/'RequestBodySourceChunked' constructors
+-- and any function which calls 'redirectIter', you must ensure
+-- that the 'Source' can be called multiple times. Usually this
+-- is not a problem.
+--
+-- The 'RequestBodySourceChunked' will send a chunked request
+-- body, note that not all servers support this. Only use
+-- 'RequestBodySourceChunked' if you know the server you're
+-- sending to supports chunked request bodies.
+data RequestBody m
+ = RequestBodyLBS L.ByteString
+ | RequestBodyBS S.ByteString
+ | RequestBodyBuilder Int64 Blaze.Builder
+ | RequestBodySource Int64 (C.Source m Blaze.Builder)
+ | RequestBodySourceChunked (C.Source m Blaze.Builder)
+
+-- | Define a HTTP proxy, consisting of a hostname and port number.
+
+data Proxy = Proxy
+ { proxyHost :: W.Ascii -- ^ The host name of the HTTP proxy.
+ , proxyPort :: Int -- ^ The port number of the HTTP proxy.
+ }
+
+encodeUrlCharPI :: Char -> String
+encodeUrlCharPI '/' = "/"
+encodeUrlCharPI c = encodeUrlChar c
+
+encodeUrlChar :: Char -> String
+encodeUrlChar c
+ -- List of unreserved characters per RFC 3986
+ -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding
+ | 'A' <= c && c <= 'Z' = [c]
+ | 'a' <= c && c <= 'z' = [c]
+ | '0' <= c && c <= '9' = [c]
+encodeUrlChar c@'-' = [c]
+encodeUrlChar c@'_' = [c]
+encodeUrlChar c@'.' = [c]
+encodeUrlChar c@'~' = [c]
+encodeUrlChar y =
+ let (a, c) = fromEnum y `divMod` 16
+ b = a `mod` 16
+ showHex' x
+ | x < 10 = toEnum $ x + (fromEnum '0')
+ | x < 16 = toEnum $ x - 10 + (fromEnum 'A')
+ | otherwise = error $ "Invalid argument to showHex: " ++ show x
+ in ['%', showHex' b, showHex' c]
+
+-- | Convert a URL into a 'Request'.
+--
+-- This defaults some of the values in 'Request', such as setting 'method' to
+-- GET and 'requestHeaders' to @[]@.
+--
+-- Since this function uses 'Failure', the return monad can be anything that is
+-- an instance of 'Failure', such as 'IO' or 'Maybe'.
+parseUrl :: Failure HttpException m => String -> m (Request m')
+parseUrl s@('h':'t':'t':'p':':':'/':'/':rest) = parseUrl1 s False rest
+parseUrl s@('h':'t':'t':'p':'s':':':'/':'/':rest) = parseUrl1 s True rest
+parseUrl x = failure $ InvalidUrlException x "Invalid scheme"
+
+parseUrl1 :: Failure HttpException m
+ => String -> Bool -> String -> m (Request m')
+parseUrl1 full sec s =
+ parseUrl2 full sec s'
+ where
+ s' = encodeString s
+
+defaultCheckCerts :: W.Ascii -> [X509] -> IO TLSCertificateUsage
+defaultCheckCerts host' certs =
+ case certificateVerifyDomain (S8.unpack host') certs of
+ CertificateUsageAccept -> certificateVerifyChain certs
+ _ -> return CertificateUsageAccept
+
+instance Default (Request m) where
+ def = Request
+ { host = "localhost"
+ , port = 80
+ , secure = False
+ , checkCerts = defaultCheckCerts
+ , requestHeaders = []
+ , path = "/"
+ , queryString = S8.empty
+ , requestBody = RequestBodyLBS L.empty
+ , method = "GET"
+ , proxy = Nothing
+ , rawBody = False
+ , decompress = browserDecompress
+ , redirectCount = 10
+ , checkStatus = \s@(W.Status sci _) hs ->
+ if 200 <= sci && sci < 300
+ then Nothing
+ else Just $ toException $ StatusCodeException s hs
+ }
+
+parseUrl2 :: Failure HttpException m
+ => String -> Bool -> String -> m (Request m')
+parseUrl2 full sec s = do
+ port' <- mport
+ return def
+ { host = S8.pack hostname
+ , port = port'
+ , secure = sec
+ , path = S8.pack
+ $ if null path''
+ then "/"
+ else concatMap encodeUrlCharPI path''
+ , queryString = S8.pack qstring
+ }
+ where
+ (beforeSlash, afterSlash) = break (== '/') s
+ (hostname, portStr) = break (== ':') beforeSlash
+ (path', qstring') = break (== '?') afterSlash
+ path'' = path'
+ qstring'' = case qstring' of
+ '?':x -> x
+ _ -> qstring'
+ qstring = takeWhile (/= '#') qstring''
+ mport =
+ case (portStr, sec) of
+ ("", False) -> return 80
+ ("", True) -> return 443
+ (':':rest, _) -> maybe
+ (failure $ InvalidUrlException full "Invalid port")
+ return
+ (readDec rest)
+ x -> error $ "parseUrl1: this should never happen: " ++ show x
+
+data HttpException = StatusCodeException W.Status W.ResponseHeaders
+ | InvalidUrlException String String
+ | TooManyRedirects
+ | HttpParserException String
+ deriving (Show, Typeable)
+instance Exception HttpException
+
+-- | Always decompress a compressed stream.
+alwaysDecompress :: ContentType -> Bool
+alwaysDecompress = const True
+
+-- | Decompress a compressed stream unless the content-type is 'application/x-tar'.
+browserDecompress :: ContentType -> Bool
+browserDecompress = (/= "application/x-tar")
+
+-- | Add a Basic Auth header (with the specified user name and password) to the
+-- given Request. Ignore error handling:
+--
+-- applyBasicAuth "user" "pass" $ fromJust $ parseUrl url
+
+applyBasicAuth :: S.ByteString -> S.ByteString -> Request m -> Request m
+applyBasicAuth user passwd req =
+ req { requestHeaders = authHeader : requestHeaders req }
+ where
+ authHeader = (CI.mk "Authorization", basic)
+ basic = S8.append "Basic " (B64.encode $ S8.concat [ user, ":", passwd ])
+
+
+-- | Add a proxy to the the Request so that the Request when executed will use
+-- the provided proxy.
+addProxy :: S.ByteString -> Int -> Request m -> Request m
+addProxy hst prt req =
+ req { proxy = Just $ Proxy hst prt }
+
+-- FIXME add a helper for generating POST bodies
+
+-- | Add url-encoded paramters to the 'Request'.
+--
+-- This sets a new 'requestBody', adds a content-type request header and
+-- changes the 'method' to POST.
+urlEncodedBody :: Monad m => [(S.ByteString, S.ByteString)] -> Request m' -> Request m
+urlEncodedBody headers req = req
+ { requestBody = RequestBodyLBS body
+ , method = "POST"
+ , requestHeaders =
+ (ct, "application/x-www-form-urlencoded")
+ : filter (\(x, _) -> x /= ct) (requestHeaders req)
+ }
+ where
+ ct = "Content-Type"
+ body = L.fromChunks . return $ W.renderSimpleQuery False headers
+
+needsGunzip :: Request m
+ -> [W.Header] -- ^ response headers
+ -> Bool
+needsGunzip req hs' =
+ not (rawBody req)
+ && ("content-encoding", "gzip") `elem` hs'
+ && decompress req (fromMaybe "" $ lookup "content-type" hs')
+
+requestBuilder
+ :: C.Resource m
+ => Request m
+ -> C.Source m Builder
+requestBuilder req =
+ CL.sourceList [builder] `mappend` bodySource
+ where
+ sourceSingle = CL.sourceList . return
+
+ (contentLength, bodySource) =
+ case requestBody req of
+ RequestBodyLBS lbs -> (Just $ L.length lbs, sourceSingle $ fromLazyByteString lbs)
+ RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, sourceSingle $ fromByteString bs)
+ RequestBodyBuilder i b -> (Just $ i, sourceSingle b)
+ RequestBodySource i source -> (Just i, source)
+ RequestBodySourceChunked source -> (Nothing, source C.$= chunkIt)
+
+ hh
+ | port req == 80 && not (secure req) = host req
+ | port req == 443 && secure req = host req
+ | otherwise = host req <> S8.pack (':' : show (port req))
+
+ contentLengthHeader (Just contentLength') =
+ if method req `elem` ["GET", "HEAD"] && contentLength' == 0
+ then id
+ else (:) ("Content-Length", S8.pack $ show contentLength')
+ contentLengthHeader Nothing = (:) ("Transfer-Encoding", "chunked")
+
+ headerPairs :: W.RequestHeaders
+ headerPairs
+ = ("Host", hh)
+ : ("Accept-Encoding", "gzip")
+ : (contentLengthHeader contentLength)
+ (requestHeaders req)
+
+ builder :: Builder
+ builder =
+ fromByteString (method req)
+ <> fromByteString " "
+ <> (case proxy req of
+ Just{} ->
+ fromByteString (if secure req then "https://" else "http://")
+ <> fromByteString hh
+ Nothing -> mempty)
+ <> (case S8.uncons $ path req of
+ Just ('/', _) -> fromByteString $ path req
+ _ -> fromByteString "/" <> fromByteString (path req))
+ <> (if S8.null (queryString req)
+ then mempty
+ else fromChar '?' <> fromByteString (queryString req))
+ <> fromByteString " HTTP/1.1\r\n"
+ <> foldr
+ (\a b -> headerPairToBuilder a <> b)
+ (fromByteString "\r\n")
+ headerPairs
+
+ headerPairToBuilder (k, v) =
+ fromByteString (CI.original k)
+ <> fromByteString ": "
+ <> fromByteString v
+ <> fromByteString "\r\n"
diff --git a/Network/HTTP/Conduit/Response.hs b/Network/HTTP/Conduit/Response.hs
index 396ccd4..f34405d 100644
--- a/Network/HTTP/Conduit/Response.hs
+++ b/Network/HTTP/Conduit/Response.hs
@@ -1,104 +1,104 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Network.HTTP.Conduit.Response
- ( Response (..)
- , getResponse
- , lbsResponse
- ) where
-
-import Control.Arrow (first)
-import Data.Typeable (Typeable)
-
-import qualified Data.ByteString.Char8 as S8
-import qualified Data.ByteString.Lazy as L
-
-import qualified Data.CaseInsensitive as CI
-
-import Control.Monad.Trans.Resource (ResourceT, ResourceIO)
-import qualified Data.Conduit as C
-import qualified Data.Conduit.Zlib as CZ
-import qualified Data.Conduit.Binary as CB
-import qualified Data.Conduit.List as CL
-
-import qualified Network.HTTP.Types as W
-
-import Network.HTTP.Conduit.Manager
-import Network.HTTP.Conduit.Request
-import Network.HTTP.Conduit.Util
-import Network.HTTP.Conduit.Parser
-import Network.HTTP.Conduit.Chunk
-
--- | A simple representation of the HTTP response created by 'lbsConsumer'.
-data Response body = Response
- { statusCode :: W.Status
- , responseHeaders :: W.ResponseHeaders
- , responseBody :: body
- }
- deriving (Show, Eq, Typeable)
-
--- | Convert a 'Response' that has a 'C.BufferedSource' body to one with a lazy
--- 'L.ByteString' body.
-lbsResponse :: C.Resource m
- => ResourceT m (Response (C.BufferedSource m S8.ByteString))
- -> ResourceT m (Response L.ByteString)
-lbsResponse mres = do
- res <- mres
- bss <- responseBody res C.$$ CL.consume
- return res
- { responseBody = L.fromChunks bss
- }
-
-getResponse :: ResourceIO m
- => ConnRelease m
- -> Request m
- -> C.BufferedSource m S8.ByteString
- -> ResourceT m (Response (C.BufferedSource m S8.ByteString))
-getResponse connRelease req@(Request {..}) bsrc = do
- ((_, sc, sm), hs) <- bsrc C.$$ sinkHeaders
- let s = W.Status sc sm
- let hs' = map (first CI.mk) hs
- let mcl = lookup "content-length" hs' >>= readDec . S8.unpack
-
- -- RFC 2616 section 4.4_1 defines responses that must not include a body
- body <- if hasNoBody method sc || mcl == Just 0
- then do
- -- FIXME clean up socket
- C.bufferSource $ CL.sourceList []
- else do
- bsrc' <-
- if ("transfer-encoding", "chunked") `elem` hs'
- then C.bufferSource $ bsrc C.$= chunkedConduit rawBody
- else
- case mcl of
- Just len -> C.bufferSource $ bsrc C.$= CB.isolate len
- Nothing -> return bsrc
- if needsGunzip req hs'
- then C.bufferSource $ bsrc' C.$= CZ.ungzip
- else return bsrc'
-
- -- should we put this connection back into the connection manager?
- let toPut = Just "close" /= lookup "connection" hs'
- let cleanup = connRelease $ if toPut then Reuse else DontReuse
-
- return $ Response s hs' $ addCleanup cleanup body
-
--- | Add some cleanup code to the given 'C.BufferedSource'. General purpose
--- function, could be included in conduit itself.
-addCleanup :: C.ResourceIO m
- => ResourceT m ()
- -> C.BufferedSource m a
- -> C.BufferedSource m a
-addCleanup cleanup bsrc = C.BufferedSource
- { C.bsourcePull = do
- res <- C.bsourcePull bsrc
- case res of
- C.Closed -> cleanup
- C.Open _ -> return ()
- return res
- , C.bsourceUnpull = C.bsourceUnpull bsrc
- , C.bsourceClose = do
- C.bsourceClose bsrc
- cleanup
- }
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Network.HTTP.Conduit.Response
+ ( Response (..)
+ , getResponse
+ , lbsResponse
+ ) where
+
+import Control.Arrow (first)
+import Data.Typeable (Typeable)
+
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Lazy as L
+
+import qualified Data.CaseInsensitive as CI
+
+import Control.Monad.Trans.Resource (ResourceT, ResourceIO)
+import qualified Data.Conduit as C
+import qualified Data.Conduit.Zlib as CZ
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.List as CL
+
+import qualified Network.HTTP.Types as W
+
+import Network.HTTP.Conduit.Manager
+import Network.HTTP.Conduit.Request
+import Network.HTTP.Conduit.Util
+import Network.HTTP.Conduit.Parser
+import Network.HTTP.Conduit.Chunk
+
+-- | A simple representation of the HTTP response created by 'lbsConsumer'.
+data Response body = Response
+ { statusCode :: W.Status
+ , responseHeaders :: W.ResponseHeaders
+ , responseBody :: body
+ }
+ deriving (Show, Eq, Typeable)
+
+-- | Convert a 'Response' that has a 'C.BufferedSource' body to one with a lazy
+-- 'L.ByteString' body.
+lbsResponse :: C.Resource m
+ => ResourceT m (Response (C.BufferedSource m S8.ByteString))
+ -> ResourceT m (Response L.ByteString)
+lbsResponse mres = do
+ res <- mres
+ bss <- responseBody res C.$$ CL.consume
+ return res
+ { responseBody = L.fromChunks bss
+ }
+
+getResponse :: ResourceIO m
+ => ConnRelease m
+ -> Request m
+ -> C.BufferedSource m S8.ByteString
+ -> ResourceT m (Response (C.BufferedSource m S8.ByteString))
+getResponse connRelease req@(Request {..}) bsrc = do
+ ((_, sc, sm), hs) <- bsrc C.$$ sinkHeaders
+ let s = W.Status sc sm
+ let hs' = map (first CI.mk) hs
+ let mcl = lookup "content-length" hs' >>= readDec . S8.unpack
+
+ -- RFC 2616 section 4.4_1 defines responses that must not include a body
+ body <- if hasNoBody method sc || mcl == Just 0
+ then do
+ -- FIXME clean up socket
+ C.bufferSource $ CL.sourceList []
+ else do
+ bsrc' <-
+ if ("transfer-encoding", "chunked") `elem` hs'
+ then C.bufferSource $ bsrc C.$= chunkedConduit rawBody
+ else
+ case mcl of
+ Just len -> C.bufferSource $ bsrc C.$= CB.isolate len
+ Nothing -> return bsrc
+ if needsGunzip req hs'
+ then C.bufferSource $ bsrc' C.$= CZ.ungzip
+ else return bsrc'
+
+ -- should we put this connection back into the connection manager?
+ let toPut = Just "close" /= lookup "connection" hs'
+ let cleanup = connRelease $ if toPut then Reuse else DontReuse
+
+ return $ Response s hs' $ addCleanup cleanup body
+
+-- | Add some cleanup code to the given 'C.BufferedSource'. General purpose
+-- function, could be included in conduit itself.
+addCleanup :: C.ResourceIO m
+ => ResourceT m ()
+ -> C.BufferedSource m a
+ -> C.BufferedSource m a
+addCleanup cleanup bsrc = C.BufferedSource
+ { C.bsourcePull = do
+ res <- C.bsourcePull bsrc
+ case res of
+ C.Closed -> cleanup
+ C.Open _ -> return ()
+ return res
+ , C.bsourceUnpull = C.bsourceUnpull bsrc
+ , C.bsourceClose = do
+ C.bsourceClose bsrc
+ cleanup
+ }
diff --git a/Network/HTTP/Conduit/Util.hs b/Network/HTTP/Conduit/Util.hs
index eea42b6..b1126b7 100644
--- a/Network/HTTP/Conduit/Util.hs
+++ b/Network/HTTP/Conduit/Util.hs
@@ -1,71 +1,71 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-module Network.HTTP.Conduit.Util
- ( hGetSome
- , (<>)
- , readDec
- , hasNoBody
- ) where
-
-import Data.Monoid (Monoid, mappend)
-
-import qualified Data.ByteString.Char8 as S8
-
-import qualified Data.Text as T
-import qualified Data.Text.Read
-
-#if MIN_VERSION_base(4,3,0)
-import Data.ByteString (hGetSome)
-#else
-import GHC.IO.Handle.Types
-import System.IO (hWaitForInput, hIsEOF)
-import System.IO.Error (mkIOError, illegalOperationErrorType)
-
--- | Like 'hGet', except that a shorter 'ByteString' may be returned
--- if there are not enough bytes immediately available to satisfy the
--- whole request. 'hGetSome' only blocks if there is no data
--- available, and EOF has not yet been reached.
-hGetSome :: Handle -> Int -> IO S.ByteString
-hGetSome hh i
- | i > 0 = let
- loop = do
- s <- S.hGetNonBlocking hh i
- if not (S.null s)
- then return s
- else do eof <- hIsEOF hh
- if eof then return s
- else hWaitForInput hh (-1) >> loop
- -- for this to work correctly, the
- -- Handle should be in binary mode
- -- (see GHC ticket #3808)
- in loop
- | i == 0 = return S.empty
- | otherwise = illegalBufferSize hh "hGetSome" i
-
-illegalBufferSize :: Handle -> String -> Int -> IO a
-illegalBufferSize handle fn sz =
- ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing)
- --TODO: System.IO uses InvalidArgument here, but it's not exported :-(
- where
- msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz []
-#endif
-
-infixr 5 <>
-(<>) :: Monoid m => m -> m -> m
-(<>) = mappend
-
-readDec :: Integral i => String -> Maybe i
-readDec s =
- case Data.Text.Read.decimal $ T.pack s of
- Right (i, t)
- | T.null t -> Just i
- _ -> Nothing
-
-hasNoBody :: S8.ByteString -- ^ request method
- -> Int -- ^ status code
- -> Bool
-hasNoBody "HEAD" _ = True
-hasNoBody _ 204 = True
-hasNoBody _ 304 = True
-hasNoBody _ i = 100 <= i && i < 200
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Network.HTTP.Conduit.Util
+ ( hGetSome
+ , (<>)
+ , readDec
+ , hasNoBody
+ ) where
+
+import Data.Monoid (Monoid, mappend)
+
+import qualified Data.ByteString.Char8 as S8
+
+import qualified Data.Text as T
+import qualified Data.Text.Read
+
+#if MIN_VERSION_base(4,3,0)
+import Data.ByteString (hGetSome)
+#else
+import GHC.IO.Handle.Types
+import System.IO (hWaitForInput, hIsEOF)
+import System.IO.Error (mkIOError, illegalOperationErrorType)
+
+-- | Like 'hGet', except that a shorter 'ByteString' may be returned
+-- if there are not enough bytes immediately available to satisfy the
+-- whole request. 'hGetSome' only blocks if there is no data
+-- available, and EOF has not yet been reached.
+hGetSome :: Handle -> Int -> IO S.ByteString
+hGetSome hh i
+ | i > 0 = let
+ loop = do
+ s <- S.hGetNonBlocking hh i
+ if not (S.null s)
+ then return s
+ else do eof <- hIsEOF hh
+ if eof then return s
+ else hWaitForInput hh (-1) >> loop
+ -- for this to work correctly, the
+ -- Handle should be in binary mode
+ -- (see GHC ticket #3808)
+ in loop
+ | i == 0 = return S.empty
+ | otherwise = illegalBufferSize hh "hGetSome" i
+
+illegalBufferSize :: Handle -> String -> Int -> IO a
+illegalBufferSize handle fn sz =
+ ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing)
+ --TODO: System.IO uses InvalidArgument here, but it's not exported :-(
+ where
+ msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz []
+#endif
+
+infixr 5 <>
+(<>) :: Monoid m => m -> m -> m
+(<>) = mappend
+
+readDec :: Integral i => String -> Maybe i
+readDec s =
+ case Data.Text.Read.decimal $ T.pack s of
+ Right (i, t)
+ | T.null t -> Just i
+ _ -> Nothing
+
+hasNoBody :: S8.ByteString -- ^ request method
+ -> Int -- ^ status code
+ -> Bool
+hasNoBody "HEAD" _ = True
+hasNoBody _ 204 = True
+hasNoBody _ 304 = True
+hasNoBody _ i = 100 <= i && i < 200
diff --git a/Setup.lhs b/Setup.lhs
index 1bc517f..d41083c 100644
--- a/Setup.lhs
+++ b/Setup.lhs
@@ -1,8 +1,8 @@
-#!/usr/bin/env runhaskell
-
-> module Main where
-> import Distribution.Simple
-> import System.Cmd (system)
-
-> main :: IO ()
-> main = defaultMain
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+> import System.Cmd (system)
+
+> main :: IO ()
+> main = defaultMain
diff --git a/http-conduit.cabal b/http-conduit.cabal
index 157e74c..1198dc6 100644
--- a/http-conduit.cabal
+++ b/http-conduit.cabal
@@ -1,62 +1,103 @@
-name: http-conduit
-version: 1.1.0.1
-license: BSD3
-license-file: LICENSE
-author: Michael Snoyman <michael@snoyman.com>
-maintainer: Michael Snoyman <michael@snoyman.com>
-synopsis: HTTP client package with conduit interface and HTTPS support.
-description:
- This package uses attoparsec for parsing the actual contents of the HTTP connection. It also provides higher-level functions which allow you to avoid direct usage of conduits. See <http://www.yesodweb.com/book/http-conduit> for more information.
-category: Web, Conduit
-stability: Stable
-cabal-version: >= 1.6
-build-type: Simple
-homepage: http://www.yesodweb.com/book/http-conduit
-
-flag network-bytestring
- default: False
-
-library
- build-depends: base >= 4 && < 5
- , bytestring >= 0.9.1.4 && < 0.10
- , transformers >= 0.2 && < 0.3
- , failure >= 0.1 && < 0.2
- , conduit >= 0.0 && < 0.1
- , zlib-conduit >= 0.0 && < 0.1
- , blaze-builder-conduit >= 0.0 && < 0.1
- , attoparsec-conduit >= 0.0 && < 0.1
- , attoparsec >= 0.8.0.2 && < 0.11
- , utf8-string >= 0.3.4 && < 0.4
- , blaze-builder >= 0.2.1 && < 0.4
- , http-types >= 0.6 && < 0.7
- , cprng-aes >= 0.2 && < 0.3
- , tls >= 0.8.1 && < 0.9
- , tls-extra >= 0.4 && < 0.5
- , monad-control >= 0.3 && < 0.4
- , containers >= 0.2
- , certificate >= 0.7 && < 1.1
- , case-insensitive >= 0.2
- , base64-bytestring >= 0.1 && < 0.2
- , asn1-data >= 0.5.1 && < 0.7
- , data-default >= 0.3 && < 0.4
- , text
- , transformers-base >= 0.4 && < 0.5
- , lifted-base >= 0.1 && < 0.2
- if flag(network-bytestring)
- build-depends: network >= 2.2.1 && < 2.2.3
- , network-bytestring >= 0.1.3 && < 0.1.4
- else
- build-depends: network >= 2.3 && < 2.4
- exposed-modules: Network.HTTP.Conduit
- other-modules: Network.HTTP.Conduit.Parser
- Network.HTTP.Conduit.ConnInfo
- Network.HTTP.Conduit.Request
- Network.HTTP.Conduit.Util
- Network.HTTP.Conduit.Manager
- Network.HTTP.Conduit.Chunk
- Network.HTTP.Conduit.Response
- ghc-options: -Wall
-
-source-repository head
- type: git
- location: git://github.com/snoyberg/http-conduit.git
+name: http-conduit
+version: 1.1.1
+license: BSD3
+license-file: LICENSE
+author: Michael Snoyman <michael@snoyman.com>
+maintainer: Michael Snoyman <michael@snoyman.com>
+synopsis: HTTP client package with conduit interface and HTTPS support.
+description:
+ This package uses attoparsec for parsing the actual contents of the HTTP connection. It also provides higher-level functions which allow you to avoid direct usage of conduits. See <http://www.yesodweb.com/book/http-conduit> for more information.
+category: Web, Conduit
+stability: Stable
+cabal-version: >= 1.8
+build-type: Simple
+homepage: http://www.yesodweb.com/book/http-conduit
+extra-source-files: test/main.hs
+
+flag network-bytestring
+ default: False
+
+library
+ build-depends: base >= 4 && < 5
+ , bytestring >= 0.9.1.4 && < 0.10
+ , transformers >= 0.2 && < 0.3
+ , failure >= 0.1 && < 0.2
+ , conduit >= 0.0 && < 0.1
+ , zlib-conduit >= 0.0 && < 0.1
+ , blaze-builder-conduit >= 0.0 && < 0.1
+ , attoparsec-conduit >= 0.0 && < 0.1
+ , attoparsec >= 0.8.0.2 && < 0.11
+ , utf8-string >= 0.3.4 && < 0.4
+ , blaze-builder >= 0.2.1 && < 0.4
+ , http-types >= 0.6 && < 0.7
+ , cprng-aes >= 0.2 && < 0.3
+ , tls >= 0.8.1 && < 0.9
+ , tls-extra >= 0.4 && < 0.5
+ , monad-control >= 0.3 && < 0.4
+ , containers >= 0.2
+ , certificate >= 0.7 && < 1.1
+ , case-insensitive >= 0.2
+ , base64-bytestring >= 0.1 && < 0.2
+ , asn1-data >= 0.5.1 && < 0.7
+ , data-default >= 0.3 && < 0.4
+ , text
+ , transformers-base >= 0.4 && < 0.5
+ , lifted-base >= 0.1 && < 0.2
+ , time
+ if flag(network-bytestring)
+ build-depends: network >= 2.2.1 && < 2.2.3
+ , network-bytestring >= 0.1.3 && < 0.1.4
+ else
+ build-depends: network >= 2.3 && < 2.4
+ exposed-modules: Network.HTTP.Conduit
+ other-modules: Network.HTTP.Conduit.Parser
+ Network.HTTP.Conduit.ConnInfo
+ Network.HTTP.Conduit.Request
+ Network.HTTP.Conduit.Util
+ Network.HTTP.Conduit.Manager
+ Network.HTTP.Conduit.Chunk
+ Network.HTTP.Conduit.Response
+ ghc-options: -Wall
+
+test-suite test
+ main-is: test/main.hs
+ type: exitcode-stdio-1.0
+
+ ghc-options: -Wall
+ cpp-options: -DDEBUG
+ build-depends: base >= 4 && < 5
+ , HUnit
+ , hspec
+ , bytestring
+ , transformers
+ , failure
+ , conduit
+ , zlib-conduit
+ , blaze-builder-conduit
+ , attoparsec-conduit
+ , attoparsec
+ , utf8-string
+ , blaze-builder
+ , http-types
+ , cprng-aes
+ , tls
+ , tls-extra
+ , monad-control
+ , containers
+ , certificate
+ , case-insensitive
+ , base64-bytestring
+ , asn1-data
+ , data-default
+ , text
+ , transformers-base
+ , lifted-base
+ , time
+ , network
+ , wai
+ , warp
+ , http-types
+
+source-repository head
+ type: git
+ location: git://github.com/snoyberg/http-conduit.git
diff --git a/test/main.hs b/test/main.hs
new file mode 100644
index 0000000..3562685
--- /dev/null
+++ b/test/main.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+import Test.Hspec.Monadic
+import Test.Hspec.HUnit ()
+import Test.HUnit
+import Network.Wai
+import Network.Wai.Handler.Warp (run)
+import Network.HTTP.Conduit
+import Control.Concurrent (forkIO, killThread)
+import Network.HTTP.Types
+import Control.Exception (try, SomeException)
+import Network.HTTP.Conduit.ConnInfo
+
+app :: Application
+app req =
+ case pathInfo req of
+ [] -> return $ responseLBS status200 [] "homepage"
+ _ -> return $ responseLBS status404 [] "not found"
+
+main :: IO ()
+main = hspecX $ do
+ describe "simpleHttp" $ do
+ it "gets homepage" $ do
+ tid <- forkIO $ run 3000 app
+ lbs <- simpleHttp "http://localhost:3000/"
+ killThread tid
+ lbs @?= "homepage"
+ it "throws exception on 404" $ do
+ tid <- forkIO $ run 3001 app
+ elbs <- try $ simpleHttp "http://localhost:3001/404"
+ killThread tid
+ case elbs of
+ Left (_ :: SomeException) -> return ()
+ Right _ -> error "Expected an exception"
+ describe "manager" $ do
+ it "closes all connections" $ do
+ clearSocketsList
+ tid1 <- forkIO $ run 3002 app
+ tid2 <- forkIO $ run 3003 app
+ withManager $ \manager -> do
+ let Just req1 = parseUrl "http://localhost:3002/"
+ let Just req2 = parseUrl "http://localhost:3003/"
+ _res1a <- http req1 manager
+ _res1b <- http req1 manager
+ _res2 <- http req2 manager
+ return ()
+ requireAllSocketsClosed
+ killThread tid2
+ killThread tid1