diff --git a/Network/HTTP/Enumerator.hs b/Network/HTTP/Enumerator.hs --- a/Network/HTTP/Enumerator.hs +++ b/Network/HTTP/Enumerator.hs @@ -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 diff --git a/Network/HTTP/Enumerator/HttpParser.hs b/Network/HTTP/Enumerator/HttpParser.hs --- a/Network/HTTP/Enumerator/HttpParser.hs +++ b/Network/HTTP/Enumerator/HttpParser.hs @@ -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 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.0.1 +version: 0.1.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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 diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -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