http-enumerator 0.6.2.1 → 0.6.3
raw patch · 7 files changed
+953/−951 lines, 7 filesdep +crypto-apidep ~tlsdep ~tls-extrasetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: crypto-api
Dependency ranges changed: tls, tls-extra
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/−82
- Setup.lhs +8/−8
- http-enumerator.cabal +61/−60
- 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,82 +1,83 @@-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)--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- }- esrand <- liftIO makeSRandomGen- let srg = either (error . show) id esrand- istate <- liftIO $ client tcp srg 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 (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
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,60 +1,61 @@-name: http-enumerator-version: 0.6.2.1-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- , tls >= 0.5 && < 0.6- , tls-extra >= 0.1.9 && < 0.2- , 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.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
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