http-enumerator 0.6.3 → 0.6.4
raw patch · 7 files changed
+953/−953 lines, 7 filesdep +cprng-aesdep −crypto-apisetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: cprng-aes
Dependencies removed: crypto-api
API changes (from Hackage documentation)
Files
- LICENSE +25/−25
- Network/HTTP/Enumerator.hs +601/−601
- Network/HTTP/Enumerator/HttpParser.hs +142/−142
- Network/TLS/Client/Enumerator.hs +83/−83
- Setup.lhs +8/−8
- http-enumerator.cabal +61/−61
- test.hs +33/−33
LICENSE view
@@ -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.
Network/HTTP/Enumerator.hs view
@@ -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
Network/HTTP/Enumerator/HttpParser.hs view
@@ -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)+-}
Network/TLS/Client/Enumerator.hs view
@@ -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
Setup.lhs view
@@ -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
http-enumerator.cabal view
@@ -1,61 +1,61 @@-name: http-enumerator -version: 0.6.3 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman <michael@snoyman.com> -maintainer: Michael Snoyman <michael@snoyman.com> -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 <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+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
test.hs view
@@ -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