http-enumerator 0.0.1 → 0.1.0

raw patch · 4 files changed

+356/−118 lines, 4 filesdep +utf8-stringPVP ok

version bump matches the API change (PVP)

Dependencies added: utf8-string

API changes (from Hackage documentation)

Files

• Network/HTTP/Enumerator.hs +332/−99
• Network/HTTP/Enumerator/HttpParser.hs +15/−3
• http-enumerator.cabal +2/−1
• test.hs +7/−15

@@ -3,14 +3,46 @@ {-# 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:+--+-- > -- Just download an HTML document and print it.+-- > import Network.HTTP.Enumerator+-- > 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 Network.HTTP.Enumerator+-- > import Data.Enumerator.IO+-- > import System.IO+-- >+-- > main = withFile "google.html" WriteMode $ \handle -> do+-- >     request <- parseUrl "http://google.com/"+-- >     httpRedirect (\_ _ -> iterHandle handle) request module Network.HTTP.Enumerator-    ( Request (..)-    , Response (..)+    ( -- * Perform a request+      simpleHttp+    , httpLbs+    , httpLbsRedirect     , http+    , httpRedirect+      -- * Datatypes+    , Request (..)+    , Response (..)+    , Headers+      -- * Utility functions     , parseUrl-    , httpLbs-    , simpleHttp     , withHttpEnumerator+    , lbsIter+      -- * Exceptions+    , InvalidUrlException (..)+    , HttpException (..)     ) where  #if OPENSSL@@ -41,12 +73,16 @@ import Control.Arrow (first) import Data.Char (toLower) import Control.Monad (forM_)-import Control.Monad.IO.Class (liftIO)+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)  -- | The OpenSSL library requires some initialization of variables to be used, -- and therefore you must call 'withOpenSSL' before using any of its functions.@@ -73,38 +109,38 @@     connect sock (addrAddress addr)     return sock -withSocketConn :: String -> Int -> (HttpConn -> IO a) -> IO a+withSocketConn :: MonadIO m => String -> Int -> (HttpConn -> m a) -> m a withSocketConn host' port' f = do-    sock <- getSocket host' port'+    sock <- liftIO $ getSocket host' port'     a <- f HttpConn         { hcRead = B.recv sock         , hcWrite = B.sendAll sock         }-    sClose sock+    liftIO $ sClose sock     return a -withSslConn :: String -> Int -> (HttpConn -> IO a) -> IO a+withSslConn :: MonadIO m => String -> Int -> (HttpConn -> m a) -> m a withSslConn host' port' f = do  #if OPENSSL-    ctx <- SSL.context-    sock <- getSocket host' port'-    ssl <- SSL.connection ctx sock-    SSL.connect ssl+    ctx <- liftIO $ SSL.context+    sock <- liftIO $ getSocket host' port'+    ssl <- liftIO $ SSL.connection ctx sock+    liftIO $ SSL.connect ssl     a <- f HttpConn         { hcRead = SSL.read ssl         , hcWrite = SSL.write ssl         }-    SSL.shutdown ssl SSL.Unidirectional+    liftIO $ SSL.shutdown ssl SSL.Unidirectional     return a #else-    ranByte <- S.head <$> AESRand.randBytes 1-    _ <- AESRand.randBytes (fromIntegral ranByte)-    Just clientRandom <- TLS.clientRandom . S.unpack <$> AESRand.randBytes 32-    premasterRandom <- (TLS.ClientKeyData . S.unpack) <$> AESRand.randBytes 46-    seqInit <- conv . S.unpack <$> AESRand.randBytes 4-    handle <- connectTo host' (PortNumber $ fromIntegral port')-    hSetBuffering handle NoBuffering+    ranByte <- liftIO $ S.head <$> AESRand.randBytes 1+    _ <- liftIO $ AESRand.randBytes (fromIntegral ranByte)+    Just clientRandom <- liftIO $ TLS.clientRandom . S.unpack <$> AESRand.randBytes 32+    premasterRandom <- liftIO $ (TLS.ClientKeyData . S.unpack) <$> AESRand.randBytes 46+    seqInit <- liftIO $ conv . S.unpack <$> AESRand.randBytes 4+    handle <- liftIO $ connectTo host' (PortNumber $ fromIntegral port')+    liftIO $ hSetBuffering handle NoBuffering     let params = TLS.TLSClientParams             TLS.TLS10             [TLS.TLS10]@@ -117,34 +153,32 @@             Nothing             (TLS.TLSClientCallbacks Nothing) -    (a, _) <- TLS.runTLSClient (do+    ((), state) <- liftIO $ TLS.runTLSClient (do         TLS.connect handle clientRandom premasterRandom-        state <- TLS.TLSClient MTL.get-        istate <- TLS.TLSClient $ MTL.liftIO $ newIORef state-        a <- TLS.TLSClient $ MTL.liftIO $ f HttpConn-            { hcRead = \_len -> do-                state1 <- readIORef istate-                (a, state2) <--                    flip MTL.runStateT state1-                  $ TLS.runTLSC-                  $ TLS.recvData handle-                writeIORef istate state2-                return $ S.concat $ L.toChunks a-            , hcWrite = \bs -> do-                state1 <- readIORef istate-                state2 <--                    flip MTL.execStateT state1-                  $ TLS.runTLSC-                  $ TLS.sendData handle-                  $ L.fromChunks [bs]-                writeIORef istate state2-            }-        state' <- TLS.TLSClient $ MTL.liftIO $ readIORef istate-        TLS.TLSClient $ MTL.put state'-        TLS.close handle-        return a         ) params $ TLS.makeSRandomGen seqInit-    hClose handle+    istate <- liftIO $ newIORef state+    a <- f HttpConn+        { hcRead = \_len -> do+            state1 <- readIORef istate+            (a, state2) <-+                flip MTL.runStateT state1+              $ TLS.runTLSC+              $ TLS.recvData handle+            writeIORef istate state2+            return $ S.concat $ L.toChunks a+        , hcWrite = \bs -> do+            state1 <- readIORef istate+            state2 <-+                flip MTL.execStateT state1+              $ TLS.runTLSC+              $ TLS.sendData handle+              $ L.fromChunks [bs]+            writeIORef istate state2+        }+    state' <- liftIO $ readIORef istate+    _state'' <- liftIO $ flip MTL.execStateT state'+              $ TLS.runTLSC $ TLS.close handle+    liftIO $ hClose handle     return a  conv :: [Word8] -> Int@@ -158,42 +192,73 @@     , hcWrite :: S.ByteString -> IO ()     } -connToEnum :: HttpConn -> Enumerator S.ByteString IO a+connToEnum :: MonadIO m => HttpConn -> Enumerator S.ByteString m a connToEnum (HttpConn r _) =     Iteratee . loop   where     loop (Continue k) = do-        bs <- r 2 -- FIXME better size+#if DEBUG+        bs <- r 5+        liftIO $ putStrLn $ "connToEnum: read 2 bytes: " ++ show bs+#else+        bs <- liftIO $ r defaultChunkSize+#endif         if S.null bs             then return $ Continue k             else do                 runIteratee (k $ Chunks [bs]) >>= loop     loop step = return step +-- | 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-    { host :: S.ByteString+    { method :: S.ByteString -- ^ HTTP request method, eg GET, POST.+    , secure :: Bool -- ^ Whether to use HTTPS (ie, SSL).+    , host :: S.ByteString     , port :: Int-    , secure :: Bool-    , requestHeaders :: [(S.ByteString, S.ByteString)]-    , path :: S.ByteString-    , queryString :: [(S.ByteString, S.ByteString)]+    , path :: S.ByteString -- ^ Everything from the host to the query string.+    , queryString :: Headers -- ^ Automatically escaped for your convenience.+    , requestHeaders :: Headers     , requestBody :: L.ByteString-    , method :: S.ByteString     }-    deriving Show+    deriving (Show, Read, Eq, Typeable, Data) -data Response a = Response+-- | A simple representation of the HTTP response created by 'lbsIter'.+data Response = Response     { statusCode :: Int-    , responseHeaders :: [(S.ByteString, S.ByteString)]-    , responseBody :: a+    , responseHeaders :: Headers+    , responseBody :: L.ByteString     }+    deriving (Show, Read, Eq, Typeable, Data) -http :: Request -> Iteratee S.ByteString IO a -> IO (Response a)-http Request {..} bodyIter = do+type Headers = [(S.ByteString, S.ByteString)]++-- | The most low-level function for initiating an HTTP request.+--+-- The second 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 first 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 'lbsIter', 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 :: MonadIO m+     => (Int -> Headers -> Iteratee S.ByteString m a)+     -> Request+     -> m a+http bodyIter Request {..} = do     let h' = S8.unpack host-    res <- (if secure then withSslConn else withSocketConn) h' port go+    let withConn = if secure then withSslConn else withSocketConn+    res <- withConn h' port go     case res of-        Left e -> throwIO e+        Left e -> liftIO $ throwIO e         Right x -> return x   where     hh@@ -201,53 +266,84 @@         | port == 443 && secure = host         | otherwise = host `S.append` S8.pack (':' : show port)     go hc = do-        hcWrite hc $ S.concat+        liftIO $ hcWrite hc $ S.concat             $ method             : " "-            : path-            : renderQS queryString [" HTTP/1.1\r\n"]+            : (case S8.uncons path of+                Just ('/', _) -> (:) path+                _ -> ((:) "/") . ((:) path))+            (renderQS queryString [" HTTP/1.1\r\n"])         let headers' = ("Host", hh)                      : ("Content-Length", S8.pack $ show                                                   $ L.length requestBody)                      : requestHeaders-        forM_ headers' $ \(k, v) -> hcWrite hc $ S.concat+        liftIO $ forM_ headers' $ \(k, v) -> hcWrite hc $ S.concat             [ k             , ": "             , v             , "\r\n"             ]-        hcWrite hc "\r\n"-        mapM_ (hcWrite hc) $ L.toChunks requestBody+        liftIO $ hcWrite hc "\r\n"+        liftIO $ mapM_ (hcWrite hc) $ L.toChunks requestBody         run $ connToEnum hc $$ do             ((_, sc, _), hs) <- iterHeaders             let hs' = map (first $ S8.map toLower) hs             let mcl = lookup "content-length" hs'-            body' <--                if ("transfer-encoding", "chunked") `elem` hs'-                    then iterChunks-                    else case mcl >>= readMay . S8.unpack of-                        Just len -> takeLBS len-                        Nothing -> return [] -- FIXME read in body anyways?-            ebody'' <- liftIO $ run $ enumList 1 body' $$ bodyIter-            case ebody'' of+            let body' =+                    if ("transfer-encoding", "chunked") `elem` hs'+                        then iterChunks'+                        else case mcl >>= readMay . S8.unpack of+                            Just len -> takeLBS len+                            Nothing -> E.map id+            bodyStep <- lift $ runIteratee $ bodyIter sc hs+            bodyStep' <- body' bodyStep+            eres <- lift $ run $ Iteratee $ return bodyStep'+            case eres of                 Left err -> liftIO $ throwIO err-                Right body'' ->-                    return $ Response-                        { statusCode = sc-                        , responseHeaders = hs-                        , responseBody = body''-                        }+                Right res -> return res -takeLBS :: Monad m => Int -> Iteratee S.ByteString m [S.ByteString]-takeLBS 0 = return []-takeLBS len = do+iterChunks' :: MonadIO m => Enumeratee S.ByteString S.ByteString m a+iterChunks' k@(Continue _) = do+#if DEBUG+    liftIO $ putStrLn "iterChunkHeader start"+#endif+    len <- iterChunkHeader+#if DEBUG+    liftIO $ putStrLn $ "iterChunkHeader stop: " ++ show len+#endif+    if len == 0+        then return k+        else do+            k' <- takeLBS len k+#if DEBUG+            liftIO $ putStrLn "iterNewline start"+#endif+            iterNewline+#if DEBUG+            liftIO $ putStrLn "iterNewline stop"+#endif+            iterChunks' k'+iterChunks' step = return step++takeLBS :: MonadIO m => Int -> Enumeratee S.ByteString S.ByteString m a+takeLBS 0 step = return step+takeLBS len (Continue k) = do     mbs <- E.head     case mbs of-        Nothing -> return []+        Nothing -> return $ Continue k         Just bs -> do-            let len' = len - S.length bs-            rest <- takeLBS len'-            return $ bs : rest+            let (len', chunk, rest) =+                    if S.length bs > len+                        then (0, S.take len bs,+                                if S.length bs == len+                                    then Chunks []+                                    else Chunks [S.drop len bs])+                        else (len - S.length bs, bs, Chunks [])+            step' <- lift $ runIteratee $ k $ Chunks [chunk]+            if len' == 0+                then yield step' rest+                else takeLBS len' step'+takeLBS _ step = return step  renderQS :: [(S.ByteString, S.ByteString)]          -> [S.ByteString]@@ -259,6 +355,10 @@     go sep (k, v) = [sep, escape k, "=", escape v]     escape = S8.concatMap (S8.pack . encodeUrlChar) +encodeUrlCharPI :: Char -> String+encodeUrlCharPI '/' = "/"+encodeUrlCharPI c = encodeUrlChar c+ encodeUrlChar :: Char -> String encodeUrlChar c     -- List of unreserved characters per RFC 3986@@ -274,16 +374,27 @@ encodeUrlChar y =     let (a, c) = fromEnum y `divMod` 16         b = a `mod` 16-        showHex' x -- FIXME just use Numeric version?+        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] +-- | Thrown by 'parseUrl' when a URL could not be parsed correctly.+--+-- 'httpRedirect' also uses the 'parseUrl' function to read the location header+-- from a server, so it can also throw this exception. data InvalidUrlException = InvalidUrlException String String     deriving (Show, Typeable) instance Exception InvalidUrlException +-- | 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 InvalidUrlException 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@@ -291,15 +402,24 @@  parseUrl1 :: Failure InvalidUrlException m           => String -> Bool -> String -> m Request-parseUrl1 full sec s = do+parseUrl1 full sec s =+    parseUrl2 full sec s'+  where+    s' = encodeString s++parseUrl2 :: Failure InvalidUrlException m+          => String -> Bool -> String -> m Request+parseUrl2 full sec s = do     port' <- mport     return Request-        { host = S8.pack hostname -- FIXME check chars+        { host = S8.pack hostname         , port = port'         , secure = sec         , requestHeaders = []-        , path = S8.pack $ if null path' then "/" else path' -- FIXME check chars-        , queryString = parseQueryString $ S8.pack qstring -- FIXME check chars+        , path = S8.pack $ if null path'+                            then "/"+                            else concatMap encodeUrlCharPI path'+        , queryString = parseQueryString $ S8.pack qstring         , requestBody = L.empty         , method = "GET"         }@@ -368,11 +488,124 @@     let (x, y) = S.break (== w) s      in (x, S.drop 1 y) -httpLbs :: Request -> IO (Response L.ByteString)-httpLbs = flip http (L.fromChunks `fmap` consume)+-- | 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.+lbsIter :: Monad m => Int -> Headers -> Iteratee S.ByteString m Response+lbsIter sc hs = do+#if DEBUG+    b <- fmap L.fromChunks consume'+#else+    b <- fmap L.fromChunks consume+#endif+    return $ Response sc hs b -simpleHttp :: String -> IO (Response L.ByteString)-simpleHttp url = parseUrl url >>= httpLbs+-- | 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 lbsIter@+--+-- Please see 'lbsIter' for more information on how the 'Response' value is+-- created.+httpLbs :: MonadIO m => Request -> m Response+httpLbs = http lbsIter++#if DEBUG+consume' =+    liftI step+  where+    step chunk = case chunk of+        Chunks [] -> Continue $ returnI . step+        Chunks xs -> Continue $ \stream -> do+            liftIO $ putStrLn $ "consume': received Chunks: " ++ show xs+            returnI $ step stream+        EOF -> Yield [] EOF+#endif++-- | Download the specified URL, following any redirects, and return the+-- response body.+--+-- 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 :: ( Failure InvalidUrlException m+              , Failure HttpException m+              , MonadIO m)+           => String -> m L.ByteString+simpleHttp url = do+    url' <- parseUrl url+    Response sc _ b <- httpLbsRedirect url'+    if 200 <= sc && sc < 300+        then return b+        else failure $ HttpException sc b++-- | Throw by 'simpleHttp' when a response does not have a 2xx status code.+data HttpException = HttpException Int L.ByteString+    deriving (Show, Typeable)+instance Exception HttpException++-- | Same as 'http', but follows all 3xx redirect status codes that contain a+-- location header.+httpRedirect+    :: (MonadIO m, Failure InvalidUrlException m)+    => (Int -> Headers -> Iteratee S.ByteString m a)+    -> Request+    -> m a+httpRedirect iter req =+    http iter' req+  where+    iter' code hs+        | 300 <= code && code < 400 =+            case lookup "location" $ map (first $ S8.map toLower) hs of+                Just l'' -> lift $ 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 <- parseUrl l'+                    let req' = req+                            { host = host l+                            , port = port l+                            , secure = secure l+                            , path = path l+                            , queryString = queryString l+                            }+                    http iter req'+                Nothing -> iter code hs+        | otherwise = iter code hs++-- | 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 lbsIter@+--+-- Please see 'lbsIter' for more information on how the 'Response' value is+-- created.+httpLbsRedirect :: ( Failure InvalidUrlException m+                   , MonadIO m)+                => Request -> m Response+httpLbsRedirect = httpRedirect lbsIter  readMay :: Read a => String -> Maybe a readMay s = case reads s of

@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Enumerator.HttpParser     ( iterHeaders-    , iterChunks+    , iterChunkHeader+    , iterNewline     ) where  import Prelude hiding (take)@@ -83,11 +84,22 @@ zeroChunk :: Parser () zeroChunk = word8 48 >> (newline <|> attribs) -- 0 -parseChunk :: Parser S.ByteString-parseChunk = do+parseChunkHeader :: Parser Int+parseChunkHeader = do     len <- hexs     skipWhile isSpace     newline <|> attribs+    return len++iterChunkHeader :: Monad m => Iteratee S.ByteString m Int+iterChunkHeader = iterParser parseChunkHeader++iterNewline :: Monad m => Iteratee S.ByteString m ()+iterNewline = iterParser newline++parseChunk :: Parser S.ByteString+parseChunk = do+    len <- parseChunkHeader     bs <- take len     newline     return bs

@@ -1,5 +1,5 @@ name:            http-enumerator-version:         0.0.1+version:         0.1.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -30,6 +30,7 @@                  , network-bytestring    >= 0.1.3   && < 0.2                  , attoparsec            >= 0.8.0.2 && < 0.9                  , attoparsec-enumerator >= 0.2     && < 0.3+                 , utf8-string           >= 0.3.4   && < 0.4     if flag(openssl)         build-depends: HsOpenSSL         >= 0.8     && < 0.9         cpp-options:   -DOPENSSL

@@ -1,27 +1,21 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} import Network.HTTP.Enumerator import Network import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Enumerator (consume, Iteratee)-import System.Environment (getArgs)+import System.Environment.UTF8 (getArgs)  main :: IO () main = withSocketsDo $ withHttpEnumerator $ do-    let _req1 = Request-            { host = "localhost"-            , port = 80-            , secure = False-            , requestHeaders = []-            , path = "/"-            , queryString = [("foo", "bar")]-            , requestBody = L8.pack "baz=bin"-            , method = "POST"-            }     [url] <- getArgs     _req2 <- parseUrl url-    Response sc hs b <- http _req2 toLBS+    Response sc hs b <- httpLbsRedirect _req2+#if DEBUG+    return ()+#else     print sc     mapM_ (\(x, y) -> do         S.putStr x@@ -30,6 +24,4 @@         putStrLn "") hs     putStrLn ""     L.putStr b--toLBS :: Monad m => Iteratee S.ByteString m L.ByteString-toLBS = L.fromChunks `fmap` consume+#endif