diff --git a/Network/HTTP/Enumerator.hs b/Network/HTTP/Enumerator.hs --- a/Network/HTTP/Enumerator.hs +++ b/Network/HTTP/Enumerator.hs @@ -3,10 +3,10 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} --- | This module contains everything you need to initiate HTTP connections. --- Make sure to wrap your code with 'withHttpEnumerator'. 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: +-- | 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.Enumerator @@ -18,13 +18,15 @@ -- constant memory space. By using 'httpRedirect', it will automatically -- follow 3xx redirects. -- +-- > import Data.Enumerator +-- > import Data.Enumerator.Binary -- > import Network.HTTP.Enumerator --- > import Data.Enumerator.IO -- > import System.IO --- > +-- > +-- > main :: IO () -- > main = withFile "google.html" WriteMode $ \handle -> do -- > request <- parseUrl "http://google.com/" --- > httpRedirect (\_ _ -> iterHandle handle) request +-- > run_ $ httpRedirect request (\_ _ -> iterHandle handle) -- -- The following headers are automatically set by this module, and should not -- be added to 'requestHeaders': @@ -35,21 +37,17 @@ -- -- * Accept-Encoding (not currently set, but client usage of this variable /will/ cause breakage). -- --- One last thing: there are two different backends available for the HTTPS --- support: the OpenSSL library and the tls package. The former requires some --- initialization, while the latter does not. Therefore, this module exports a --- 'withHttpEnumerator' function to provide necessary initialization. --- Additionally, 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 those two functions at --- some point. The best approach is to simply call them at the beginning of --- your main function, such as: +-- 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.Enumerator -- > import qualified Data.ByteString.Lazy as L -- > import Network (withSocketsDo) -- > --- > main = withSocketsDo . withHttpEnumerator +-- > main = withSocketsDo -- > $ simpleHttp "http://www.haskell.org/" >>= L.putStr module Network.HTTP.Enumerator ( -- * Perform a request @@ -57,15 +55,18 @@ , httpLbs , httpLbsRedirect , http - , streamingHttp , httpRedirect + , redirectIter -- * Datatypes , Request (..) , Response (..) - , Headers + -- * Manager + , Manager + , newManager + , closeManager + , withManager -- * Utility functions , parseUrl - , withHttpEnumerator , lbsIter -- * Request bodies , urlEncodedBody @@ -73,155 +74,132 @@ , HttpException (..) ) where -#if OPENSSL -import OpenSSL -import qualified OpenSSL.Session as SSL -#else -import System.IO (hClose, hSetBuffering, BufferMode (NoBuffering)) import qualified Network.TLS.Client.Enumerator as TLS import Network (connectTo, PortID (PortNumber)) -#endif import qualified Network.Socket as NS -import qualified Network.Socket.ByteString as B import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Data.Enumerator - ( Iteratee (..), Stream (..), catchError, throwError, consume + ( Iteratee (..), Stream (..), catchError, throwError , yield, Step (..), Enumeratee, ($$), joinI, Enumerator, run_ - , continue, returnI, (>==>) + , returnI, (>==>) ) -import qualified Data.Enumerator as E +import qualified Data.Enumerator.List as EL import Network.HTTP.Enumerator.HttpParser -import Network.HTTP.Enumerator.Zlib (ungzip) -import Control.Exception (Exception) -import Control.Arrow (first) +import Control.Exception (Exception, bracket) +import Control.Arrow ((***)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (lift) import Control.Failure import Data.Typeable (Typeable) -import Data.Data (Data) -import Data.Word (Word8) import Data.Bits -import Data.Maybe (fromMaybe) -import Data.ByteString.Lazy.Internal (defaultChunkSize) import Codec.Binary.UTF8.String (encodeString) import qualified Blaze.ByteString.Builder as Blaze import Blaze.ByteString.Builder.Enumerator (builderToByteString) -import qualified Blaze.ByteString.Builder.Internal.Write as Blaze import Data.Monoid (Monoid (..)) -import qualified Network.Wai as W +import qualified Network.HTTP.Types as W +import qualified Data.CaseInsensitive as CI import Data.Int (Int64) - --- | The OpenSSL library requires some initialization of variables to be used, --- and therefore you must call 'withOpenSSL' before using any of its functions. --- As this library uses OpenSSL, you must use 'withOpenSSL' as well. (As a side --- note, you'll also want to use the withSocketsDo function for network --- activity.) --- --- To future-proof this package against switching to different SSL libraries, --- we re-export 'withOpenSSL' under this name. You can call this function as --- early as you like; in fact, simply wrapping the do block of your main --- function is probably best. -withHttpEnumerator :: IO a -> IO a -#if OPENSSL -withHttpEnumerator = withOpenSSL -#else -withHttpEnumerator = id -#endif +import qualified Codec.Zlib +import qualified Codec.Zlib.Enum as Z +import Control.Monad.IO.Control (MonadControlIO, liftIOOp) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.IORef as I +import Control.Applicative ((<$>)) +import Data.Certificate.X509 (X509) +import qualified Data.Ascii as A getSocket :: String -> Int -> IO NS.Socket getSocket host' port' = do - addrs <- NS.getAddrInfo Nothing (Just host') (Just $ show port') - let addr = head addrs - sock <- NS.socket (NS.addrFamily addr) NS.Stream NS.defaultProtocol + 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) NS.connect sock (NS.addrAddress addr) return sock withSocketConn :: MonadIO m - => String + => Manager + -> String -> Int -> Enumerator Blaze.Builder m () -> Enumerator S.ByteString m a -withSocketConn host' port' req step0 = do - sock <- liftIO $ getSocket host' port' - lift $ run_ $ req $$ joinI $ builderToByteString $$ writeToIter $ B.sendAll sock - a <- readToEnum (B.recv sock defaultChunkSize) step0 - liftIO $ NS.sClose sock - return a - - -writeToIter :: MonadIO m - => (S.ByteString -> IO b) -> Iteratee S.ByteString m () -writeToIter write = - continue go - where - go EOF = return () - go (Chunks bss) = do - liftIO $ mapM_ write bss - continue go +withSocketConn man host' port' = + withManagedConn man (host', port', False) $ + fmap TLS.socketConn $ getSocket host' port' -readToEnum :: MonadIO m => IO S.ByteString -> Enumerator S.ByteString m b -readToEnum read' (Continue k) = do - bs <- liftIO read' - if S.null bs - then continue k - else do - step <- lift $ runIteratee $ k $ Chunks [bs] - readToEnum read' step -readToEnum _ step = returnI step +withManagedConn + :: MonadIO m + => Manager + -> ConnKey + -> IO TLS.ConnInfo + -> Enumerator Blaze.Builder m () + -> Enumerator S.ByteString m a +withManagedConn man key open req step = do + ci <- liftIO $ takeInsecureSocket man key + >>= maybe (liftIO open) return + a <- withCI ci req step + liftIO $ putInsecureSocket man key ci + return a withSslConn :: MonadIO m - => String -- ^ host + => ([X509] -> IO Bool) + -> Manager + -> String -- ^ host -> Int -- ^ port -> Enumerator Blaze.Builder m () -- ^ request -> Enumerator S.ByteString m a -- ^ response -withSslConn host' port' req step0 = do +withSslConn checkCert man host' port' = + withManagedConn man (host', port', True) $ + (connectTo host' (PortNumber $ fromIntegral port') >>= TLS.sslClientConn checkCert) -#if OPENSSL - ctx <- liftIO $ SSL.context - sock <- liftIO $ getSocket host' port' - ssl <- liftIO $ SSL.connection ctx sock - liftIO $ SSL.connect ssl - lift $ run_ $ req $$ writeToIter $ SSL.write ssl - a <- readToEnum (SSL.read ssl defaultChunkSize) step0 - liftIO $ SSL.shutdown ssl SSL.Unidirectional - liftIO $ NS.sClose sock - return a -#else - handle <- liftIO $ connectTo host' (PortNumber $ fromIntegral port') - liftIO $ hSetBuffering handle NoBuffering - a <- TLS.clientEnumSimple handle req step0 - liftIO $ hClose handle +withCI :: MonadIO m => TLS.ConnInfo -> Enumerator Blaze.Builder m () -> Enumerator S.ByteString m a +withCI ci req step0 = do + lift $ run_ $ req $$ joinI $ builderToByteString $$ TLS.connIter ci + a <- TLS.connEnum ci step0 + -- FIXME liftIO $ hClose handle return a -#endif -- | 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'. -data Request = Request - { method :: S.ByteString -- ^ HTTP request method, eg GET, POST. +data Request m = Request + { method :: W.Method -- ^ HTTP request method, eg GET, POST. , secure :: Bool -- ^ Whether to use HTTPS (ie, SSL). - , host :: S.ByteString + , checkCerts :: [X509] -> IO Bool -- ^ Check if the server certificate is valid. Only relevant for HTTPS. + , host :: A.Ascii , port :: Int - , path :: S.ByteString -- ^ Everything from the host to the query string. - , queryString :: [(S.ByteString, S.ByteString)] -- ^ Automatically escaped for your convenience. - , requestHeaders :: Headers - , requestBody :: L.ByteString + , path :: A.Ascii -- ^ Everything from the host to the query string. + , queryString :: W.Query -- ^ Automatically escaped for your convenience. + , requestHeaders :: W.RequestHeaders + , requestBody :: RequestBody m } - deriving (Show, Read, Eq, Typeable, Data) +-- | When using the 'RequestBodyEnum' constructor and any function which calls +-- 'redirectIter', you must ensure that the 'Enumerator' can be called multiple +-- times. +data RequestBody m + = RequestBodyLBS L.ByteString + | RequestBodyEnum Int64 (Enumerator Blaze.Builder m ()) + -- | A simple representation of the HTTP response created by 'lbsIter'. data Response = Response { statusCode :: Int - , responseHeaders :: Headers + , responseHeaders :: W.ResponseHeaders , responseBody :: L.ByteString } - deriving (Show, Read, Eq, Typeable, Data) + deriving (Show, Read, Eq, Typeable) -type Headers = [(W.ResponseHeader, S.ByteString)] +enumSingle :: Monad m => a -> Enumerator a m b +enumSingle x (Continue k) = k $ Chunks [x] +enumSingle _ step = returnI step -- | The most low-level function for initiating an HTTP request. -- @@ -237,73 +215,62 @@ -- 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 :: MonadIO m - => Request - -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) - -> Iteratee S.ByteString m a -http req bodyStep = - streamingHttp req reqBody bodyStep - where - reqBody = (L.length $ requestBody req, toEnum $ requestBody req) - toEnum = enumSingle . Blaze.fromLazyByteString - -enumSingle x (Continue k) = k $ Chunks [x] -enumSingle _ step = returnI step - --- | Same as 'http', but allows you to specify a ('Int64', 'Enumerator') pair --- for the request body. Note: this function ignores the 'requestBody' record --- in the 'Request' argument. -streamingHttp +http :: MonadIO m - => Request - -> (Int64, Enumerator Blaze.Builder m ()) + => Request m -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) + -> Manager -> Iteratee S.ByteString m a -streamingHttp Request {..} (contentLength, bodyEnum) bodyStep = do - let h' = S8.unpack host - let withConn = if secure then withSslConn else withSocketConn - withConn h' port requestEnum $$ go +http Request {..} bodyStep m = do + let h' = A.toString host + let withConn = if secure then withSslConn checkCerts else withSocketConn + withConn m h' port requestEnum $$ go where + (contentLength, bodyEnum) = + case requestBody of + RequestBodyLBS lbs -> (L.length lbs, enumSingle $ Blaze.fromLazyByteString lbs) + RequestBodyEnum i enum -> (i, enum) hh | port == 80 && not secure = host | port == 443 && secure = host - | otherwise = host `S.append` S8.pack (':' : show port) + | otherwise = host `mappend` A.unsafeFromString (':' : show port) headers' = ("Host", hh) - : ("Content-Length", S8.pack $ show contentLength) + : ("Content-Length", A.unsafeFromString $ show contentLength) : ("Accept-Encoding", "gzip") : requestHeaders - requestHeaders' = mconcat - [ Blaze.fromByteString method - , Blaze.fromByteString " " - , Blaze.fromByteString $ - case S8.uncons path of - Just ('/', _) -> path - _ -> S8.cons '/' path - , renderQS queryString - , Blaze.fromByteString " HTTP/1.1\r\n" - , mconcat $ flip map headers' $ \(k, v) -> mconcat - [ Blaze.fromByteString $ W.ciOriginal k - , Blaze.fromByteString ": " - , Blaze.fromByteString v - , Blaze.fromByteString "\r\n" - ] - , Blaze.fromByteString "\r\n" - ] + requestHeaders' = + Blaze.fromByteString (A.toByteString method) + `mappend` Blaze.fromByteString " " + `mappend` + (case S8.uncons $ A.toByteString path of + Just ('/', _) -> Blaze.fromByteString $ A.toByteString path + _ -> Blaze.fromByteString "/" + `mappend` Blaze.fromByteString (A.toByteString path)) + `mappend` (if null queryString + then mempty + else A.toBuilder $ W.renderQueryBuilder True queryString) + `mappend` Blaze.fromByteString " HTTP/1.1\r\n" + `mappend` mconcat (flip map headers' $ \(k, v) -> + Blaze.fromByteString (A.toByteString $ CI.original k) + `mappend` Blaze.fromByteString ": " + `mappend` Blaze.fromByteString (A.toByteString v) + `mappend` Blaze.fromByteString "\r\n") + `mappend` Blaze.fromByteString "\r\n" requestEnum = enumSingle requestHeaders' >==> bodyEnum go = do - ((_, sc, sm), hs) <- catchParser "HTTP headers" iterHeaders - let s = W.Status sc sm - let hs' = map (first W.mkCIByteString) hs + ((_, sc, sm), hs) <- iterHeaders + let s = W.Status sc $ A.unsafeFromByteString sm + let hs' = map (CI.mk . A.unsafeFromByteString *** A.unsafeFromByteString) hs let mcl = lookup "content-length" hs' let body' x = if ("transfer-encoding", "chunked") `elem` hs' then joinI $ chunkedEnumeratee $$ x - else case mcl >>= readMay . S8.unpack of + else case mcl >>= readMay . A.toString of Just len -> joinI $ takeLBS len $$ x Nothing -> x let decompress x = if ("content-encoding", "gzip") `elem` hs' - then joinI $ ungzip x + then joinI $ Z.decompress (Codec.Zlib.WindowBits 31) x else returnI x if method == "HEAD" then bodyStep s hs' @@ -323,7 +290,7 @@ takeLBS :: MonadIO m => Int -> Enumeratee S.ByteString S.ByteString m a takeLBS 0 step = return step takeLBS len (Continue k) = do - mbs <- E.head + mbs <- EL.head case mbs of Nothing -> return $ Continue k Just bs -> do @@ -340,20 +307,6 @@ else takeLBS len' step' takeLBS _ step = return step -renderQS :: [(S.ByteString, S.ByteString)] -> Blaze.Builder -renderQS [] = mempty -renderQS (p:ps) = mconcat - $ go "?" p - : map (go "&") ps - where - go sep (k, v) = mconcat - [ Blaze.fromByteString sep - , Blaze.fromByteString $ escape k - , Blaze.fromByteString "=" - , Blaze.fromByteString $ escape v - ] - escape = S8.concatMap (S8.pack . encodeUrlChar) - encodeUrlCharPI :: Char -> String encodeUrlCharPI '/' = "/" encodeUrlCharPI c = encodeUrlChar c @@ -386,32 +339,37 @@ -- -- 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 -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" +parseUrl :: Failure HttpException m => A.Ascii -> m (Request m') +parseUrl = parseUrlS . A.toString +parseUrlS :: Failure HttpException m => String -> m (Request m') +parseUrlS s@('h':'t':'t':'p':':':'/':'/':rest) = parseUrl1 s False rest +parseUrlS s@('h':'t':'t':'p':'s':':':'/':'/':rest) = parseUrl1 s True rest +parseUrlS x = failure $ InvalidUrlException x "Invalid scheme" + parseUrl1 :: Failure HttpException m - => String -> Bool -> String -> m Request + => String -> Bool -> String -> m (Request m') parseUrl1 full sec s = parseUrl2 full sec s' where s' = encodeString s parseUrl2 :: Failure HttpException m - => String -> Bool -> String -> m Request + => String -> Bool -> String -> m (Request m') parseUrl2 full sec s = do port' <- mport return Request - { host = S8.pack hostname + { host = A.unsafeFromString hostname , port = port' , secure = sec + , checkCerts = const $ return True , requestHeaders = [] - , path = S8.pack $ if null path' + , path = A.unsafeFromString + $ if null path' then "/" else concatMap encodeUrlCharPI path' - , queryString = parseQueryString $ S8.pack qstring - , requestBody = L.empty + , queryString = W.parseQuery $ S8.pack qstring + , requestBody = RequestBodyLBS L.empty , method = "GET" } where @@ -432,53 +390,6 @@ Nothing -> failure $ InvalidUrlException full "Invalid port" x -> error $ "parseUrl1: this should never happen: " ++ show x -parseQueryString :: S.ByteString -> [(S.ByteString, S.ByteString)] -parseQueryString = parseQueryString' . dropQuestion - where - dropQuestion q | S.null q || S.head q /= 63 = q - dropQuestion q | otherwise = S.tail q - parseQueryString' q | S.null q = [] - parseQueryString' q = - let (x, xs) = breakDiscard 38 q -- ampersand - in parsePair x : parseQueryString' xs - where - parsePair x = - let (k, v) = breakDiscard 61 x -- equal sign - in (qsDecode k, qsDecode v) - - -qsDecode :: S.ByteString -> S.ByteString -qsDecode z = fst $ S.unfoldrN (S.length z) go z - where - go bs = - case uncons bs of - Nothing -> Nothing - Just (43, ws) -> Just (32, ws) -- plus to space - Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent - (x, xs) <- uncons ws - x' <- hexVal x - (y, ys) <- uncons xs - y' <- hexVal y - Just $ (combine x' y', ys) - Just (w, ws) -> Just (w, ws) - hexVal w - | 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9 - | 65 <= w && w <= 70 = Just $ w - 55 -- A - F - | 97 <= w && w <= 102 = Just $ w - 87 -- a - f - | otherwise = Nothing - combine :: Word8 -> Word8 -> Word8 - combine a b = shiftL a 4 .|. b - -uncons :: S.ByteString -> Maybe (Word8, S.ByteString) -uncons s - | S.null s = Nothing - | otherwise = Just (S.head s, S.tail s) - -breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) -breakDiscard w s = - let (x, y) = S.break (== w) s - in (x, S.drop 1 y) - -- | Convert the HTTP response into a 'Response' value. -- -- Even though a 'Response' contains a lazy bytestring, this function does @@ -488,7 +399,7 @@ lbsIter :: Monad m => W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m Response lbsIter (W.Status sc _) hs = do - lbs <- fmap L.fromChunks consume + lbs <- fmap L.fromChunks EL.consume return $ Response sc hs lbs -- | Download the specified 'Request', returning the results as a 'Response'. @@ -502,8 +413,8 @@ -- -- Please see 'lbsIter' for more information on how the 'Response' value is -- created. -httpLbs :: MonadIO m => Request -> m Response -httpLbs req = run_ $ http req $ lbsIter +httpLbs :: MonadIO m => Request m -> Manager -> m Response +httpLbs req = run_ . http req lbsIter -- | Download the specified URL, following any redirects, and return the -- response body. @@ -511,10 +422,10 @@ -- This function will 'failure' an 'HttpException' for any response with a -- non-2xx status code. It uses 'parseUrl' to parse the input. This function -- essentially wraps 'httpLbsRedirect'. -simpleHttp :: (MonadIO m, Failure HttpException m) => String -> m L.ByteString +simpleHttp :: (MonadControlIO m, Failure HttpException m) => A.Ascii -> m L.ByteString simpleHttp url = do url' <- parseUrl url - Response sc _ b <- httpLbsRedirect url' + Response sc _ b <- withManager $ httpLbsRedirect url' if 200 <= sc && sc < 300 then return b else failure $ StatusCodeException sc b @@ -530,43 +441,57 @@ -- location header. httpRedirect :: (MonadIO m, Failure HttpException m) - => Request + => Request m -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) + -> Manager -> Iteratee S.ByteString m a -httpRedirect req bodyStep = - http req $ iter' (10 :: Int) - where - iter' redirects s@(W.Status code _) hs - | 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 <- lift $ parseUrl l' - let req' = req - { host = host l - , port = port l - , secure = secure l - , path = path l - , queryString = queryString l - } - if redirects == 0 - then lift $ failure TooManyRedirects - else (http req') $ (iter' $ redirects - 1) - Nothing -> bodyStep s hs - | otherwise = bodyStep s hs +httpRedirect req bodyStep manager = + http req (redirectIter 10 req bodyStep manager) manager +-- | Make a request automatically follow 3xx redirects. +-- +-- Used internally by 'httpRedirect' and family. +redirectIter :: (MonadIO m, Failure HttpException m) + => Int -- ^ number of redirects to attempt + -> Request m -- ^ Original request + -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) + -> Manager + -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) +redirectIter redirects req bodyStep manager s@(W.Status code _) hs + | 300 <= code && code < 400 = + case fmap A.toByteString $ 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 "" + , "://" + , A.toString $ host req + , ":" + , show $ port req + , S8.unpack l'' + ] + _ -> S8.unpack l'' + l <- lift $ parseUrlS 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 lift $ failure TooManyRedirects + else (http req') (redirectIter (redirects - 1) req' bodyStep manager) manager + Nothing -> bodyStep s hs + | otherwise = bodyStep s hs + -- | Download the specified 'Request', returning the results as a 'Response' -- and automatically handling redirects. -- @@ -579,21 +504,23 @@ -- -- Please see 'lbsIter' for more information on how the 'Response' value is -- created. -httpLbsRedirect :: (MonadIO m, Failure HttpException m) => Request -> m Response -httpLbsRedirect req = run_ $ httpRedirect req $ lbsIter +httpLbsRedirect :: (MonadIO m, Failure HttpException m) => Request m -> Manager -> m Response +httpLbsRedirect req = run_ . httpRedirect req lbsIter readMay :: Read a => String -> Maybe a readMay s = case reads s of [] -> Nothing (x, _):_ -> Just x +-- 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 :: [(S.ByteString, S.ByteString)] -> Request -> Request +urlEncodedBody :: Monad m => [(S.ByteString, S.ByteString)] -> Request m' -> Request m urlEncodedBody headers req = req - { requestBody = body + { requestBody = RequestBodyLBS body , method = "POST" , requestHeaders = (ct, "application/x-www-form-urlencoded") @@ -632,3 +559,38 @@ catchParser :: Monad m => String -> Iteratee a m b -> Iteratee a m b catchParser s i = catchError i (const $ throwError $ HttpParserException s) + +-- | Keeps track of open connections for keep-alive. +data Manager = Manager + { mConns :: I.IORef (Map ConnKey TLS.ConnInfo) + } + +type ConnKey = (String, Int, Bool) + +takeInsecureSocket :: Manager -> ConnKey -> IO (Maybe TLS.ConnInfo) +takeInsecureSocket man key = + I.atomicModifyIORef (mConns man) go + where + go m = (Map.delete key m, Map.lookup key m) + +putInsecureSocket :: Manager -> ConnKey -> TLS.ConnInfo -> IO () +putInsecureSocket man key ci = do + msock <- I.atomicModifyIORef (mConns man) go + maybe (return ()) TLS.connClose msock + where + go m = (Map.insert key ci m, Map.lookup key m) + +-- | Create a new 'Manager' with no open connection. +newManager :: IO Manager +newManager = Manager <$> I.newIORef Map.empty + +-- | 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_ TLS.connClose $ Map.elems m + +-- | Create a new 'Manager', call the supplied function and then close it. +withManager :: MonadControlIO m => (Manager -> m a) -> m a +withManager = liftIOOp $ bracket newManager closeManager diff --git a/Network/HTTP/Enumerator/Zlib.hs b/Network/HTTP/Enumerator/Zlib.hs deleted file mode 100644 --- a/Network/HTTP/Enumerator/Zlib.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Network.HTTP.Enumerator.Zlib - ( ungzip - ) where - -import Prelude hiding (head) -import Data.Enumerator -import qualified Data.ByteString as S -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Class (lift) -import Codec.Zlib - -ungzip :: MonadIO m => Enumeratee S.ByteString S.ByteString m b -ungzip inner = do - fzstr <- liftIO $ initInflate $ WindowBits 31 - ungzip' fzstr inner - -ungzip' :: MonadIO m => Inflate -> Enumeratee S.ByteString S.ByteString m b -ungzip' fzstr (Continue k) = do - x <- head - case x of - Nothing -> do - chunk <- liftIO $ finishInflate fzstr - lift $ runIteratee $ k $ Chunks [chunk] - Just bs -> do - chunks <- liftIO $ withInflateInput fzstr bs $ go id - step <- lift $ runIteratee $ k $ Chunks chunks - ungzip' fzstr step - where - go front pop = do - x <- pop - case x of - Nothing -> return $ front [] - Just y -> go (front . (:) y) pop -ungzip' _ step = return step diff --git a/Network/TLS/Client/Enumerator.hs b/Network/TLS/Client/Enumerator.hs --- a/Network/TLS/Client/Enumerator.hs +++ b/Network/TLS/Client/Enumerator.hs @@ -1,53 +1,78 @@ module Network.TLS.Client.Enumerator - ( clientEnumSimple - , clientEnum + ( ConnInfo + , connClose + , connIter + , connEnum + , sslClientConn + , socketConn ) where -import qualified Data.ByteString as B +import Data.ByteString (ByteString) +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import qualified Data.Enumerator as E -import Data.Enumerator (($$), joinI) -import qualified Control.Monad.IO.Class as Trans +import System.IO (Handle, hClose) +import Network.Socket (Socket, sClose) +import Network.Socket.ByteString (recv, sendAll) +import Network.TLS +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (lift) -import Blaze.ByteString.Builder (Builder) -import Blaze.ByteString.Builder.Enumerator (builderToByteString) - -import Network.TLS.Client -import Network.TLS.SRandom -import Network.TLS.Struct -import Network.TLS.Cipher +import Data.Enumerator + ( Iteratee (..), Enumerator, Step (..), Stream (..), continue, returnI + ) +import Data.Certificate.X509 (X509) -import Control.Monad.State (runStateT) +data ConnInfo = ConnInfo + { connRead :: IO [ByteString] + , connWrite :: [ByteString] -> IO () + , connClose :: IO () + } -import Data.IORef -import System.IO (Handle) +connIter :: MonadIO m => ConnInfo -> Iteratee ByteString m () +connIter ConnInfo { connWrite = write } = + continue go + where + go EOF = return () + go (Chunks bss) = do + liftIO $ write bss + continue go -type IState = IORef TLSStateClient +connEnum :: MonadIO m => ConnInfo -> Enumerator ByteString m b +connEnum ConnInfo { connRead = read' } = + go + where + go (Continue k) = do + bs <- liftIO read' + if all S.null bs + then continue k + else do + step <- lift $ runIteratee $ k $ Chunks bs + go step + go step = returnI step -newIState :: TLSClientParams -> SRandomGen -> IO IState -newIState params rng = do - ((), tsc) <- runTLSClient (return ()) params rng - newIORef tsc +socketConn :: Socket -> ConnInfo +socketConn sock = ConnInfo + { connRead = fmap return $ recv sock 4096 + , connWrite = mapM_ (sendAll sock) + , connClose = sClose sock + } -clientEnumSimple - :: Trans.MonadIO m - => Handle - -> E.Enumerator Builder m () -- ^ request - -> E.Enumerator B.ByteString m a -- ^ response -clientEnumSimple h req step = do - let clientstate = TLSClientParams - { cpConnectVersion = TLS10 - , cpAllowedVersions = [ TLS10, TLS11 ] - , cpSession = Nothing - , cpCiphers = ciphers - , cpCertificate = Nothing - , cpCallbacks = TLSClientCallbacks - { cbCertificates = Nothing - } +sslClientConn :: ([X509] -> IO Bool) -> Handle -> IO ConnInfo +sslClientConn onCerts h = do + let tcp = defaultParams + { pConnectVersion = TLS10 + , pAllowedVersions = [ TLS10, TLS11 ] + , pCiphers = ciphers + , onCertificatesRecv = onCerts } - esrand <- Trans.liftIO makeSRandomGen - let srand = either (error . show) id esrand - clientEnum clientstate srand h req step + esrand <- liftIO makeSRandomGen + let srg = either (error . show) id esrand + istate <- liftIO $ client tcp srg h + liftIO $ handshake istate + return ConnInfo + { connRead = liftIO $ fmap L.toChunks $ recvData istate + , connWrite = liftIO . sendData istate . L.fromChunks + , connClose = liftIO $ bye istate >> hClose h + } where ciphers = [ cipher_AES128_SHA1 @@ -55,38 +80,3 @@ , cipher_RC4_128_MD5 , cipher_RC4_128_SHA1 ] - -clientEnum :: Trans.MonadIO m - => TLSClientParams -> SRandomGen -> Handle - -> E.Enumerator Builder m () - -> E.Enumerator B.ByteString m a -clientEnum tcp srg h req step0 = do - istate <- Trans.liftIO $ newIState tcp srg - tlsHelper istate $ connect h - lift $ E.run_ $ req $$ joinI $ builderToByteString $$ iter istate - res <- enum istate step0 - tlsHelper istate $ close h - return res - where - iter :: Trans.MonadIO m => IState -> E.Iteratee B.ByteString m () - iter istate = - E.continue go - where - go E.EOF = return () - go (E.Chunks xs) = do - tlsHelper istate $ sendData h $ L.fromChunks xs - E.continue go - enum :: Trans.MonadIO m => IState -> E.Enumerator B.ByteString m a - enum istate (E.Continue k) = E.Iteratee $ do - lbs <- tlsHelper istate $ recvData h - let chunks = E.Chunks $ L.toChunks lbs - step <- E.runIteratee $ k chunks - E.runIteratee $ enum istate step - enum _ step = E.returnI step - -tlsHelper :: Trans.MonadIO m => IState -> TLSClient IO a -> m a -tlsHelper istate (TLSClient client) = do - state <- Trans.liftIO $ readIORef istate - (ret, state') <- Trans.liftIO $ runStateT client state - Trans.liftIO $ writeIORef istate state' - return ret diff --git a/http-enumerator.cabal b/http-enumerator.cabal --- a/http-enumerator.cabal +++ b/http-enumerator.cabal @@ -1,5 +1,5 @@ name: http-enumerator -version: 0.3.1 +version: 0.4.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -13,9 +13,6 @@ build-type: Simple homepage: http://github.com/snoyberg/http-enumerator -flag openssl - description: Build using the HSOpenSSL library. - default: False flag test description: Build the test executable. default: False @@ -26,30 +23,29 @@ , bytestring >= 0.9.1.4 && < 0.10 , transformers >= 0.2 && < 0.3 , failure >= 0.1 && < 0.2 - , enumerator >= 0.4.1 && < 0.5 + , enumerator >= 0.4.7 && < 0.5 , attoparsec >= 0.8.0.2 && < 0.9 , attoparsec-enumerator >= 0.2 && < 0.3 , utf8-string >= 0.3.4 && < 0.4 , blaze-builder >= 0.2.1 && < 0.3 - , zlib-bindings >= 0.0.0 && < 0.1 - , wai >= 0.3 && < 0.4 + , zlib-bindings >= 0.0 && < 0.1 + , zlib-enum >= 0.1 && < 0.2 + , http-types >= 0.5 && < 0.6 , blaze-builder-enumerator >= 0.2 && < 0.3 + , tls >= 0.4 && < 0.5 + , monad-control >= 0.2 && < 0.3 + , containers >= 0.2 && < 0.5 + , certificate >= 0.7 && < 0.8 + , case-insensitive >= 0.2 && < 0.3 + , ascii >= 0.0.2 && < 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 - if flag(openssl) - build-depends: HsOpenSSL >= 0.8 && < 0.9 - cpp-options: -DOPENSSL - else - build-depends: tls >= 0.3 && < 0.4 - , mtl >= 1.1 && < 2.1 exposed-modules: Network.HTTP.Enumerator other-modules: Network.HTTP.Enumerator.HttpParser - Network.HTTP.Enumerator.Zlib - if ! flag(openssl) - other-modules: Network.TLS.Client.Enumerator + Network.TLS.Client.Enumerator ghc-options: -Wall executable http-enumerator diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -6,24 +6,28 @@ import qualified Data.ByteString.Lazy as L import System.Environment.UTF8 (getArgs) import Network.Wai (ciOriginal) +import qualified Data.Ascii as A main :: IO () -main = withSocketsDo $ withHttpEnumerator $ do - [url] <- getArgs - _req2 <- parseUrl url +main = withSocketsDo $ do + [urlS] <- getArgs + urlA <- maybe (error "Invalid ASCII sequence") return $ A.fromChars urlS + _req2 <- parseUrl urlA + {- let req = urlEncodedBody [ ("foo", "bar") , ("baz%%38**.8fn", "bin") ] _req2 - Response sc hs b <- httpLbsRedirect _req2 + -} + Response sc hs b <- withManager $ httpLbsRedirect _req2 #if DEBUG return () #else print sc mapM_ (\(x, y) -> do - S.putStr $ ciOriginal x + S.putStr $ A.ciToByteString x putStr ": " - S.putStr y + S.putStr $ A.toByteString y putStrLn "") hs putStrLn "" L.putStr b