diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,25 +1,25 @@ -The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright 2010, Michael Snoyman. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO -EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, -OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/HTTP/Enumerator.hs b/Network/HTTP/Enumerator.hs --- a/Network/HTTP/Enumerator.hs +++ b/Network/HTTP/Enumerator.hs @@ -1,601 +1,601 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} --- | 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 --- > import qualified Data.ByteString.Lazy as L --- > --- > main = simpleHttp "http://www.haskell.org/" >>= L.putStr --- --- This example uses interleaved IO to write the response body to a file in --- constant memory space. By using 'httpRedirect', it will automatically --- follow 3xx redirects. --- --- > import Data.Enumerator --- > import Data.Enumerator.Binary --- > import Network.HTTP.Enumerator --- > import System.IO --- > --- > main :: IO () --- > main = withFile "google.html" WriteMode $ \handle -> do --- > request <- parseUrl "http://google.com/" --- > withManager $ run_ $ httpRedirect request (\_ _ -> iterHandle handle) --- --- The following headers are automatically set by this module, and should not --- be added to 'requestHeaders': --- --- * Content-Length --- --- * Host --- --- * Accept-Encoding (not currently set, but client usage of this variable /will/ cause breakage). --- --- Any network code on Windows requires some initialization, and the network --- library provides withSocketsDo to perform it. Therefore, proper usage of --- this library will always involve calling that function at some point. The --- best approach is to simply call them at the beginning of your main function, --- such as: --- --- > import Network.HTTP.Enumerator --- > import qualified Data.ByteString.Lazy as L --- > import Network (withSocketsDo) --- > --- > main = withSocketsDo --- > $ simpleHttp "http://www.haskell.org/" >>= L.putStr -module Network.HTTP.Enumerator - ( -- * Perform a request - simpleHttp - , httpLbs - , httpLbsRedirect - , http - , httpRedirect - , redirectIter - -- * Datatypes - , Request (..) - , RequestBody (..) - , Response (..) - -- * Manager - , Manager - , newManager - , closeManager - , withManager - -- * Utility functions - , parseUrl - , semiParseUrl - , lbsIter - -- * Request bodies - , urlEncodedBody - -- * Exceptions - , HttpException (..) - ) where - -import qualified Network.TLS.Client.Enumerator as TLS -import Network (connectTo, PortID (PortNumber)) - -import qualified Network.Socket as NS -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 - , yield, Step (..), Enumeratee, ($$), joinI, Enumerator, run_ - , returnI, (>==>) - ) -import qualified Data.Enumerator.List as EL -import Network.HTTP.Enumerator.HttpParser -import Control.Exception (Exception, bracket) -import Control.Arrow (first) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Class (lift) -import Control.Failure -import Data.Typeable (Typeable) -import Codec.Binary.UTF8.String (encodeString) -import qualified Blaze.ByteString.Builder as Blaze -import Blaze.ByteString.Builder.Enumerator (builderToByteString) -import Data.Monoid (Monoid (..)) -import qualified Network.HTTP.Types as W -import qualified Data.CaseInsensitive as CI -import Data.Int (Int64) -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 Network.TLS.Extra (certificateVerifyChain, certificateVerifyDomain) - -getSocket :: String -> Int -> IO NS.Socket -getSocket host' port' = do - let hints = NS.defaultHints { - NS.addrFlags = [NS.AI_ADDRCONFIG] - , NS.addrSocketType = NS.Stream - } - (addr:_) <- NS.getAddrInfo (Just hints) (Just host') (Just $ show port') - sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) - (NS.addrProtocol addr) - NS.connect sock (NS.addrAddress addr) - return sock - -withSocketConn :: MonadIO m - => Manager - -> String - -> Int - -> Enumerator Blaze.Builder m () - -> Enumerator S.ByteString m a -withSocketConn man host' port' = - withManagedConn man (host', port', False) $ - fmap TLS.socketConn $ getSocket host' port' - -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 - => ([X509] -> IO Bool) - -> Manager - -> String -- ^ host - -> Int -- ^ port - -> Enumerator Blaze.Builder m () -- ^ request - -> Enumerator S.ByteString m a -- ^ response -withSslConn checkCert man host' port' = - withManagedConn man (host', port', True) $ - (connectTo host' (PortNumber $ fromIntegral port') >>= TLS.sslClientConn checkCert) - -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 - --- | 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 m = Request - { method :: W.Method -- ^ HTTP request method, eg GET, POST. - , secure :: Bool -- ^ Whether to use HTTPS (ie, SSL). - , checkCerts :: [X509] -> IO Bool -- ^ Check if the server certificate is valid. Only relevant for HTTPS. - , host :: W.Ascii - , port :: Int - , path :: W.Ascii -- ^ Everything from the host to the query string. - , queryString :: W.Query -- ^ Automatically escaped for your convenience. - , requestHeaders :: W.RequestHeaders - , requestBody :: RequestBody m - } - --- | 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 - | RequestBodyBS S.ByteString - | RequestBodyBuilder Int64 Blaze.Builder - | RequestBodyEnum Int64 (Enumerator Blaze.Builder m ()) - --- | A simple representation of the HTTP response created by 'lbsIter'. -data Response = Response - { statusCode :: Int - , responseHeaders :: W.ResponseHeaders - , responseBody :: L.ByteString - } - deriving (Show, Read, Eq, Typeable) - -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. --- --- The first argument to this function gives a full specification on the --- request: the host to connect to, whether to use SSL, headers, etc. Please --- see 'Request' for full details. --- --- The second argument specifies how the response should be handled. It's a --- function that takes two arguments: the first is the HTTP status code of the --- response, and the second is a list of all response headers. This module --- exports '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 - => Request m - -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) - -> Manager - -> Iteratee S.ByteString m a -http Request {..} bodyStep m = do - let h' = S8.unpack 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) - RequestBodyBS bs -> (fromIntegral $ S.length bs, enumSingle $ Blaze.fromByteString bs) - RequestBodyBuilder i b -> (i, enumSingle b) - RequestBodyEnum i enum -> (i, enum) - hh - | port == 80 && not secure = host - | port == 443 && secure = host - | otherwise = host `mappend` S8.pack (':' : show port) - headers' = ("Host", hh) - : ("Content-Length", S8.pack $ show contentLength) - : ("Accept-Encoding", "gzip") - : requestHeaders - requestHeaders' = - Blaze.fromByteString method - `mappend` Blaze.fromByteString " " - `mappend` - (case S8.uncons path of - Just ('/', _) -> Blaze.fromByteString path - _ -> Blaze.fromByteString "/" - `mappend` Blaze.fromByteString path) - `mappend` (if null queryString - then mempty - else W.renderQueryBuilder True queryString) - `mappend` Blaze.fromByteString " HTTP/1.1\r\n" - `mappend` mconcat (flip map headers' $ \(k, v) -> - Blaze.fromByteString (CI.original k) - `mappend` Blaze.fromByteString ": " - `mappend` Blaze.fromByteString v - `mappend` Blaze.fromByteString "\r\n") - `mappend` Blaze.fromByteString "\r\n" - requestEnum = enumSingle requestHeaders' >==> bodyEnum - go = do - ((_, sc, sm), hs) <- iterHeaders - let s = W.Status sc sm - let hs' = map (first CI.mk) 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 - Just len -> joinI $ takeLBS len $$ x - Nothing -> x - let decompress x = - if ("content-encoding", "gzip") `elem` hs' - then joinI $ Z.ungzip x - else returnI x - if method == "HEAD" - then bodyStep s hs' - else body' $ decompress $$ bodyStep s hs' - -chunkedEnumeratee :: MonadIO m => Enumeratee S.ByteString S.ByteString m a -chunkedEnumeratee k@(Continue _) = do - len <- catchParser "Chunk header" iterChunkHeader - if len == 0 - then return k - else do - k' <- takeLBS len k - catchParser "End of chunk newline" iterNewline - chunkedEnumeratee k' -chunkedEnumeratee 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 <- EL.head - case mbs of - Nothing -> return $ Continue k - Just bs -> do - 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 - -encodeUrlCharPI :: Char -> String -encodeUrlCharPI '/' = "/" -encodeUrlCharPI c = encodeUrlChar c - -encodeUrlChar :: Char -> String -encodeUrlChar c - -- List of unreserved characters per RFC 3986 - -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding - | 'A' <= c && c <= 'Z' = [c] - | 'a' <= c && c <= 'z' = [c] - | '0' <= c && c <= '9' = [c] -encodeUrlChar c@'-' = [c] -encodeUrlChar c@'_' = [c] -encodeUrlChar c@'.' = [c] -encodeUrlChar c@'~' = [c] -encodeUrlChar ' ' = "+" -encodeUrlChar y = - let (a, c) = fromEnum y `divMod` 16 - b = a `mod` 16 - showHex' x - | x < 10 = toEnum $ x + (fromEnum '0') - | x < 16 = toEnum $ x - 10 + (fromEnum 'A') - | otherwise = error $ "Invalid argument to showHex: " ++ show x - in ['%', showHex' b, showHex' c] - --- | Convert a URL into a 'Request'. --- --- This defaults some of the values in 'Request', such as setting 'method' to --- GET and 'requestHeaders' to @[]@. --- --- Since this function uses 'Failure', the return monad can be anything that is --- an instance of 'Failure', such as 'IO' or 'Maybe'. -parseUrl :: Failure HttpException m => String -> m (Request m') -parseUrl = parseUrlHelper True - --- | Same as 'parseUrl', with one distinction: this function will not attempt --- to parse the query string, but instead leave it with the path info. This can --- be useful if you need precise control of the rendering of the query string, --- such as using semicolons instead of ampersands. -semiParseUrl :: Failure HttpException m => String -> m (Request m') -semiParseUrl = parseUrlHelper False - -parseUrlHelper :: Failure HttpException m => Bool -> String -> m (Request m') -parseUrlHelper parsePath s@('h':'t':'t':'p':':':'/':'/':rest) = parseUrl1 s False parsePath rest -parseUrlHelper parsePath s@('h':'t':'t':'p':'s':':':'/':'/':rest) = parseUrl1 s True parsePath rest -parseUrlHelper _ x = failure $ InvalidUrlException x "Invalid scheme" - -parseUrl1 :: Failure HttpException m - => String -> Bool -> Bool -> String -> m (Request m') -parseUrl1 full sec parsePath s = - parseUrl2 full sec parsePath s' - where - s' = encodeString s - -parseUrl2 :: Failure HttpException m - => String -> Bool -> Bool -> String -> m (Request m') -parseUrl2 full sec parsePath s = do - port' <- mport - return Request - { host = S8.pack hostname - , port = port' - , secure = sec - , checkCerts = \x -> - if certificateVerifyDomain hostname x - then certificateVerifyChain x - else return False - , requestHeaders = [] - , path = S8.pack - $ if null path'' - then "/" - else concatMap encodeUrlCharPI path'' - , queryString = if parsePath - then W.parseQuery $ S8.pack qstring - else [] - , requestBody = RequestBodyLBS L.empty - , method = "GET" - } - where - (beforeSlash, afterSlash) = break (== '/') s - (hostname, portStr) = break (== ':') beforeSlash - (path', qstring') = break (== '?') afterSlash - path'' = if parsePath then path' else afterSlash - qstring'' = case qstring' of - '?':x -> x - _ -> qstring' - qstring = takeWhile (/= '#') qstring'' - mport = - case (portStr, sec) of - ("", False) -> return 80 - ("", True) -> return 443 - (':':rest, _) -> - case readMay rest of - Just i -> return i - Nothing -> failure $ InvalidUrlException full "Invalid port" - x -> error $ "parseUrl1: this should never happen: " ++ show x - --- | 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 => W.Status -> W.ResponseHeaders - -> Iteratee S.ByteString m Response -lbsIter (W.Status sc _) hs = do - lbs <- fmap L.fromChunks EL.consume - return $ Response sc hs lbs - --- | 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. --- --- Even though a 'Response' contains a lazy bytestring, this function does --- /not/ utilize lazy I/O, and therefore the entire response body will live in --- memory. If you want constant memory usage, you'll need to write your own --- iteratee and use 'http' or 'httpRedirect' directly. -httpLbs :: 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. --- --- 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'. --- --- Note: Even though this function returns a lazy bytestring, it does /not/ --- utilize lazy I/O, and therefore the entire response body will live in --- memory. If you want constant memory usage, you'll need to write your own --- iteratee and use 'http' or 'httpRedirect' directly. -simpleHttp :: (MonadIO m, Failure HttpException m) => String -> m L.ByteString -simpleHttp url = do - url' <- parseUrlHelper False url - Response sc _ b <- liftIO $ withManager $ httpLbsRedirect url' - if 200 <= sc && sc < 300 - then return b - else failure $ StatusCodeException sc b - -data HttpException = StatusCodeException Int L.ByteString - | InvalidUrlException String String - | TooManyRedirects - | HttpParserException String - 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 HttpException m) - => Request m - -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) - -> Manager - -> Iteratee S.ByteString m a -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 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 - , 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. --- --- 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. --- --- Even though a 'Response' contains a lazy bytestring, this function does --- /not/ utilize lazy I/O, and therefore the entire response body will live in --- memory. If you want constant memory usage, you'll need to write your own --- iteratee and use 'http' or 'httpRedirect' directly. -httpLbsRedirect :: (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 :: Monad m => [(S.ByteString, S.ByteString)] -> Request m' -> Request m -urlEncodedBody headers req = req - { requestBody = RequestBodyLBS body - , method = "POST" - , requestHeaders = - (ct, "application/x-www-form-urlencoded") - : filter (\(x, _) -> x /= ct) (requestHeaders req) - } - where - ct = "Content-Type" - body = L.fromChunks . return $ W.renderSimpleQuery False headers - -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 +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +-- | 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 +-- > import qualified Data.ByteString.Lazy as L +-- > +-- > main = simpleHttp "http://www.haskell.org/" >>= L.putStr +-- +-- This example uses interleaved IO to write the response body to a file in +-- constant memory space. By using 'httpRedirect', it will automatically +-- follow 3xx redirects. +-- +-- > import Data.Enumerator +-- > import Data.Enumerator.Binary +-- > import Network.HTTP.Enumerator +-- > import System.IO +-- > +-- > main :: IO () +-- > main = withFile "google.html" WriteMode $ \handle -> do +-- > request <- parseUrl "http://google.com/" +-- > withManager $ run_ $ httpRedirect request (\_ _ -> iterHandle handle) +-- +-- The following headers are automatically set by this module, and should not +-- be added to 'requestHeaders': +-- +-- * Content-Length +-- +-- * Host +-- +-- * Accept-Encoding (not currently set, but client usage of this variable /will/ cause breakage). +-- +-- Any network code on Windows requires some initialization, and the network +-- library provides withSocketsDo to perform it. Therefore, proper usage of +-- this library will always involve calling that function at some point. The +-- best approach is to simply call them at the beginning of your main function, +-- such as: +-- +-- > import Network.HTTP.Enumerator +-- > import qualified Data.ByteString.Lazy as L +-- > import Network (withSocketsDo) +-- > +-- > main = withSocketsDo +-- > $ simpleHttp "http://www.haskell.org/" >>= L.putStr +module Network.HTTP.Enumerator + ( -- * Perform a request + simpleHttp + , httpLbs + , httpLbsRedirect + , http + , httpRedirect + , redirectIter + -- * Datatypes + , Request (..) + , RequestBody (..) + , Response (..) + -- * Manager + , Manager + , newManager + , closeManager + , withManager + -- * Utility functions + , parseUrl + , semiParseUrl + , lbsIter + -- * Request bodies + , urlEncodedBody + -- * Exceptions + , HttpException (..) + ) where + +import qualified Network.TLS.Client.Enumerator as TLS +import Network (connectTo, PortID (PortNumber)) + +import qualified Network.Socket as NS +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 + , yield, Step (..), Enumeratee, ($$), joinI, Enumerator, run_ + , returnI, (>==>) + ) +import qualified Data.Enumerator.List as EL +import Network.HTTP.Enumerator.HttpParser +import Control.Exception (Exception, bracket) +import Control.Arrow (first) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (lift) +import Control.Failure +import Data.Typeable (Typeable) +import Codec.Binary.UTF8.String (encodeString) +import qualified Blaze.ByteString.Builder as Blaze +import Blaze.ByteString.Builder.Enumerator (builderToByteString) +import Data.Monoid (Monoid (..)) +import qualified Network.HTTP.Types as W +import qualified Data.CaseInsensitive as CI +import Data.Int (Int64) +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 Network.TLS.Extra (certificateVerifyChain, certificateVerifyDomain) + +getSocket :: String -> Int -> IO NS.Socket +getSocket host' port' = do + let hints = NS.defaultHints { + NS.addrFlags = [NS.AI_ADDRCONFIG] + , NS.addrSocketType = NS.Stream + } + (addr:_) <- NS.getAddrInfo (Just hints) (Just host') (Just $ show port') + sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) + (NS.addrProtocol addr) + NS.connect sock (NS.addrAddress addr) + return sock + +withSocketConn :: MonadIO m + => Manager + -> String + -> Int + -> Enumerator Blaze.Builder m () + -> Enumerator S.ByteString m a +withSocketConn man host' port' = + withManagedConn man (host', port', False) $ + fmap TLS.socketConn $ getSocket host' port' + +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 + => ([X509] -> IO Bool) + -> Manager + -> String -- ^ host + -> Int -- ^ port + -> Enumerator Blaze.Builder m () -- ^ request + -> Enumerator S.ByteString m a -- ^ response +withSslConn checkCert man host' port' = + withManagedConn man (host', port', True) $ + (connectTo host' (PortNumber $ fromIntegral port') >>= TLS.sslClientConn checkCert) + +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 + +-- | 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 m = Request + { method :: W.Method -- ^ HTTP request method, eg GET, POST. + , secure :: Bool -- ^ Whether to use HTTPS (ie, SSL). + , checkCerts :: [X509] -> IO Bool -- ^ Check if the server certificate is valid. Only relevant for HTTPS. + , host :: W.Ascii + , port :: Int + , path :: W.Ascii -- ^ Everything from the host to the query string. + , queryString :: W.Query -- ^ Automatically escaped for your convenience. + , requestHeaders :: W.RequestHeaders + , requestBody :: RequestBody m + } + +-- | 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 + | RequestBodyBS S.ByteString + | RequestBodyBuilder Int64 Blaze.Builder + | RequestBodyEnum Int64 (Enumerator Blaze.Builder m ()) + +-- | A simple representation of the HTTP response created by 'lbsIter'. +data Response = Response + { statusCode :: Int + , responseHeaders :: W.ResponseHeaders + , responseBody :: L.ByteString + } + deriving (Show, Read, Eq, Typeable) + +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. +-- +-- The first argument to this function gives a full specification on the +-- request: the host to connect to, whether to use SSL, headers, etc. Please +-- see 'Request' for full details. +-- +-- The second argument specifies how the response should be handled. It's a +-- function that takes two arguments: the first is the HTTP status code of the +-- response, and the second is a list of all response headers. This module +-- exports '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 + => Request m + -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) + -> Manager + -> Iteratee S.ByteString m a +http Request {..} bodyStep m = do + let h' = S8.unpack 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) + RequestBodyBS bs -> (fromIntegral $ S.length bs, enumSingle $ Blaze.fromByteString bs) + RequestBodyBuilder i b -> (i, enumSingle b) + RequestBodyEnum i enum -> (i, enum) + hh + | port == 80 && not secure = host + | port == 443 && secure = host + | otherwise = host `mappend` S8.pack (':' : show port) + headers' = ("Host", hh) + : ("Content-Length", S8.pack $ show contentLength) + : ("Accept-Encoding", "gzip") + : requestHeaders + requestHeaders' = + Blaze.fromByteString method + `mappend` Blaze.fromByteString " " + `mappend` + (case S8.uncons path of + Just ('/', _) -> Blaze.fromByteString path + _ -> Blaze.fromByteString "/" + `mappend` Blaze.fromByteString path) + `mappend` (if null queryString + then mempty + else W.renderQueryBuilder True queryString) + `mappend` Blaze.fromByteString " HTTP/1.1\r\n" + `mappend` mconcat (flip map headers' $ \(k, v) -> + Blaze.fromByteString (CI.original k) + `mappend` Blaze.fromByteString ": " + `mappend` Blaze.fromByteString v + `mappend` Blaze.fromByteString "\r\n") + `mappend` Blaze.fromByteString "\r\n" + requestEnum = enumSingle requestHeaders' >==> bodyEnum + go = do + ((_, sc, sm), hs) <- iterHeaders + let s = W.Status sc sm + let hs' = map (first CI.mk) 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 + Just len -> joinI $ takeLBS len $$ x + Nothing -> x + let decompress x = + if ("content-encoding", "gzip") `elem` hs' + then joinI $ Z.ungzip x + else returnI x + if method == "HEAD" + then bodyStep s hs' + else body' $ decompress $$ bodyStep s hs' + +chunkedEnumeratee :: MonadIO m => Enumeratee S.ByteString S.ByteString m a +chunkedEnumeratee k@(Continue _) = do + len <- catchParser "Chunk header" iterChunkHeader + if len == 0 + then return k + else do + k' <- takeLBS len k + catchParser "End of chunk newline" iterNewline + chunkedEnumeratee k' +chunkedEnumeratee 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 <- EL.head + case mbs of + Nothing -> return $ Continue k + Just bs -> do + 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 + +encodeUrlCharPI :: Char -> String +encodeUrlCharPI '/' = "/" +encodeUrlCharPI c = encodeUrlChar c + +encodeUrlChar :: Char -> String +encodeUrlChar c + -- List of unreserved characters per RFC 3986 + -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding + | 'A' <= c && c <= 'Z' = [c] + | 'a' <= c && c <= 'z' = [c] + | '0' <= c && c <= '9' = [c] +encodeUrlChar c@'-' = [c] +encodeUrlChar c@'_' = [c] +encodeUrlChar c@'.' = [c] +encodeUrlChar c@'~' = [c] +encodeUrlChar ' ' = "+" +encodeUrlChar y = + let (a, c) = fromEnum y `divMod` 16 + b = a `mod` 16 + showHex' x + | x < 10 = toEnum $ x + (fromEnum '0') + | x < 16 = toEnum $ x - 10 + (fromEnum 'A') + | otherwise = error $ "Invalid argument to showHex: " ++ show x + in ['%', showHex' b, showHex' c] + +-- | Convert a URL into a 'Request'. +-- +-- This defaults some of the values in 'Request', such as setting 'method' to +-- GET and 'requestHeaders' to @[]@. +-- +-- Since this function uses 'Failure', the return monad can be anything that is +-- an instance of 'Failure', such as 'IO' or 'Maybe'. +parseUrl :: Failure HttpException m => String -> m (Request m') +parseUrl = parseUrlHelper True + +-- | Same as 'parseUrl', with one distinction: this function will not attempt +-- to parse the query string, but instead leave it with the path info. This can +-- be useful if you need precise control of the rendering of the query string, +-- such as using semicolons instead of ampersands. +semiParseUrl :: Failure HttpException m => String -> m (Request m') +semiParseUrl = parseUrlHelper False + +parseUrlHelper :: Failure HttpException m => Bool -> String -> m (Request m') +parseUrlHelper parsePath s@('h':'t':'t':'p':':':'/':'/':rest) = parseUrl1 s False parsePath rest +parseUrlHelper parsePath s@('h':'t':'t':'p':'s':':':'/':'/':rest) = parseUrl1 s True parsePath rest +parseUrlHelper _ x = failure $ InvalidUrlException x "Invalid scheme" + +parseUrl1 :: Failure HttpException m + => String -> Bool -> Bool -> String -> m (Request m') +parseUrl1 full sec parsePath s = + parseUrl2 full sec parsePath s' + where + s' = encodeString s + +parseUrl2 :: Failure HttpException m + => String -> Bool -> Bool -> String -> m (Request m') +parseUrl2 full sec parsePath s = do + port' <- mport + return Request + { host = S8.pack hostname + , port = port' + , secure = sec + , checkCerts = \x -> + if certificateVerifyDomain hostname x + then certificateVerifyChain x + else return False + , requestHeaders = [] + , path = S8.pack + $ if null path'' + then "/" + else concatMap encodeUrlCharPI path'' + , queryString = if parsePath + then W.parseQuery $ S8.pack qstring + else [] + , requestBody = RequestBodyLBS L.empty + , method = "GET" + } + where + (beforeSlash, afterSlash) = break (== '/') s + (hostname, portStr) = break (== ':') beforeSlash + (path', qstring') = break (== '?') afterSlash + path'' = if parsePath then path' else afterSlash + qstring'' = case qstring' of + '?':x -> x + _ -> qstring' + qstring = takeWhile (/= '#') qstring'' + mport = + case (portStr, sec) of + ("", False) -> return 80 + ("", True) -> return 443 + (':':rest, _) -> + case readMay rest of + Just i -> return i + Nothing -> failure $ InvalidUrlException full "Invalid port" + x -> error $ "parseUrl1: this should never happen: " ++ show x + +-- | 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 => W.Status -> W.ResponseHeaders + -> Iteratee S.ByteString m Response +lbsIter (W.Status sc _) hs = do + lbs <- fmap L.fromChunks EL.consume + return $ Response sc hs lbs + +-- | 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. +-- +-- Even though a 'Response' contains a lazy bytestring, this function does +-- /not/ utilize lazy I/O, and therefore the entire response body will live in +-- memory. If you want constant memory usage, you'll need to write your own +-- iteratee and use 'http' or 'httpRedirect' directly. +httpLbs :: 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. +-- +-- 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'. +-- +-- Note: Even though this function returns a lazy bytestring, it does /not/ +-- utilize lazy I/O, and therefore the entire response body will live in +-- memory. If you want constant memory usage, you'll need to write your own +-- iteratee and use 'http' or 'httpRedirect' directly. +simpleHttp :: (MonadIO m, Failure HttpException m) => String -> m L.ByteString +simpleHttp url = do + url' <- parseUrlHelper False url + Response sc _ b <- liftIO $ withManager $ httpLbsRedirect url' + if 200 <= sc && sc < 300 + then return b + else failure $ StatusCodeException sc b + +data HttpException = StatusCodeException Int L.ByteString + | InvalidUrlException String String + | TooManyRedirects + | HttpParserException String + 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 HttpException m) + => Request m + -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) + -> Manager + -> Iteratee S.ByteString m a +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 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 + , 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. +-- +-- 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. +-- +-- Even though a 'Response' contains a lazy bytestring, this function does +-- /not/ utilize lazy I/O, and therefore the entire response body will live in +-- memory. If you want constant memory usage, you'll need to write your own +-- iteratee and use 'http' or 'httpRedirect' directly. +httpLbsRedirect :: (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 :: Monad m => [(S.ByteString, S.ByteString)] -> Request m' -> Request m +urlEncodedBody headers req = req + { requestBody = RequestBodyLBS body + , method = "POST" + , requestHeaders = + (ct, "application/x-www-form-urlencoded") + : filter (\(x, _) -> x /= ct) (requestHeaders req) + } + where + ct = "Content-Type" + body = L.fromChunks . return $ W.renderSimpleQuery False headers + +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/HttpParser.hs b/Network/HTTP/Enumerator/HttpParser.hs --- a/Network/HTTP/Enumerator/HttpParser.hs +++ b/Network/HTTP/Enumerator/HttpParser.hs @@ -1,142 +1,142 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.HTTP.Enumerator.HttpParser - ( iterHeaders - , iterChunkHeader - , iterNewline - ) where - -import Prelude hiding (take, takeWhile) -import Data.Attoparsec -import Data.Attoparsec.Enumerator -import Data.Enumerator (Iteratee) -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import Control.Applicative -import Data.Word (Word8) - -type Header = (S.ByteString, S.ByteString) - -parseHeader :: Parser Header -parseHeader = do - k <- takeWhile1 notNewlineColon - _ <- word8 58 -- colon - skipWhile isSpace - v <- takeWhile notNewline - newline - return (k, v) - -notNewlineColon, isSpace, notNewline :: Word8 -> Bool - -notNewlineColon 10 = False -- LF -notNewlineColon 13 = False -- CR -notNewlineColon 58 = False -- colon -notNewlineColon _ = True - -isSpace 32 = True -isSpace _ = False - -notNewline 10 = False -notNewline 13 = False -notNewline _ = True - -newline :: Parser () -newline = - lf <|> (cr >> lf) - where - word8' x = word8 x >> return () - lf = word8' 10 - cr = word8' 13 - -parseHeaders :: Parser (Status, [Header]) -parseHeaders = do - s <- parseStatus "HTTP status line" - h <- manyTill parseHeader newline "Response headers" - return (s, h) - -iterHeaders :: Monad m => Iteratee S.ByteString m (Status, [Header]) -iterHeaders = iterParser parseHeaders - -type Status = (S.ByteString, Int, S.ByteString) - -parseStatus :: Parser Status -parseStatus = do - _ <- string "HTTP/" - ver <- takeWhile1 $ not . isSpace - _ <- word8 32 -- space - statCode <- takeWhile1 $ not . isSpace - statCode' <- - case reads $ S8.unpack statCode of - [] -> fail $ "Invalid status code: " ++ S8.unpack statCode - (x, _):_ -> return x - _ <- word8 32 - statMsg <- takeWhile1 $ notNewline - newline - if (statCode == "100") - then newline >> parseStatus - else return (ver, statCode', statMsg) - -parseChunkHeader :: Parser Int -parseChunkHeader = do - len <- hexs - skipWhile isSpace - newline <|> attribs - return len - -iterChunkHeader :: Monad m => Iteratee S.ByteString m Int -iterChunkHeader = - iterParser (parseChunkHeader "Chunked transfer encoding header") - -iterNewline :: Monad m => Iteratee S.ByteString m () -iterNewline = iterParser newline - -attribs :: Parser () -attribs = do - _ <- word8 59 -- colon - skipWhile notNewline - newline - -hexs :: Parser Int -hexs = do - ws <- many1 hex - return $ foldl1 (\a b -> a * 16 + b) $ map fromIntegral ws - -hex :: Parser Word8 -hex = - (digit <|> upper <|> lower) "Hexadecimal digit" - where - digit = do - d <- satisfy $ \w -> (w >= 48 && w <= 57) - return $ d - 48 - upper = do - d <- satisfy $ \w -> (w >= 65 && w <= 70) - return $ d - 55 - lower = do - d <- satisfy $ \w -> (w >= 97 && w <= 102) - return $ d - 87 - -{- -iterParserTill :: Monad m - => Parser a - -> Parser end - -> E.Enumeratee a S.ByteString m b -iterParserTill p pend = - E.continue $ step $ parse p - where - step parse (E.Chunks xs) = parseLoop parse xs - step parse E.EOF = case parse S.empty of - Done extra a -> E.yield a $ if S.null extra - then E.Chunks [] - else E.Chunks [extra] - Partial _ -> err [] "iterParser: divergent parser" - Fail _ ctx msg -> err ctx msg - - parseLoop parse [] = E.continue (step parse) - parseLoop parse (x:xs) = case parse x of - Done extra a -> E.yield a $ if S.null extra - then E.Chunks xs - else E.Chunks (extra:xs) - Partial parse' -> parseLoop parse' xs - Fail _ ctx msg -> err ctx msg - - err ctx msg = E.throwError (ParseError ctx msg) --} +{-# LANGUAGE OverloadedStrings #-} +module Network.HTTP.Enumerator.HttpParser + ( iterHeaders + , iterChunkHeader + , iterNewline + ) where + +import Prelude hiding (take, takeWhile) +import Data.Attoparsec +import Data.Attoparsec.Enumerator +import Data.Enumerator (Iteratee) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Control.Applicative +import Data.Word (Word8) + +type Header = (S.ByteString, S.ByteString) + +parseHeader :: Parser Header +parseHeader = do + k <- takeWhile1 notNewlineColon + _ <- word8 58 -- colon + skipWhile isSpace + v <- takeWhile notNewline + newline + return (k, v) + +notNewlineColon, isSpace, notNewline :: Word8 -> Bool + +notNewlineColon 10 = False -- LF +notNewlineColon 13 = False -- CR +notNewlineColon 58 = False -- colon +notNewlineColon _ = True + +isSpace 32 = True +isSpace _ = False + +notNewline 10 = False +notNewline 13 = False +notNewline _ = True + +newline :: Parser () +newline = + lf <|> (cr >> lf) + where + word8' x = word8 x >> return () + lf = word8' 10 + cr = word8' 13 + +parseHeaders :: Parser (Status, [Header]) +parseHeaders = do + s <- parseStatus "HTTP status line" + h <- manyTill parseHeader newline "Response headers" + return (s, h) + +iterHeaders :: Monad m => Iteratee S.ByteString m (Status, [Header]) +iterHeaders = iterParser parseHeaders + +type Status = (S.ByteString, Int, S.ByteString) + +parseStatus :: Parser Status +parseStatus = do + _ <- string "HTTP/" + ver <- takeWhile1 $ not . isSpace + _ <- word8 32 -- space + statCode <- takeWhile1 $ not . isSpace + statCode' <- + case reads $ S8.unpack statCode of + [] -> fail $ "Invalid status code: " ++ S8.unpack statCode + (x, _):_ -> return x + _ <- word8 32 + statMsg <- takeWhile1 $ notNewline + newline + if (statCode == "100") + then newline >> parseStatus + else return (ver, statCode', statMsg) + +parseChunkHeader :: Parser Int +parseChunkHeader = do + len <- hexs + skipWhile isSpace + newline <|> attribs + return len + +iterChunkHeader :: Monad m => Iteratee S.ByteString m Int +iterChunkHeader = + iterParser (parseChunkHeader "Chunked transfer encoding header") + +iterNewline :: Monad m => Iteratee S.ByteString m () +iterNewline = iterParser newline + +attribs :: Parser () +attribs = do + _ <- word8 59 -- colon + skipWhile notNewline + newline + +hexs :: Parser Int +hexs = do + ws <- many1 hex + return $ foldl1 (\a b -> a * 16 + b) $ map fromIntegral ws + +hex :: Parser Word8 +hex = + (digit <|> upper <|> lower) "Hexadecimal digit" + where + digit = do + d <- satisfy $ \w -> (w >= 48 && w <= 57) + return $ d - 48 + upper = do + d <- satisfy $ \w -> (w >= 65 && w <= 70) + return $ d - 55 + lower = do + d <- satisfy $ \w -> (w >= 97 && w <= 102) + return $ d - 87 + +{- +iterParserTill :: Monad m + => Parser a + -> Parser end + -> E.Enumeratee a S.ByteString m b +iterParserTill p pend = + E.continue $ step $ parse p + where + step parse (E.Chunks xs) = parseLoop parse xs + step parse E.EOF = case parse S.empty of + Done extra a -> E.yield a $ if S.null extra + then E.Chunks [] + else E.Chunks [extra] + Partial _ -> err [] "iterParser: divergent parser" + Fail _ ctx msg -> err ctx msg + + parseLoop parse [] = E.continue (step parse) + parseLoop parse (x:xs) = case parse x of + Done extra a -> E.yield a $ if S.null extra + then E.Chunks xs + else E.Chunks (extra:xs) + Partial parse' -> parseLoop parse' xs + Fail _ ctx msg -> err ctx msg + + err ctx msg = E.throwError (ParseError ctx msg) +-} diff --git a/Network/TLS/Client/Enumerator.hs b/Network/TLS/Client/Enumerator.hs --- a/Network/TLS/Client/Enumerator.hs +++ b/Network/TLS/Client/Enumerator.hs @@ -1,83 +1,83 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Network.TLS.Client.Enumerator - ( ConnInfo - , connClose - , connIter - , connEnum - , sslClientConn - , socketConn - ) where - -import Data.ByteString (ByteString) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -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 Data.Enumerator - ( Iteratee (..), Enumerator, Step (..), Stream (..), continue, returnI - ) -import Data.Certificate.X509 (X509) -import Network.TLS.Extra (ciphersuite_all) -import Crypto.Random (SystemRandom, newGenIO) - -data ConnInfo = ConnInfo - { connRead :: IO [ByteString] - , connWrite :: [ByteString] -> IO () - , connClose :: IO () - } - -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 - -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 - -socketConn :: Socket -> ConnInfo -socketConn sock = ConnInfo - { connRead = fmap return $ recv sock 4096 - , connWrite = mapM_ (sendAll sock) - , connClose = sClose sock - } - -sslClientConn :: ([X509] -> IO Bool) -> Handle -> IO ConnInfo -sslClientConn onCerts h = do - let tcp = defaultParams - { pConnectVersion = TLS10 - , pAllowedVersions = [ TLS10, TLS11 ] - , pCiphers = ciphersuite_all - , onCertificatesRecv = onCerts - } - gen :: SystemRandom <- newGenIO - istate <- liftIO $ client tcp gen h - liftIO $ handshake istate - return ConnInfo - { connRead = recvD istate - , connWrite = liftIO . sendData istate . L.fromChunks - , connClose = liftIO $ bye istate >> hClose h - } - where - recvD istate = do - x <- liftIO $ recvData istate - if L.null x - then recvD istate - else return $ L.toChunks x +{-# LANGUAGE ScopedTypeVariables #-} +module Network.TLS.Client.Enumerator + ( ConnInfo + , connClose + , connIter + , connEnum + , sslClientConn + , socketConn + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +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 Data.Enumerator + ( Iteratee (..), Enumerator, Step (..), Stream (..), continue, returnI + ) +import Data.Certificate.X509 (X509) +import Network.TLS.Extra (ciphersuite_all) +import Crypto.Random.AESCtr (makeSystem) + +data ConnInfo = ConnInfo + { connRead :: IO [ByteString] + , connWrite :: [ByteString] -> IO () + , connClose :: IO () + } + +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 + +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 + +socketConn :: Socket -> ConnInfo +socketConn sock = ConnInfo + { connRead = fmap return $ recv sock 4096 + , connWrite = mapM_ (sendAll sock) + , connClose = sClose sock + } + +sslClientConn :: ([X509] -> IO Bool) -> Handle -> IO ConnInfo +sslClientConn onCerts h = do + let tcp = defaultParams + { pConnectVersion = TLS10 + , pAllowedVersions = [ TLS10, TLS11 ] + , pCiphers = ciphersuite_all + , onCertificatesRecv = onCerts + } + gen <- makeSystem + istate <- liftIO $ client tcp gen h + liftIO $ handshake istate + return ConnInfo + { connRead = recvD istate + , connWrite = liftIO . sendData istate . L.fromChunks + , connClose = liftIO $ bye istate >> hClose h + } + where + recvD istate = do + x <- liftIO $ recvData istate + if L.null x + then recvD istate + else return $ L.toChunks x diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,8 +1,8 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple -> import System.Cmd (system) - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMain diff --git a/http-enumerator.cabal b/http-enumerator.cabal --- a/http-enumerator.cabal +++ b/http-enumerator.cabal @@ -1,61 +1,61 @@ -name: http-enumerator -version: 0.6.3 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman -maintainer: Michael Snoyman -synopsis: HTTP client package with enumerator interface and HTTPS support. -description: - This package uses attoparsec for parsing the actual contents of the HTTP connection. The only gotcha is the withHttpEnumerator function, otherwise should do exactly what you expect. -category: Web, Enumerator -stability: Experimental -cabal-version: >= 1.6 -build-type: Simple -homepage: http://github.com/snoyberg/http-enumerator - -flag test - description: Build the test executable. - default: False -flag network-bytestring - default: False - -library - build-depends: base >= 4 && < 5 - , bytestring >= 0.9.1.4 && < 0.10 - , transformers >= 0.2 && < 0.3 - , failure >= 0.1 && < 0.2 - , 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.4 - , zlib-enum >= 0.2 && < 0.3 - , http-types >= 0.6 && < 0.7 - , blaze-builder-enumerator >= 0.2 && < 0.3 - , crypto-api >= 0.6 && < 0.7 - , tls >= 0.6 && < 0.7 - , tls-extra >= 0.2 && < 0.3 - , monad-control >= 0.2 && < 0.3 - , containers >= 0.2 && < 0.5 - , certificate >= 0.7 && < 0.8 - , case-insensitive >= 0.2 && < 0.3 - if flag(network-bytestring) - build-depends: network >= 2.2.1 && < 2.2.3 - , network-bytestring >= 0.1.3 && < 0.1.4 - else - build-depends: network >= 2.3 && < 2.4 - exposed-modules: Network.HTTP.Enumerator - other-modules: Network.HTTP.Enumerator.HttpParser - Network.TLS.Client.Enumerator - ghc-options: -Wall - -executable http-enumerator - main-is: test.hs - if flag(test) - Buildable: True - else - Buildable: False - -source-repository head - type: git - location: git://github.com/snoyberg/http-enumerator.git +name: http-enumerator +version: 0.6.4 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: HTTP client package with enumerator interface and HTTPS support. +description: + This package uses attoparsec for parsing the actual contents of the HTTP connection. The only gotcha is the withHttpEnumerator function, otherwise should do exactly what you expect. +category: Web, Enumerator +stability: Experimental +cabal-version: >= 1.6 +build-type: Simple +homepage: http://github.com/snoyberg/http-enumerator + +flag test + description: Build the test executable. + default: False +flag network-bytestring + default: False + +library + build-depends: base >= 4 && < 5 + , bytestring >= 0.9.1.4 && < 0.10 + , transformers >= 0.2 && < 0.3 + , failure >= 0.1 && < 0.2 + , 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.4 + , zlib-enum >= 0.2 && < 0.3 + , http-types >= 0.6 && < 0.7 + , blaze-builder-enumerator >= 0.2 && < 0.3 + , cprng-aes >= 0.2 && < 0.3 + , tls >= 0.6 && < 0.7 + , tls-extra >= 0.2 && < 0.3 + , monad-control >= 0.2 && < 0.3 + , containers >= 0.2 && < 0.5 + , certificate >= 0.7 && < 0.8 + , case-insensitive >= 0.2 && < 0.3 + if flag(network-bytestring) + build-depends: network >= 2.2.1 && < 2.2.3 + , network-bytestring >= 0.1.3 && < 0.1.4 + else + build-depends: network >= 2.3 && < 2.4 + exposed-modules: Network.HTTP.Enumerator + other-modules: Network.HTTP.Enumerator.HttpParser + Network.TLS.Client.Enumerator + ghc-options: -Wall + +executable http-enumerator + main-is: test.hs + if flag(test) + Buildable: True + else + Buildable: False + +source-repository head + type: git + location: git://github.com/snoyberg/http-enumerator.git diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -1,33 +1,33 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -import Network.HTTP.Enumerator -import Network -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import System.Environment.UTF8 (getArgs) -import Data.CaseInsensitive (original) - -main :: IO () -main = withSocketsDo $ do - [url] <- getArgs - _req2 <- parseUrl url - {- - let req = urlEncodedBody - [ ("foo", "bar") - , ("baz%%38**.8fn", "bin") - ] _req2 - -} - Response sc hs b <- withManager $ httpLbsRedirect _req2 -#if DEBUG - return () -#else - print sc - mapM_ (\(x, y) -> do - S.putStr $ original x - putStr ": " - S.putStr y - putStrLn "") hs - putStrLn "" - L.putStr b -#endif +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +import Network.HTTP.Enumerator +import Network +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import System.Environment.UTF8 (getArgs) +import Data.CaseInsensitive (original) + +main :: IO () +main = withSocketsDo $ do + [url] <- getArgs + _req2 <- parseUrl url + {- + let req = urlEncodedBody + [ ("foo", "bar") + , ("baz%%38**.8fn", "bin") + ] _req2 + -} + Response sc hs b <- withManager $ httpLbsRedirect _req2 +#if DEBUG + return () +#else + print sc + mapM_ (\(x, y) -> do + S.putStr $ original x + putStr ": " + S.putStr y + putStrLn "") hs + putStrLn "" + L.putStr b +#endif