summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--LICENSE25
-rw-r--r--Network/HTTP/Conduit.hs256
-rw-r--r--Network/HTTP/Conduit/Chunk.hs82
-rw-r--r--Network/HTTP/Conduit/ConnInfo.hs109
-rw-r--r--Network/HTTP/Conduit/Manager.hs188
-rw-r--r--Network/HTTP/Conduit/Parser.hs149
-rw-r--r--Network/HTTP/Conduit/Request.hs334
-rw-r--r--Network/HTTP/Conduit/Response.hs94
-rw-r--r--Network/HTTP/Conduit/Util.hs72
-rw-r--r--Setup.lhs8
-rw-r--r--http-conduit.cabal73
-rw-r--r--test.hs36
12 files changed, 1426 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..8643e5d
--- /dev/null
+++ b/LICENSE
@@ -0,0 +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.
diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs
new file mode 100644
index 0000000..ae6f0ba
--- /dev/null
+++ b/Network/HTTP/Conduit.hs
@@ -0,0 +1,256 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+-- | 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. By using 'httpRedirect', it will automatically
+-- follow 3xx redirects.
+--
+-- > import Data.Conduit.Binary (sinkFile)
+-- > import Network.HTTP.Conduit
+-- > import System.IO
+-- >
+-- > main :: IO ()
+-- > main = do
+-- > request <- parseUrl "http://google.com/"
+-- > withManager $ \manager -> do
+-- > let handler _ _ bsrc = bsrc C.$$ sinkFile "google.html"
+-- > run_ $ httpRedirect request handler manager
+--
+-- 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
+ , httpLbsRedirect
+ , http
+ , httpRedirect
+ , redirectConsumer
+ -- * Datatypes
+ , Proxy (..)
+ , RequestBody (..)
+ , Response (..)
+ , ResponseConsumer
+ -- ** Request
+ , Request
+ , def
+ , method
+ , secure
+ , checkCerts
+ , host
+ , port
+ , path
+ , queryString
+ , requestHeaders
+ , requestBody
+ , proxy
+ , rawBody
+ , decompress
+ -- *** Defaults
+ , defaultCheckCerts
+ -- * Manager
+ , Manager
+ , newManager
+ , withManager
+ -- * Utility functions
+ , parseUrl
+ , applyBasicAuth
+ , addProxy
+ , lbsConsumer
+ -- * Decompression predicates
+ , alwaysDecompress
+ , browserDecompress
+ -- * Request bodies
+ , urlEncodedBody
+ -- * Exceptions
+ , HttpException (..)
+ ) 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 qualified Data.Conduit as C
+import Data.Conduit.Blaze (builderToByteString)
+import Control.Monad.Trans.Resource (ResourceT, runResourceT, ResourceIO)
+
+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 how the response should be handled. It's a
+-- function that takes two arguments: the first is the HTTP status code of the
+-- response, and the second is a list of all response headers. This module
+-- exports 'lbsConsumer', which generates a 'Response' value.
+--
+-- Note that this allows you to have fully interleaved IO actions during your
+-- HTTP download, making it possible to download very large responses in
+-- constant memory.
+http
+ :: ResourceIO m
+ => Request m
+ -> ResponseConsumer m a
+ -> Manager
+ -> ResourceT m a
+http req consumer m = withConn req m $ \ci -> do
+ bsrc <- C.bufferSource $ connSource ci
+ requestBuilder req C.$$ builderToByteString C.=$ connSink ci
+ getResponse req consumer 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 = http lbsConsumer@
+--
+-- Please see 'lbsConsumer' for more information on how the 'Response' value is
+-- created.
+--
+-- Even though a '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 write your own
+-- iteratee and use 'http' or 'httpRedirect' directly.
+httpLbs :: ResourceIO m => Request m -> Manager -> ResourceT m Response
+httpLbs req = http req lbsConsumer
+
+-- | 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. 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 write your own
+-- iteratee and use 'http' or 'httpRedirect' directly.
+simpleHttp :: ResourceIO m => String -> m L.ByteString
+simpleHttp url = runResourceT $ do
+ url' <- liftBase $ parseUrl url
+ man <- newManager
+ Response sc _ b <- httpLbsRedirect url'
+ { decompress = browserDecompress
+ } man
+ if 200 <= sc && sc < 300
+ then return b
+ else liftBase $ throwIO $ StatusCodeException sc b
+
+-- | Same as 'http', but follows all 3xx redirect status codes that contain a
+-- location header.
+httpRedirect
+ :: ResourceIO m
+ => Request m
+ -> (W.Status -> W.ResponseHeaders -> C.BufferedSource m S.ByteString -> ResourceT m a)
+ -> Manager
+ -> ResourceT m a
+httpRedirect req bodyStep manager =
+ http req (redirectConsumer 10 req bodyStep manager) manager
+
+-- | Download the specified 'Request', returning the results as a 'Response'
+-- and automatically handling redirects.
+--
+-- This is a simplified version of 'httpRedirect' 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 'httpRedirect' directly. This function is defined as:
+--
+-- @httpLbsRedirect = httpRedirect lbsConsumer@
+--
+-- Please see 'lbsConsumer' for more information on how the 'Response' value is
+-- created.
+--
+-- Even though a '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 write your own
+-- iteratee and use 'http' or 'httpRedirect' directly.
+httpLbsRedirect :: ResourceIO m => Request m -> Manager -> ResourceT m Response
+httpLbsRedirect req m = httpRedirect req lbsConsumer m
+
+-- | Make a request automatically follow 3xx redirects.
+--
+-- Used internally by 'httpRedirect' and family.
+redirectConsumer :: ResourceIO m
+ => Int -- ^ number of redirects to attempt
+ -> Request m -- ^ Original request
+ -> ResponseConsumer m a
+ -> Manager
+ -> ResponseConsumer m a
+redirectConsumer redirects req bodyStep manager s@(W.Status code _) hs bsrc
+ | 300 <= code && code < 400 =
+ case lookup "location" hs of
+ 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 =
+ if code == 303
+ then "GET"
+ else method l
+ }
+ if redirects == 0
+ then liftBase $ throwIO TooManyRedirects
+ else (http req') (redirectConsumer (redirects - 1) req' bodyStep manager) manager
+ Nothing -> bodyStep s hs bsrc
+ | otherwise = bodyStep s hs bsrc
diff --git a/Network/HTTP/Conduit/Chunk.hs b/Network/HTTP/Conduit/Chunk.hs
new file mode 100644
index 0000000..0e0638c
--- /dev/null
+++ b/Network/HTTP/Conduit/Chunk.hs
@@ -0,0 +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]
+ }
diff --git a/Network/HTTP/Conduit/ConnInfo.hs b/Network/HTTP/Conduit/ConnInfo.hs
new file mode 100644
index 0000000..f6343f0
--- /dev/null
+++ b/Network/HTTP/Conduit/ConnInfo.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module Network.HTTP.Conduit.ConnInfo
+ ( ConnInfo
+ , connClose
+ , connSink
+ , connSource
+ , sslClientConn
+ , socketConn
+ , TLSCertificateRejectReason(..)
+ , TLSCertificateUsage(..)
+ , getSocket
+ ) 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
+
+
+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 ()
+ }
+
+socketConn :: Socket -> ConnInfo
+socketConn sock = ConnInfo
+ { connRead = recv sock 4096
+ , connWrite = sendAll sock
+ , connClose = sClose sock
+ }
+
+sslClientConn :: ([X509] -> IO TLSCertificateUsage) -> Handle -> IO ConnInfo
+sslClientConn onCerts h = do
+ 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 = 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
new file mode 100644
index 0000000..3564cb7
--- /dev/null
+++ b/Network/HTTP/Conduit/Manager.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Network.HTTP.Conduit.Manager
+ ( Manager
+ , ConnKey (..)
+ , newManager
+ , withConn
+ , WithConnResponse (..)
+ , ConnReuse (..)
+ , UseConn
+ , withManager
+ ) 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, try, throwIO, SomeException)
+import Control.Monad.Trans.Resource (ResourceT, runResourceT, ResourceIO, withIO)
+
+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
+
+type UseConn m a = ConnInfo -> ResourceT m (WithConnResponse a)
+
+withSocketConn
+ :: ResourceIO m
+ => Manager
+ -> String
+ -> Int
+ -> UseConn m a
+ -> ResourceT m a
+withSocketConn man host' port' =
+ withManagedConn man (ConnKey (T.pack host') port' False) $
+ fmap socketConn $ getSocket host' port'
+
+withSslConn :: ResourceIO m
+ => ([X509] -> IO TLSCertificateUsage)
+ -> Manager
+ -> String -- ^ host
+ -> Int -- ^ port
+ -> UseConn m a
+ -> ResourceT m a
+withSslConn checkCert man host' port' =
+ withManagedConn man (ConnKey (T.pack host') port' True) $
+ (connectTo host' (PortNumber $ fromIntegral port') >>= sslClientConn checkCert)
+
+withSslProxyConn
+ :: ResourceIO m
+ => ([X509] -> IO TLSCertificateUsage)
+ -> S8.ByteString -- ^ Target host
+ -> Int -- ^ Target port
+ -> Manager
+ -> String -- ^ Proxy host
+ -> Int -- ^ Proxy port
+ -> UseConn m a
+ -> ResourceT m a
+withSslProxyConn checkCert thost tport man phost pport =
+ withManagedConn man (ConnKey (T.pack phost) pport True) $
+ doConnect >>= sslClientConn checkCert
+ where
+ 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
+
+withManagedConn
+ :: ResourceIO m
+ => Manager
+ -> ConnKey
+ -> IO ConnInfo
+ -> UseConn m a
+ -> ResourceT m a
+withManagedConn man key open f = mask $ \restore -> do
+ mci <- liftBase $ takeSocket man key
+ (ci, isManaged) <-
+ case mci of
+ Nothing -> do
+ ci <- restore $ liftBase open
+ return (ci, False)
+ Just ci -> return (ci, True)
+ ea <- try $ restore $ f ci
+ case ea of
+ Left e -> do
+ liftBase $ connClose ci
+ if isManaged
+ then restore $ withManagedConn man key open f
+ else throwIO (e :: SomeException)
+ Right (WithConnResponse cr a) -> do
+ case cr of
+ Reuse -> liftBase $ putSocket man key ci
+ DontReuse -> liftBase $ connClose ci
+ return a
+
+data WithConnResponse a = WithConnResponse !ConnReuse !a
+
+data ConnReuse = Reuse | DontReuse
+
+withConn :: ResourceIO m
+ => Request m
+ -> Manager
+ -> UseConn m a
+ -> ResourceT m a
+withConn 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, _) -> withSocketConn
+ (True, False) -> withSslConn $ checkCerts req h
+ (True, True) -> withSslProxyConn (checkCerts req h) h (port req)
diff --git a/Network/HTTP/Conduit/Parser.hs b/Network/HTTP/Conduit/Parser.hs
new file mode 100644
index 0000000..0187832
--- /dev/null
+++ b/Network/HTTP/Conduit/Parser.hs
@@ -0,0 +1,149 @@
+{-# 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
+
+{-
+sinkParserTill :: Monad m
+ => Parser a
+ -> Parser end
+ -> E.Enumeratee a S.ByteString m b
+sinkParserTill p pend =
+ E.continue $ step $ parse p
+ where
+ step parse (E.Chunks xs) = parseLoop parse xs
+ step parse E.EOF = case parse S.empty of
+ Done extra a -> E.yield a $ if S.null extra
+ then E.Chunks []
+ else E.Chunks [extra]
+ Partial _ -> err [] "sinkParser: divergent parser"
+ Fail _ ctx msg -> err ctx msg
+
+ parseLoop parse [] = E.continue (step parse)
+ parseLoop parse (x:xs) = case parse x of
+ Done extra a -> E.yield a $ if S.null extra
+ then E.Chunks xs
+ else E.Chunks (extra:xs)
+ Partial parse' -> parseLoop parse' xs
+ Fail _ ctx msg -> err ctx msg
+
+ err ctx msg = E.throwError (ParseError ctx msg)
+-}
diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs
new file mode 100644
index 0000000..558ffe7
--- /dev/null
+++ b/Network/HTTP/Conduit/Request.hs
@@ -0,0 +1,334 @@
+{-# 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)
+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').
+ }
+
+-- | 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 = alwaysDecompress
+ }
+
+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 Int L.ByteString
+ | 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
new file mode 100644
index 0000000..a3ac2f0
--- /dev/null
+++ b/Network/HTTP/Conduit/Response.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Network.HTTP.Conduit.Response
+ ( lbsConsumer
+ , Response (..)
+ , ResponseConsumer
+ , getResponse
+ ) where
+
+import Control.Arrow (first)
+import Data.Typeable (Typeable)
+
+import qualified Data.ByteString as S
+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
+
+
+-- | Convert the HTTP response into a 'Response' value.
+--
+-- Even though a '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 write your own
+-- iteratee and use 'http' or 'httpRedirect' directly.
+lbsConsumer :: ResourceIO m => ResponseConsumer m Response
+lbsConsumer (W.Status sc _) hs bsrc = do
+ lbs <- fmap L.fromChunks $ bsrc C.$$ CL.consume
+ return $ Response sc hs lbs
+
+-- | A simple representation of the HTTP response created by 'lbsConsumer'.
+data Response = Response
+ { statusCode :: Int
+ , responseHeaders :: W.ResponseHeaders
+ , responseBody :: L.ByteString
+ }
+ deriving (Show, Read, Eq, Typeable)
+
+type ResponseConsumer m a
+ = W.Status
+ -> W.ResponseHeaders
+ -> C.BufferedSource m S.ByteString
+ -> ResourceT m a
+
+getResponse :: ResourceIO m
+ => Request m
+ -> ResponseConsumer m a
+ -> C.BufferedSource m S8.ByteString
+ -> ResourceT m (WithConnResponse a)
+getResponse req@(Request {..}) bodyStep 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'
+ -- RFC 2616 section 4.4_1 defines responses that must not include a body
+ res <- if hasNoBody method sc
+ then do
+ bsrcNull <- C.bufferSource $ CL.sourceList []
+ bodyStep s hs' bsrcNull
+ else do
+ bsrc' <-
+ if ("transfer-encoding", "chunked") `elem` hs'
+ then C.bufferSource $ bsrc C.$= chunkedConduit rawBody
+ else
+ case mcl >>= readDec . S8.unpack of
+ Just len -> C.bufferSource $ bsrc C.$= CB.isolate len
+ Nothing -> return bsrc
+ bsrc'' <-
+ if needsGunzip req hs'
+ then C.bufferSource $ bsrc' C.$= CZ.ungzip
+ else return bsrc'
+ bodyStep s hs' bsrc''
+ -- FIXME this is causing hangs, need to look into it bsrc C.$$ CL.sinkNull
+ -- Most likely just need to flush the actual buffer
+
+ -- should we put this connection back into the connection manager?
+ let toPut = Just "close" /= lookup "connection" hs'
+ return $ WithConnResponse (if toPut then Reuse else DontReuse) res
diff --git a/Network/HTTP/Conduit/Util.hs b/Network/HTTP/Conduit/Util.hs
new file mode 100644
index 0000000..7043f37
--- /dev/null
+++ b/Network/HTTP/Conduit/Util.hs
@@ -0,0 +1,72 @@
+{-# 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 1
+-- FIXME 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
new file mode 100644
index 0000000..1bc517f
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,8 @@
+#!/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
new file mode 100644
index 0000000..dde6e21
--- /dev/null
+++ b/http-conduit.cabal
@@ -0,0 +1,73 @@
+name: http-conduit
+version: 1.0.0
+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.
+category: Web, Conduit
+stability: Stable
+cabal-version: >= 1.6
+build-type: Simple
+homepage: http://github.com/snoyberg/http-enumerator
+
+flag test
+ description: Build the test executable.
+ default: False
+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
+ , zlib-enum >= 0.2 && < 0.3
+ , 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
+
+executable http-conduit
+ main-is: test.hs
+ if flag(test)
+ Buildable: True
+ else
+ Buildable: False
+
+source-repository head
+ type: git
+ location: git://github.com/snoyberg/http-enumerator.git
diff --git a/test.hs b/test.hs
new file mode 100644
index 0000000..3019a10
--- /dev/null
+++ b/test.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+import Network.HTTP.Conduit
+import Network
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import System.Environment.UTF8 (getArgs)
+import Data.CaseInsensitive (original)
+import Data.Conduit
+
+main :: IO ()
+main = withSocketsDo $ do
+ [url] <- getArgs
+ _req2 <- parseUrl url
+ {-
+ let req = urlEncodedBody
+ [ ("foo", "bar")
+ , ("baz%%38**.8fn", "bin")
+ ] _req2
+ -}
+ runResourceT $ do
+ man <- newManager
+ Response sc hs b <- httpLbsRedirect _req2 man
+#if DEBUG
+ return ()
+#else
+ liftBase $ do
+ print sc
+ mapM_ (\(x, y) -> do
+ S.putStr $ original x
+ putStr ": "
+ S.putStr y
+ putStrLn "") hs
+ putStrLn ""
+ L.putStr b
+#endif