http-enumerator 0.3.1 → 0.4.0

raw patch · 5 files changed

+325/−407 lines, 5 filesdep +asciidep +case-insensitivedep +certificatedep −HsOpenSSLdep −mtldep −waidep ~enumeratordep ~tlsdep ~zlib-bindingsPVP ok

version bump matches the API change (PVP)

Dependencies added: ascii, case-insensitive, certificate, containers, http-types, monad-control, zlib-enum

Dependencies removed: HsOpenSSL, mtl, wai

Dependency ranges changed: enumerator, tls, zlib-bindings

API changes (from Hackage documentation)

Files

• Network/HTTP/Enumerator.hs +239/−277
• Network/HTTP/Enumerator/Zlib.hs +0/−34
• Network/TLS/Client/Enumerator.hs +64/−74
• http-enumerator.cabal +12/−16
• test.hs +10/−6

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

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

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

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

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