http-enumerator 0.7.1.4 → 0.7.1.5
raw patch · 7 files changed
+1249/−1249 lines, 7 filesdep ~attoparsecdep ~case-insensitivedep ~containerssetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: attoparsec, case-insensitive, containers
API changes (from Hackage documentation)
Files
- LICENSE +25/−25
- Network/HTTP/Enumerator.hs +885/−885
- Network/HTTP/Enumerator/HttpParser.hs +148/−148
- Network/TLS/Client/Enumerator.hs +86/−86
- Setup.lhs +8/−8
- http-enumerator.cabal +64/−64
- 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,885 +1,885 @@-{-# 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 $ \manager -> do --- > run_ $ httpRedirect request (\_ _ -> iterHandle handle) manager --- --- 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 - , Proxy (..) - , RequestBody (..) - , Response (..) - -- ** Request - , Request - , def - , method - , secure - , checkCerts - , host - , port - , path - , queryString - , requestHeaders - , requestBody - , proxy - , rawBody - , decompress - -- *** Defaults - , defaultCheckCerts - -- * Manager - , Manager - , newManager - , closeManager - , withManager - -- * Utility functions - , parseUrl - , applyBasicAuth - , addProxy - , semiParseUrl - , lbsIter - -- * Decompression predicates - , alwaysDecompress - , browserDecompress - -- * 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, (>==>), (>>==), continue, checkDone, enumEOF - , (=$) - ) -import qualified Data.Enumerator.List as EL -import Network.HTTP.Enumerator.HttpParser -import Control.Exception (Exception, bracket, throwIO, SomeException, try) -import Control.Arrow (first) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Class (lift) -import Control.Failure (Failure (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 Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator) -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) -import qualified Data.ByteString.Base64 as B64 -import System.IO (hClose, hFlush) -import Blaze.ByteString.Builder (toByteString) -import Data.Maybe (fromMaybe) -import Data.Default (Default (def)) -import Numeric (showHex) -#if !MIN_VERSION_base(4,3,0) -import GHC.IO.Handle.Types -import System.IO (hWaitForInput, hIsEOF) -import System.IO.Error (mkIOError, illegalOperationErrorType) - --- | Like 'hGet', except that a shorter 'ByteString' may be returned --- if there are not enough bytes immediately available to satisfy the --- whole request. 'hGetSome' only blocks if there is no data --- available, and EOF has not yet been reached. --- -hGetSome :: Handle -> Int -> IO S.ByteString -hGetSome hh i - | i > 0 = let - loop = do - s <- S.hGetNonBlocking hh i - if not (S.null s) - then return s - else do eof <- hIsEOF hh - if eof then return s - else hWaitForInput hh (-1) >> loop - -- for this to work correctly, the - -- Handle should be in binary mode - -- (see GHC ticket #3808) - in loop - | i == 0 = return S.empty - | otherwise = illegalBufferSize hh "hGetSome" i - -illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize handle fn sz = - ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing) - --TODO: System.IO uses InvalidArgument here, but it's not exported :-( - where - msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz [] -#endif - -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) - ee <- try' $ NS.connect sock (NS.addrAddress addr) - case ee of - Left e -> NS.sClose sock >> throwIO e - Right () -> return sock - where - try' :: IO a -> IO (Either SomeException a) - try' = try - -withSocketConn :: MonadIO m - => Manager - -> String - -> Int - -> Enumerator Blaze.Builder m () - -> Step S.ByteString m (Bool, a) - -> Iteratee 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 () - -> Step S.ByteString m (Bool, a) -- ^ Bool indicates if the connection should go back in the manager - -> Iteratee S.ByteString m a -withManagedConn man key open req step = do - mci <- liftIO $ takeInsecureSocket man key - (ci, isManaged) <- - case mci of - Nothing -> do - ci <- liftIO open - return (ci, False) - Just ci -> return (ci, True) - catchError - (do - (toPut, a) <- withCI ci req step - liftIO $ if toPut - then putInsecureSocket man key ci - else TLS.connClose ci - return a) - (\se -> if isManaged - then withManagedConn man key open req step - else throwError se) - -withSslConn :: MonadIO m - => ([X509] -> IO TLS.TLSCertificateUsage) - -> Manager - -> String -- ^ host - -> Int -- ^ port - -> Enumerator Blaze.Builder m () -- ^ request - -> Step S.ByteString m (Bool, a) -- ^ response - -> Iteratee S.ByteString m a -- ^ response -withSslConn checkCert man host' port' = - withManagedConn man (host', port', True) $ - (connectTo host' (PortNumber $ fromIntegral port') >>= TLS.sslClientConn checkCert) - -withSslProxyConn :: MonadIO m - => ([X509] -> IO TLS.TLSCertificateUsage) - -> S8.ByteString -- ^ Target host - -> Int -- ^ Target port - -> Manager - -> String -- ^ Proxy host - -> Int -- ^ Proxy port - -> Enumerator Blaze.Builder m () -- ^ request - -> Step S.ByteString m (Bool, a) -- ^ response - -> Iteratee S.ByteString m a -- ^ response -withSslProxyConn checkCert thost tport man phost pport = - withManagedConn man (phost, pport, True) $ - doConnect >>= TLS.sslClientConn checkCert - where - doConnect = do - h <- connectTo phost (PortNumber $ fromIntegral pport) - S8.hPutStr h $ toByteString connectRequest - hFlush h -#if MIN_VERSION_base(4,3,0) - r <- S.hGetSome h 2048 -#else - r <- hGetSome h 2048 -#endif - res <- parserHeadersFromByteString r - case res of - Right ((_, 200, _), _) -> return h - Right ((_, _, msg), _) -> hClose h >> proxyError (S8.unpack msg) - Left s -> hClose h >> proxyError s - - connectRequest = - Blaze.fromByteString "CONNECT " - `mappend` Blaze.fromByteString thost - `mappend` Blaze.fromByteString (S8.pack (':' : show tport)) - `mappend` Blaze.fromByteString " HTTP/1.1\r\n\r\n" - proxyError s = - error $ "Proxy failed to CONNECT to '" - ++ S8.unpack thost ++ ":" ++ show tport ++ "' : " ++ s - -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 - - --- | Define a HTTP proxy, consisting of a hostname and port number. - -data Proxy = Proxy - { proxyHost :: W.Ascii -- ^ The host name of the HTTP proxy. - , proxyPort :: Int -- ^ The port numner of the HTTP proxy. - } - -type ContentType = S.ByteString - --- | 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'. --- --- The constructor for this data type is not exposed. Instead, you should use --- either the 'def' method to retrieve a default instance, or 'parseUrl' to --- construct from a URL, and then use the records below to make modifications. --- This approach allows http-enumerator to add configuration options without --- breaking backwards compatibility. -data Request m = Request - { method :: W.Method -- ^ HTTP request method, eg GET, POST. - , secure :: Bool -- ^ Whether to use HTTPS (ie, SSL). - , checkCerts :: W.Ascii -> [X509] -> IO TLS.TLSCertificateUsage -- ^ 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 - , proxy :: Maybe Proxy -- ^ Optional HTTP proxy. - , rawBody :: Bool -- ^ If True, a chunked and/or gzipped body will not be decoded. Use with caution. - , decompress :: ContentType -> Bool -- ^ Predicate to specify whether gzipped data should be decompressed on the fly. - } - --- | When using the 'RequestBodyEnum' constructor and any function which calls --- 'redirectIter', you must ensure that the 'Enumerator' can be called multiple --- times. --- --- The 'RequestBodyEnumChunked' will send a chunked request body, note --- that not all servers support this. Only use 'RequestBodyEnumChunked' --- if you know the server you're sending to supports chunked request --- bodies. -data RequestBody m - = RequestBodyLBS L.ByteString - | RequestBodyBS S.ByteString - | RequestBodyBuilder Int64 Blaze.Builder - | RequestBodyEnum Int64 (Enumerator Blaze.Builder m ()) - | RequestBodyEnumChunked (Enumerator Blaze.Builder m ()) - - --- | Add a Basic Auth header (with the specified user name and password) to the --- given Request. Ignore error handling: --- --- applyBasicAuth "user" "pass" $ fromJust $ parseUrl url - -applyBasicAuth :: S.ByteString -> S.ByteString -> Request m -> Request m -applyBasicAuth user passwd req = - req { requestHeaders = authHeader : requestHeaders req } - where - authHeader = (CI.mk "Authorization", basic) - basic = S8.append "Basic " (B64.encode $ S8.concat [ user, ":", passwd ]) - - --- | Add a proxy to the the Request so that the Request when executed will use --- the provided proxy. -addProxy :: S.ByteString -> Int -> Request m -> Request m -addProxy hst prt req = - req { proxy = Just $ Proxy hst prt } - - --- | 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 - - --- | Always decompress a compressed stream. -alwaysDecompress :: ContentType -> Bool -alwaysDecompress = const True - --- | Decompress a compressed stream unless the content-type is 'application/x-tar'. -browserDecompress :: ContentType -> Bool -browserDecompress = (/= "application/x-tar") - - --- | 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 req@(Request {..}) bodyStep m = - withConn m connhost connport requestEnum $$ getResponse req bodyStep - where - (useProxy, connhost, connport) = - case proxy of - Just p -> (True, S8.unpack (proxyHost p), proxyPort p) - Nothing -> (False, S8.unpack host, port) - withConn = - case (secure, useProxy) of - (False, _) -> withSocketConn - (True, False) -> withSslConn $ checkCerts host - (True, True) -> withSslProxyConn (checkCerts host) host port - (contentLength, bodyEnum) = - case requestBody of - RequestBodyLBS lbs -> (Just $ L.length lbs, enumSingle $ Blaze.fromLazyByteString lbs) - RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, enumSingle $ Blaze.fromByteString bs) - RequestBodyBuilder i b -> (Just $ i, enumSingle b) - RequestBodyEnum i enum -> (Just i, enum) - RequestBodyEnumChunked enum -> (Nothing, \step -> enum $$ joinI $ chunkIt step) - hh - | port == 80 && not secure = host - | port == 443 && secure = host - | otherwise = host `mappend` S8.pack (':' : show port) - contentLengthHeader (Just contentLength') = - if method `elem` ["GET", "HEAD"] && contentLength' == 0 - then id - else (:) ("Content-Length", S8.pack $ show contentLength') - contentLengthHeader Nothing = (:) ("Transfer-Encoding", "chunked") - headers' = ("Host", hh) - : (contentLengthHeader contentLength) - (("Accept-Encoding", "gzip") : requestHeaders) - requestHeaders' = - Blaze.fromByteString method - `mappend` Blaze.fromByteString " " - `mappend` - (if useProxy - then Blaze.fromByteString (if secure then "https://" else "http://") - `mappend` Blaze.fromByteString hh - else mempty) - `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 - -getResponse :: MonadIO m - => Request m - -> (W.Status -> [W.Header] -> Iteratee S8.ByteString m a) - -> Iteratee S8.ByteString m (Bool, a) -getResponse Request {..} bodyStep = 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' = - case (rawBody, ("transfer-encoding", "chunked") `elem` hs') of - (False, True) -> (chunkedEnumeratee =$) - (True , True) -> (chunkedTerminator =$) - (_ , False) -> case mcl >>= readMay . S8.unpack of - Just len -> (takeLBS len =$) - Nothing -> id - let decompresser = - if needsGunzip hs' - then (Z.ungzip =$) - else id - -- RFC 2616 section 4.4_1 defines responses that must not include a body - res <- - if hasNoBody method sc - then enumEOF $$ bodyStep s hs' - else body' $ decompresser $ do - x <- bodyStep s hs' - flushStream - return x - - -- should we put this connection back into the connection manager? - let toPut = Just "close" /= lookup "connection" hs' - return (toPut, res) - where - hasNoBody :: S8.ByteString -- ^ request method - -> Int -- ^ status code - -> Bool - hasNoBody "HEAD" _ = True - hasNoBody _ 204 = True - hasNoBody _ 304 = True - hasNoBody _ i = 100 <= i && i < 200 - - needsGunzip :: [W.Header] -> Bool - needsGunzip hs' = - not rawBody - && ("content-encoding", "gzip") `elem` hs' - && decompress (fromMaybe "" $ lookup "content-type" hs') - -flushStream :: Monad m => Iteratee a m () -flushStream = do - x <- EL.head - case x of - Nothing -> return () - Just _ -> flushStream - -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 - -chunkedTerminator :: MonadIO m => Enumeratee S.ByteString S.ByteString m a -chunkedTerminator (Continue k) = do - len <- catchParser "Chunk header" iterChunkHeader - k' <- sendCont k $ S8.pack $ showHex len "\r\n" - if len == 0 - then return k' - else do - step <- takeLBS len k' - catchParser "End of chunk newline" iterNewline - case step of - Continue k'' -> do - k''' <- sendCont k'' "\r\n" - chunkedTerminator k''' - _ -> return step -chunkedTerminator step = return step - -sendCont :: Monad m - => (Stream S8.ByteString -> Iteratee S8.ByteString m a) - -> S8.ByteString - -> Iteratee S8.ByteString m (Step S8.ByteString m a) -sendCont k bs = lift $ runIteratee $ k $ Chunks [bs] - -chunkIt :: Monad m => Enumeratee Blaze.Builder Blaze.Builder m a -chunkIt = checkDone $ continue . step - where - step k EOF = k (Chunks [chunkedTransferTerminator]) >>== return - step k (Chunks []) = continue $ step k - step k (Chunks xs) = k (Chunks [chunkedTransferEncoding $ mconcat xs]) - >>== chunkIt - - -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 :: Bool -> Char -> String -encodeUrlCharPI _ '/' = "/" -encodeUrlCharPI False '?' = "?" -encodeUrlCharPI False '&' = "&" -encodeUrlCharPI False '=' = "=" -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 - -defaultCheckCerts :: W.Ascii -> [X509] -> IO TLS.TLSCertificateUsage -defaultCheckCerts host' certs = - case certificateVerifyDomain (S8.unpack host') certs of - TLS.CertificateUsageAccept -> certificateVerifyChain certs - _ -> return TLS.CertificateUsageAccept - -instance Default (Request m) where - def = Request - { host = "localhost" - , port = 80 - , secure = False - , checkCerts = defaultCheckCerts - , requestHeaders = [] - , path = "/" - , queryString = [] - , requestBody = RequestBodyLBS L.empty - , method = "GET" - , proxy = Nothing - , rawBody = False - , decompress = alwaysDecompress - } - -parseUrl2 :: Failure HttpException m - => String -> Bool -> Bool -> String -> m (Request m') -parseUrl2 full sec parsePath s = do - port' <- mport - return def - { host = S8.pack hostname - , port = port' - , secure = sec - , path = S8.pack - $ if null path'' - then "/" - else concatMap (encodeUrlCharPI parsePath) path'' - , queryString = if parsePath - then W.parseQuery $ S8.pack qstring - else [] - } - 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' <- parseUrl url - Response sc _ b <- liftIO $ withManager $ httpLbsRedirect - $ url' { decompress = browserDecompress } - 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. -newtype Manager = Manager - { mConns :: I.IORef (Map ConnKey TLS.ConnInfo) - } - --- | ConnKey consists of a hostname, a port and a Bool specifying whether to --- use keepalive. -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 $ \manager -> do+-- > run_ $ httpRedirect request (\_ _ -> iterHandle handle) manager+--+-- 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+ , Proxy (..)+ , RequestBody (..)+ , Response (..)+ -- ** Request+ , Request+ , def+ , method+ , secure+ , checkCerts+ , host+ , port+ , path+ , queryString+ , requestHeaders+ , requestBody+ , proxy+ , rawBody+ , decompress+ -- *** Defaults+ , defaultCheckCerts+ -- * Manager+ , Manager+ , newManager+ , closeManager+ , withManager+ -- * Utility functions+ , parseUrl+ , applyBasicAuth+ , addProxy+ , semiParseUrl+ , lbsIter+ -- * Decompression predicates+ , alwaysDecompress+ , browserDecompress+ -- * 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, (>==>), (>>==), continue, checkDone, enumEOF+ , (=$)+ )+import qualified Data.Enumerator.List as EL+import Network.HTTP.Enumerator.HttpParser+import Control.Exception (Exception, bracket, throwIO, SomeException, try)+import Control.Arrow (first)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Class (lift)+import Control.Failure (Failure (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 Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)+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)+import qualified Data.ByteString.Base64 as B64+import System.IO (hClose, hFlush)+import Blaze.ByteString.Builder (toByteString)+import Data.Maybe (fromMaybe)+import Data.Default (Default (def))+import Numeric (showHex)+#if !MIN_VERSION_base(4,3,0)+import GHC.IO.Handle.Types+import System.IO (hWaitForInput, hIsEOF)+import System.IO.Error (mkIOError, illegalOperationErrorType)++-- | Like 'hGet', except that a shorter 'ByteString' may be returned+-- if there are not enough bytes immediately available to satisfy the+-- whole request. 'hGetSome' only blocks if there is no data+-- available, and EOF has not yet been reached.+--+hGetSome :: Handle -> Int -> IO S.ByteString+hGetSome hh i+ | i > 0 = let+ loop = do+ s <- S.hGetNonBlocking hh i+ if not (S.null s)+ then return s+ else do eof <- hIsEOF hh+ if eof then return s+ else hWaitForInput hh (-1) >> loop+ -- for this to work correctly, the+ -- Handle should be in binary mode+ -- (see GHC ticket #3808)+ in loop+ | i == 0 = return S.empty+ | otherwise = illegalBufferSize hh "hGetSome" i++illegalBufferSize :: Handle -> String -> Int -> IO a+illegalBufferSize handle fn sz =+ ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing)+ --TODO: System.IO uses InvalidArgument here, but it's not exported :-(+ where+ msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz []+#endif++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)+ ee <- try' $ NS.connect sock (NS.addrAddress addr)+ case ee of+ Left e -> NS.sClose sock >> throwIO e+ Right () -> return sock+ where+ try' :: IO a -> IO (Either SomeException a)+ try' = try++withSocketConn :: MonadIO m+ => Manager+ -> String+ -> Int+ -> Enumerator Blaze.Builder m ()+ -> Step S.ByteString m (Bool, a)+ -> Iteratee 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 ()+ -> Step S.ByteString m (Bool, a) -- ^ Bool indicates if the connection should go back in the manager+ -> Iteratee S.ByteString m a+withManagedConn man key open req step = do+ mci <- liftIO $ takeInsecureSocket man key+ (ci, isManaged) <-+ case mci of+ Nothing -> do+ ci <- liftIO open+ return (ci, False)+ Just ci -> return (ci, True)+ catchError+ (do+ (toPut, a) <- withCI ci req step+ liftIO $ if toPut+ then putInsecureSocket man key ci+ else TLS.connClose ci+ return a)+ (\se -> if isManaged+ then withManagedConn man key open req step+ else throwError se)++withSslConn :: MonadIO m+ => ([X509] -> IO TLS.TLSCertificateUsage)+ -> Manager+ -> String -- ^ host+ -> Int -- ^ port+ -> Enumerator Blaze.Builder m () -- ^ request+ -> Step S.ByteString m (Bool, a) -- ^ response+ -> Iteratee S.ByteString m a -- ^ response+withSslConn checkCert man host' port' =+ withManagedConn man (host', port', True) $+ (connectTo host' (PortNumber $ fromIntegral port') >>= TLS.sslClientConn checkCert)++withSslProxyConn :: MonadIO m+ => ([X509] -> IO TLS.TLSCertificateUsage)+ -> S8.ByteString -- ^ Target host+ -> Int -- ^ Target port+ -> Manager+ -> String -- ^ Proxy host+ -> Int -- ^ Proxy port+ -> Enumerator Blaze.Builder m () -- ^ request+ -> Step S.ByteString m (Bool, a) -- ^ response+ -> Iteratee S.ByteString m a -- ^ response+withSslProxyConn checkCert thost tport man phost pport =+ withManagedConn man (phost, pport, True) $+ doConnect >>= TLS.sslClientConn checkCert+ where+ doConnect = do+ h <- connectTo phost (PortNumber $ fromIntegral pport)+ S8.hPutStr h $ toByteString connectRequest+ hFlush h+#if MIN_VERSION_base(4,3,0)+ r <- S.hGetSome h 2048+#else+ r <- hGetSome h 2048+#endif+ res <- parserHeadersFromByteString r+ case res of+ Right ((_, 200, _), _) -> return h+ Right ((_, _, msg), _) -> hClose h >> proxyError (S8.unpack msg)+ Left s -> hClose h >> proxyError s++ connectRequest =+ Blaze.fromByteString "CONNECT "+ `mappend` Blaze.fromByteString thost+ `mappend` Blaze.fromByteString (S8.pack (':' : show tport))+ `mappend` Blaze.fromByteString " HTTP/1.1\r\n\r\n"+ proxyError s =+ error $ "Proxy failed to CONNECT to '"+ ++ S8.unpack thost ++ ":" ++ show tport ++ "' : " ++ s++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+++-- | Define a HTTP proxy, consisting of a hostname and port number.++data Proxy = Proxy+ { proxyHost :: W.Ascii -- ^ The host name of the HTTP proxy.+ , proxyPort :: Int -- ^ The port numner of the HTTP proxy.+ }++type ContentType = S.ByteString++-- | 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'.+--+-- The constructor for this data type is not exposed. Instead, you should use+-- either the 'def' method to retrieve a default instance, or 'parseUrl' to+-- construct from a URL, and then use the records below to make modifications.+-- This approach allows http-enumerator to add configuration options without+-- breaking backwards compatibility.+data Request m = Request+ { method :: W.Method -- ^ HTTP request method, eg GET, POST.+ , secure :: Bool -- ^ Whether to use HTTPS (ie, SSL).+ , checkCerts :: W.Ascii -> [X509] -> IO TLS.TLSCertificateUsage -- ^ 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+ , proxy :: Maybe Proxy -- ^ Optional HTTP proxy.+ , rawBody :: Bool -- ^ If True, a chunked and/or gzipped body will not be decoded. Use with caution.+ , decompress :: ContentType -> Bool -- ^ Predicate to specify whether gzipped data should be decompressed on the fly.+ }++-- | When using the 'RequestBodyEnum' constructor and any function which calls+-- 'redirectIter', you must ensure that the 'Enumerator' can be called multiple+-- times.+--+-- The 'RequestBodyEnumChunked' will send a chunked request body, note+-- that not all servers support this. Only use 'RequestBodyEnumChunked'+-- if you know the server you're sending to supports chunked request+-- bodies.+data RequestBody m+ = RequestBodyLBS L.ByteString+ | RequestBodyBS S.ByteString+ | RequestBodyBuilder Int64 Blaze.Builder+ | RequestBodyEnum Int64 (Enumerator Blaze.Builder m ())+ | RequestBodyEnumChunked (Enumerator Blaze.Builder m ())+++-- | Add a Basic Auth header (with the specified user name and password) to the+-- given Request. Ignore error handling:+--+-- applyBasicAuth "user" "pass" $ fromJust $ parseUrl url++applyBasicAuth :: S.ByteString -> S.ByteString -> Request m -> Request m+applyBasicAuth user passwd req =+ req { requestHeaders = authHeader : requestHeaders req }+ where+ authHeader = (CI.mk "Authorization", basic)+ basic = S8.append "Basic " (B64.encode $ S8.concat [ user, ":", passwd ])+++-- | Add a proxy to the the Request so that the Request when executed will use+-- the provided proxy.+addProxy :: S.ByteString -> Int -> Request m -> Request m+addProxy hst prt req =+ req { proxy = Just $ Proxy hst prt }+++-- | 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+++-- | Always decompress a compressed stream.+alwaysDecompress :: ContentType -> Bool+alwaysDecompress = const True++-- | Decompress a compressed stream unless the content-type is 'application/x-tar'.+browserDecompress :: ContentType -> Bool+browserDecompress = (/= "application/x-tar")+++-- | 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 req@(Request {..}) bodyStep m =+ withConn m connhost connport requestEnum $$ getResponse req bodyStep+ where+ (useProxy, connhost, connport) =+ case proxy of+ Just p -> (True, S8.unpack (proxyHost p), proxyPort p)+ Nothing -> (False, S8.unpack host, port)+ withConn =+ case (secure, useProxy) of+ (False, _) -> withSocketConn+ (True, False) -> withSslConn $ checkCerts host+ (True, True) -> withSslProxyConn (checkCerts host) host port+ (contentLength, bodyEnum) =+ case requestBody of+ RequestBodyLBS lbs -> (Just $ L.length lbs, enumSingle $ Blaze.fromLazyByteString lbs)+ RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, enumSingle $ Blaze.fromByteString bs)+ RequestBodyBuilder i b -> (Just $ i, enumSingle b)+ RequestBodyEnum i enum -> (Just i, enum)+ RequestBodyEnumChunked enum -> (Nothing, \step -> enum $$ joinI $ chunkIt step)+ hh+ | port == 80 && not secure = host+ | port == 443 && secure = host+ | otherwise = host `mappend` S8.pack (':' : show port)+ contentLengthHeader (Just contentLength') =+ if method `elem` ["GET", "HEAD"] && contentLength' == 0+ then id+ else (:) ("Content-Length", S8.pack $ show contentLength')+ contentLengthHeader Nothing = (:) ("Transfer-Encoding", "chunked")+ headers' = ("Host", hh)+ : (contentLengthHeader contentLength)+ (("Accept-Encoding", "gzip") : requestHeaders)+ requestHeaders' =+ Blaze.fromByteString method+ `mappend` Blaze.fromByteString " "+ `mappend`+ (if useProxy+ then Blaze.fromByteString (if secure then "https://" else "http://")+ `mappend` Blaze.fromByteString hh+ else mempty)+ `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++getResponse :: MonadIO m+ => Request m+ -> (W.Status -> [W.Header] -> Iteratee S8.ByteString m a)+ -> Iteratee S8.ByteString m (Bool, a)+getResponse Request {..} bodyStep = 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' =+ case (rawBody, ("transfer-encoding", "chunked") `elem` hs') of+ (False, True) -> (chunkedEnumeratee =$)+ (True , True) -> (chunkedTerminator =$)+ (_ , False) -> case mcl >>= readMay . S8.unpack of+ Just len -> (takeLBS len =$)+ Nothing -> id+ let decompresser =+ if needsGunzip hs'+ then (Z.ungzip =$)+ else id+ -- RFC 2616 section 4.4_1 defines responses that must not include a body+ res <-+ if hasNoBody method sc+ then enumEOF $$ bodyStep s hs'+ else body' $ decompresser $ do+ x <- bodyStep s hs'+ flushStream+ return x++ -- should we put this connection back into the connection manager?+ let toPut = Just "close" /= lookup "connection" hs'+ return (toPut, res)+ where+ hasNoBody :: S8.ByteString -- ^ request method+ -> Int -- ^ status code+ -> Bool+ hasNoBody "HEAD" _ = True+ hasNoBody _ 204 = True+ hasNoBody _ 304 = True+ hasNoBody _ i = 100 <= i && i < 200++ needsGunzip :: [W.Header] -> Bool+ needsGunzip hs' =+ not rawBody+ && ("content-encoding", "gzip") `elem` hs'+ && decompress (fromMaybe "" $ lookup "content-type" hs')++flushStream :: Monad m => Iteratee a m ()+flushStream = do+ x <- EL.head+ case x of+ Nothing -> return ()+ Just _ -> flushStream++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++chunkedTerminator :: MonadIO m => Enumeratee S.ByteString S.ByteString m a+chunkedTerminator (Continue k) = do+ len <- catchParser "Chunk header" iterChunkHeader+ k' <- sendCont k $ S8.pack $ showHex len "\r\n"+ if len == 0+ then return k'+ else do+ step <- takeLBS len k'+ catchParser "End of chunk newline" iterNewline+ case step of+ Continue k'' -> do+ k''' <- sendCont k'' "\r\n"+ chunkedTerminator k'''+ _ -> return step+chunkedTerminator step = return step++sendCont :: Monad m+ => (Stream S8.ByteString -> Iteratee S8.ByteString m a)+ -> S8.ByteString+ -> Iteratee S8.ByteString m (Step S8.ByteString m a)+sendCont k bs = lift $ runIteratee $ k $ Chunks [bs]++chunkIt :: Monad m => Enumeratee Blaze.Builder Blaze.Builder m a+chunkIt = checkDone $ continue . step+ where+ step k EOF = k (Chunks [chunkedTransferTerminator]) >>== return+ step k (Chunks []) = continue $ step k+ step k (Chunks xs) = k (Chunks [chunkedTransferEncoding $ mconcat xs])+ >>== chunkIt+++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 :: Bool -> Char -> String+encodeUrlCharPI _ '/' = "/"+encodeUrlCharPI False '?' = "?"+encodeUrlCharPI False '&' = "&"+encodeUrlCharPI False '=' = "="+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++defaultCheckCerts :: W.Ascii -> [X509] -> IO TLS.TLSCertificateUsage+defaultCheckCerts host' certs =+ case certificateVerifyDomain (S8.unpack host') certs of+ TLS.CertificateUsageAccept -> certificateVerifyChain certs+ _ -> return TLS.CertificateUsageAccept++instance Default (Request m) where+ def = Request+ { host = "localhost"+ , port = 80+ , secure = False+ , checkCerts = defaultCheckCerts+ , requestHeaders = []+ , path = "/"+ , queryString = []+ , requestBody = RequestBodyLBS L.empty+ , method = "GET"+ , proxy = Nothing+ , rawBody = False+ , decompress = alwaysDecompress+ }++parseUrl2 :: Failure HttpException m+ => String -> Bool -> Bool -> String -> m (Request m')+parseUrl2 full sec parsePath s = do+ port' <- mport+ return def+ { host = S8.pack hostname+ , port = port'+ , secure = sec+ , path = S8.pack+ $ if null path''+ then "/"+ else concatMap (encodeUrlCharPI parsePath) path''+ , queryString = if parsePath+ then W.parseQuery $ S8.pack qstring+ else []+ }+ 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' <- parseUrl url+ Response sc _ b <- liftIO $ withManager $ httpLbsRedirect+ $ url' { decompress = browserDecompress }+ 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.+newtype Manager = Manager+ { mConns :: I.IORef (Map ConnKey TLS.ConnInfo)+ }++-- | ConnKey consists of a hostname, a port and a Bool specifying whether to+-- use keepalive.+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,148 +1,148 @@-{-# LANGUAGE OverloadedStrings #-} -module Network.HTTP.Enumerator.HttpParser - ( iterHeaders - , iterChunkHeader - , iterNewline - , parserHeadersFromByteString - ) 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 - - -parserHeadersFromByteString :: Monad m => S.ByteString -> m (Either String (Status, [Header])) -parserHeadersFromByteString s = return $ parseOnly parseHeaders s - - -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+ , parserHeadersFromByteString+ ) 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+++parserHeadersFromByteString :: Monad m => S.ByteString -> m (Either String (Status, [Header]))+parserHeadersFromByteString s = return $ parseOnly parseHeaders s+++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,86 +1,86 @@-{-# LANGUAGE ScopedTypeVariables #-} -module Network.TLS.Client.Enumerator - ( ConnInfo - , connClose - , connIter - , connEnum - , sslClientConn - , socketConn - , TLSCertificateRejectReason(..) - , TLSCertificateUsage(..) - ) 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) -import Control.Monad.Trans.Class (lift) -import Data.Enumerator - ( Iteratee (..), Enumerator, Step (..), Stream (..), continue, returnI - , tryIO - ) -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 - tryIO $ write bss - continue go - -connEnum :: MonadIO m => ConnInfo -> Enumerator ByteString m b -connEnum ConnInfo { connRead = read' } = - go - where - go (Continue k) = do - bs <- tryIO 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 TLSCertificateUsage) -> Handle -> IO ConnInfo -sslClientConn onCerts h = do - let tcp = defaultParams - { pConnectVersion = TLS10 - , pAllowedVersions = [ TLS10, TLS11 ] - , pCiphers = ciphersuite_all - , onCertificatesRecv = onCerts - } - gen <- makeSystem - istate <- client tcp gen h - _ <- handshake istate - return ConnInfo - { connRead = recvD istate - , connWrite = sendData istate . L.fromChunks - , connClose = bye istate >> hClose h - } - where - recvD istate = do - x <- 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+ , TLSCertificateRejectReason(..)+ , TLSCertificateUsage(..)+ ) 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)+import Control.Monad.Trans.Class (lift)+import Data.Enumerator+ ( Iteratee (..), Enumerator, Step (..), Stream (..), continue, returnI+ , tryIO+ )+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+ tryIO $ write bss+ continue go++connEnum :: MonadIO m => ConnInfo -> Enumerator ByteString m b+connEnum ConnInfo { connRead = read' } =+ go+ where+ go (Continue k) = do+ bs <- tryIO 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 TLSCertificateUsage) -> Handle -> IO ConnInfo+sslClientConn onCerts h = do+ let tcp = defaultParams+ { pConnectVersion = TLS10+ , pAllowedVersions = [ TLS10, TLS11 ]+ , pCiphers = ciphersuite_all+ , onCertificatesRecv = onCerts+ }+ gen <- makeSystem+ istate <- client tcp gen h+ _ <- handshake istate+ return ConnInfo+ { connRead = recvD istate+ , connWrite = sendData istate . L.fromChunks+ , connClose = bye istate >> hClose h+ }+ where+ recvD istate = do+ x <- 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,64 +1,64 @@-name: http-enumerator -version: 0.7.1.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. It also provides higher-level functions which allow you to avoid direct usage of enumerators. -category: Web, Enumerator -stability: Stable -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.9 && < 0.5 - , attoparsec >= 0.8.0.2 && < 0.10 - , attoparsec-enumerator >= 0.2.0.4 && < 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.8.1 && < 0.9 - , tls-extra >= 0.3 && < 0.5 - , monad-control >= 0.2 && < 0.3 - , containers >= 0.2 && < 0.5 - , certificate >= 0.7 && < 1.1 - , case-insensitive >= 0.2 && < 0.4 - , base64-bytestring >= 0.1 && < 0.2 - , asn1-data >= 0.5.1 && < 0.7 - , data-default >= 0.3 && < 0.4 - 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.7.1.5+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. It also provides higher-level functions which allow you to avoid direct usage of enumerators.+category: Web, Enumerator+stability: Stable+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.9 && < 0.5+ , attoparsec >= 0.8.0.2 && < 0.11+ , attoparsec-enumerator >= 0.2.0.4 && < 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.8.1 && < 0.9+ , tls-extra >= 0.3 && < 0.5+ , monad-control >= 0.2 && < 0.3+ , containers >= 0.2+ , certificate >= 0.7 && < 1.1+ , case-insensitive >= 0.2+ , base64-bytestring >= 0.1 && < 0.2+ , asn1-data >= 0.5.1 && < 0.7+ , data-default >= 0.3 && < 0.4+ 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