diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,25 +1,25 @@ -The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright 2010, Michael Snoyman. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO -EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, -OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/HTTP/Enumerator.hs b/Network/HTTP/Enumerator.hs --- a/Network/HTTP/Enumerator.hs +++ b/Network/HTTP/Enumerator.hs @@ -1,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 diff --git a/Network/HTTP/Enumerator/HttpParser.hs b/Network/HTTP/Enumerator/HttpParser.hs --- a/Network/HTTP/Enumerator/HttpParser.hs +++ b/Network/HTTP/Enumerator/HttpParser.hs @@ -1,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) +-} diff --git a/Network/TLS/Client/Enumerator.hs b/Network/TLS/Client/Enumerator.hs --- a/Network/TLS/Client/Enumerator.hs +++ b/Network/TLS/Client/Enumerator.hs @@ -1,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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,8 +1,8 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple -> import System.Cmd (system) - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMain diff --git a/http-enumerator.cabal b/http-enumerator.cabal --- a/http-enumerator.cabal +++ b/http-enumerator.cabal @@ -1,64 +1,64 @@ -name: http-enumerator -version: 0.7.1.4 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman -maintainer: Michael Snoyman -synopsis: HTTP client package with enumerator interface and HTTPS support. -description: - This package uses attoparsec for parsing the actual contents of the HTTP connection. 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 +maintainer: Michael Snoyman +synopsis: HTTP client package with enumerator interface and HTTPS support. +description: + This package uses attoparsec for parsing the actual contents of the HTTP connection. 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 diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -1,33 +1,33 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -import Network.HTTP.Enumerator -import Network -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import System.Environment.UTF8 (getArgs) -import Data.CaseInsensitive (original) - -main :: IO () -main = withSocketsDo $ do - [url] <- getArgs - _req2 <- parseUrl url - {- - let req = urlEncodedBody - [ ("foo", "bar") - , ("baz%%38**.8fn", "bin") - ] _req2 - -} - Response sc hs b <- withManager $ httpLbsRedirect _req2 -#if DEBUG - return () -#else - print sc - mapM_ (\(x, y) -> do - S.putStr $ original x - putStr ": " - S.putStr y - putStrLn "") hs - putStrLn "" - L.putStr b -#endif +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +import Network.HTTP.Enumerator +import Network +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import System.Environment.UTF8 (getArgs) +import Data.CaseInsensitive (original) + +main :: IO () +main = withSocketsDo $ do + [url] <- getArgs + _req2 <- parseUrl url + {- + let req = urlEncodedBody + [ ("foo", "bar") + , ("baz%%38**.8fn", "bin") + ] _req2 + -} + Response sc hs b <- withManager $ httpLbsRedirect _req2 +#if DEBUG + return () +#else + print sc + mapM_ (\(x, y) -> do + S.putStr $ original x + putStr ": " + S.putStr y + putStrLn "") hs + putStrLn "" + L.putStr b +#endif