diff --git a/Network/HTTP/Enumerator.hs b/Network/HTTP/Enumerator.hs --- a/Network/HTTP/Enumerator.hs +++ b/Network/HTTP/Enumerator.hs @@ -22,11 +22,12 @@ -- > 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/" --- > run_ $ httpRedirect request (\_ _ -> iterHandle handle) +-- > 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': @@ -58,9 +59,26 @@ , httpRedirect , redirectIter -- * Datatypes - , Request (..) + , Proxy (..) , RequestBody (..) , Response (..) + -- ** Request + , Request + , def + , method + , secure + , checkCerts + , host + , port + , path + , queryString + , requestHeaders + , requestBody + , proxy + , rawBody + , decompress + -- *** Defaults + , defaultCheckCerts -- * Manager , Manager , newManager @@ -68,7 +86,13 @@ , withManager -- * Utility functions , parseUrl + , applyBasicAuth + , addProxy + , semiParseUrl , lbsIter + -- * Decompression predicates + , alwaysDecompress + , browserDecompress -- * Request bodies , urlEncodedBody -- * Exceptions @@ -85,31 +109,81 @@ import Data.Enumerator ( Iteratee (..), Stream (..), catchError, throwError , yield, Step (..), Enumeratee, ($$), joinI, Enumerator, run_ - , returnI, (>==>) + , returnI, (>==>), (>>==), continue, checkDone, enumEOF + , (=$) ) import qualified Data.Enumerator.List as EL import Network.HTTP.Enumerator.HttpParser -import Control.Exception (Exception, bracket) +import Control.Exception + ( Exception, bracket, throwIO, SomeException, try + , fromException + ) import Control.Arrow (first) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (lift) -import Control.Failure +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 +#if MIN_VERSION_monad_control(0,3,0) +import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp) +#else import Control.Monad.IO.Control (MonadControlIO, liftIOOp) +#endif 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 { @@ -119,44 +193,112 @@ (addr:_) <- NS.getAddrInfo (Just hints) (Just host') (Just $ show port') sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) (NS.addrProtocol addr) - NS.connect sock (NS.addrAddress addr) - return sock + 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 () - -> Enumerator S.ByteString m a + -> 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' +checkReset :: SomeException -> Bool +checkReset e = isReset || isIOReset + where isReset = case fromException e of + Just TLS.ConnectionReset -> True + _ -> False + isIOReset = show e == "recv: resource vanished (Connection reset by peer)" + withManagedConn :: MonadIO m => Manager -> ConnKey -> IO TLS.ConnInfo -> Enumerator Blaze.Builder m () - -> Enumerator S.ByteString m a + -> 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 - ci <- liftIO $ takeInsecureSocket man key - >>= maybe (liftIO open) return - a <- withCI ci req step - liftIO $ putInsecureSocket man key ci - return a + 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 -> liftIO (TLS.connClose ci) >> + liftIO (putStrLn $ "Error during enum: " ++ show se) >> + if checkReset se && isManaged + then withManagedConn man key open req step + else throwError se + ) withSslConn :: MonadIO m - => ([X509] -> IO Bool) + => ([X509] -> IO TLS.TLSCertificateUsage) -> Manager -> String -- ^ host -> Int -- ^ port -> Enumerator Blaze.Builder m () -- ^ request - -> Enumerator S.ByteString m a -- ^ response + -> 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 @@ -164,31 +306,77 @@ -- 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 :: [X509] -> IO Bool -- ^ Check if the server certificate is valid. Only relevant for HTTPS. + , 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 @@ -201,13 +389,23 @@ 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 second argument to this function gives a full specification on the +-- 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 first argument specifies how the response should be handled. It's a +-- 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. @@ -221,29 +419,46 @@ -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) -> Manager -> Iteratee S.ByteString m a -http Request {..} bodyStep m = do - let h' = S8.unpack host - let withConn = if secure then withSslConn checkCerts else withSocketConn - withConn m h' port requestEnum $$ go +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 -> (L.length lbs, enumSingle $ Blaze.fromLazyByteString lbs) - RequestBodyBS bs -> (fromIntegral $ S.length bs, enumSingle $ Blaze.fromByteString bs) - RequestBodyBuilder i b -> (i, enumSingle b) - RequestBodyEnum i enum -> (i, enum) + 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) - : ("Content-Length", S8.pack $ show contentLength) - : ("Accept-Encoding", "gzip") - : requestHeaders + : (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 "/" @@ -259,25 +474,61 @@ `mappend` Blaze.fromByteString "\r\n") `mappend` Blaze.fromByteString "\r\n" requestEnum = enumSingle requestHeaders' >==> bodyEnum - go = do - ((_, sc, sm), hs) <- iterHeaders - let s = W.Status sc sm - let hs' = map (first CI.mk) hs - let mcl = lookup "content-length" hs' - let body' x = - if ("transfer-encoding", "chunked") `elem` hs' - then joinI $ chunkedEnumeratee $$ x - else case mcl >>= readMay . S8.unpack of - Just len -> joinI $ takeLBS len $$ x - Nothing -> x - let decompress x = - if ("content-encoding", "gzip") `elem` hs' - then joinI $ Z.ungzip x - else returnI x - if method == "HEAD" - then bodyStep s hs' - else body' $ decompress $$ bodyStep s hs' +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 @@ -289,6 +540,37 @@ 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 @@ -309,9 +591,12 @@ else takeLBS len' step' takeLBS _ step = return step -encodeUrlCharPI :: Char -> String -encodeUrlCharPI '/' = "/" -encodeUrlCharPI c = encodeUrlChar c +encodeUrlCharPI :: Bool -> Char -> String +encodeUrlCharPI _ '/' = "/" +encodeUrlCharPI False '?' = "?" +encodeUrlCharPI False '&' = "&" +encodeUrlCharPI False '=' = "=" +encodeUrlCharPI _ c = encodeUrlChar c encodeUrlChar :: Char -> String encodeUrlChar c @@ -324,7 +609,6 @@ encodeUrlChar c@'_' = [c] encodeUrlChar c@'.' = [c] encodeUrlChar c@'~' = [c] -encodeUrlChar ' ' = "+" encodeUrlChar y = let (a, c) = fromEnum y `divMod` 16 b = a `mod` 16 @@ -341,38 +625,67 @@ -- -- 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 => W.Ascii -> m (Request m') -parseUrl = parseUrlS . S8.unpack +parseUrl :: Failure HttpException m => String -> m (Request m') +parseUrl = parseUrlHelper True -parseUrlS :: Failure HttpException m => String -> m (Request m') -parseUrlS s@('h':'t':'t':'p':':':'/':'/':rest) = parseUrl1 s False rest -parseUrlS s@('h':'t':'t':'p':'s':':':'/':'/':rest) = parseUrl1 s True rest -parseUrlS x = failure $ InvalidUrlException x "Invalid scheme" +-- | 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 -> String -> m (Request m') -parseUrl1 full sec s = - parseUrl2 full sec s' + => 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 + rejected -> return rejected + +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 -> String -> m (Request m') -parseUrl2 full sec s = do + => String -> Bool -> Bool -> String -> m (Request m') +parseUrl2 full sec parsePath s = do port' <- mport - return Request + return def { host = S8.pack hostname , port = port' , secure = sec - , checkCerts = const $ return True - , requestHeaders = [] , path = S8.pack - $ if null path' + $ (if null path' then "/" - else concatMap encodeUrlCharPI path' - , queryString = W.parseQuery $ S8.pack qstring - , requestBody = RequestBodyLBS L.empty - , method = "GET" + else concatMap (encodeUrlCharPI parsePath) path') + ++ + (if parsePath then "" else qstring') + , queryString = if parsePath + then W.parseQuery $ S8.pack qstring + else [] } where (beforeSlash, afterSlash) = break (== '/') s @@ -415,22 +728,33 @@ -- -- 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 +-- This function will 'throwIO' an 'HttpException' for any response with a -- non-2xx status code. It uses 'parseUrl' to parse the input. This function -- essentially wraps 'httpLbsRedirect'. -simpleHttp :: (MonadIO m, Failure HttpException m) => W.Ascii -> m L.ByteString +-- +-- 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 => String -> m L.ByteString simpleHttp url = do - url' <- parseUrl url - Response sc _ b <- liftIO $ withManager $ httpLbsRedirect url' + url' <- liftIO $ parseUrl url + Response sc _ b <- liftIO $ withManager $ httpLbsRedirect + $ url' { decompress = browserDecompress } if 200 <= sc && sc < 300 then return b - else failure $ StatusCodeException sc b + else liftIO $ throwIO $ StatusCodeException sc b data HttpException = StatusCodeException Int L.ByteString | InvalidUrlException String String @@ -442,7 +766,7 @@ -- | Same as 'http', but follows all 3xx redirect status codes that contain a -- location header. httpRedirect - :: (MonadIO m, Failure HttpException m) + :: MonadIO m => Request m -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) -> Manager @@ -453,7 +777,7 @@ -- | Make a request automatically follow 3xx redirects. -- -- Used internally by 'httpRedirect' and family. -redirectIter :: (MonadIO m, Failure HttpException m) +redirectIter :: MonadIO m => Int -- ^ number of redirects to attempt -> Request m -- ^ Original request -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) @@ -476,7 +800,7 @@ , S8.unpack l'' ] _ -> S8.unpack l'' - l <- lift $ parseUrlS l' + l <- liftIO $ parseUrl l' let req' = req { host = host l , port = port l @@ -489,7 +813,7 @@ else method l } if redirects == 0 - then lift $ failure TooManyRedirects + then liftIO $ throwIO TooManyRedirects else (http req') (redirectIter (redirects - 1) req' bodyStep manager) manager Nothing -> bodyStep s hs | otherwise = bodyStep s hs @@ -506,7 +830,12 @@ -- -- Please see 'lbsIter' for more information on how the 'Response' value is -- created. -httpLbsRedirect :: (MonadIO m, Failure HttpException m) => Request m -> Manager -> m Response +-- +-- 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 => Request m -> Manager -> m Response httpLbsRedirect req = run_ . httpRedirect req lbsIter readMay :: Read a => String -> Maybe a @@ -536,10 +865,12 @@ catchParser s i = catchError i (const $ throwError $ HttpParserException s) -- | Keeps track of open connections for keep-alive. -data Manager = Manager +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) @@ -567,5 +898,10 @@ mapM_ TLS.connClose $ Map.elems m -- | Create a new 'Manager', call the supplied function and then close it. +#if MIN_VERSION_monad_control(0,3,0) +withManager :: MonadBaseControl IO m => (Manager -> m a) -> m a +withManager = liftBaseOp $ bracket newManager closeManager +#else withManager :: MonadControlIO m => (Manager -> m a) -> m a withManager = liftIOOp $ bracket newManager closeManager +#endif 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 @@ -3,6 +3,7 @@ ( iterHeaders , iterChunkHeader , iterNewline + , parserHeadersFromByteString ) where import Prelude hiding (take, takeWhile) @@ -13,6 +14,7 @@ import qualified Data.ByteString.Char8 as S8 import Control.Applicative import Data.Word (Word8) +import Control.Monad (when) type Header = (S.ByteString, S.ByteString) @@ -56,11 +58,18 @@ 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/" + end <- atEnd + when end $ fail "EOF reached" + _ <- manyTill (take 1 >> return ()) (try $ string "HTTP/") "HTTP/" ver <- takeWhile1 $ not . isSpace _ <- word8 32 -- space statCode <- takeWhile1 $ not . isSpace 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,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} module Network.TLS.Client.Enumerator ( ConnInfo , connClose @@ -5,21 +7,29 @@ , connEnum , sslClientConn , socketConn + , TLSCertificateRejectReason(..) + , TLSCertificateUsage(..) + , ConnectionReset (..) ) where import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import Data.Typeable (Typeable) +import Control.Exception (Exception) import System.IO (Handle, hClose) import Network.Socket (Socket, sClose) import Network.Socket.ByteString (recv, sendAll) import Network.TLS -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import Data.Enumerator ( Iteratee (..), Enumerator, Step (..), Stream (..), continue, returnI + , tryIO, throwError ) import Data.Certificate.X509 (X509) +import Network.TLS.Extra (ciphersuite_all) +import Crypto.Random.AESCtr (makeSystem) data ConnInfo = ConnInfo { connRead :: IO [ByteString] @@ -27,13 +37,17 @@ , connClose :: IO () } +data ConnectionReset = ConnectionReset + deriving (Show,Typeable) +instance Exception ConnectionReset + connIter :: MonadIO m => ConnInfo -> Iteratee ByteString m () connIter ConnInfo { connWrite = write } = continue go where go EOF = return () go (Chunks bss) = do - liftIO $ write bss + tryIO $ write bss continue go connEnum :: MonadIO m => ConnInfo -> Enumerator ByteString m b @@ -41,7 +55,7 @@ go where go (Continue k) = do - bs <- liftIO read' + bs <- tryIO read' if all S.null bs then continue k else do @@ -56,32 +70,25 @@ , connClose = sClose sock } -sslClientConn :: ([X509] -> IO Bool) -> Handle -> IO ConnInfo +sslClientConn :: ([X509] -> IO TLSCertificateUsage) -> Handle -> IO ConnInfo sslClientConn onCerts h = do let tcp = defaultParams { pConnectVersion = TLS10 , pAllowedVersions = [ TLS10, TLS11 ] - , pCiphers = ciphers + , pCiphers = ciphersuite_all , onCertificatesRecv = onCerts } - esrand <- liftIO makeSRandomGen - let srg = either (error . show) id esrand - istate <- liftIO $ client tcp srg h - liftIO $ handshake istate + gen <- makeSystem + istate <- client tcp gen h + handshake istate return ConnInfo { connRead = recvD istate - , connWrite = liftIO . sendData istate . L.fromChunks - , connClose = liftIO $ bye istate >> hClose h + , connWrite = sendData istate . L.fromChunks + , connClose = bye istate >> hClose h } where recvD istate = do - x <- liftIO $ recvData istate - if L.null x + x <- recvData istate + if S.null x then recvD istate - else return $ L.toChunks x - ciphers = - [ cipher_AES128_SHA1 - , cipher_AES256_SHA1 - , cipher_RC4_128_MD5 - , cipher_RC4_128_SHA1 - ] + else return [x] diff --git a/http-enumerator.cabal b/http-enumerator.cabal --- a/http-enumerator.cabal +++ b/http-enumerator.cabal @@ -1,14 +1,14 @@ name: http-enumerator -version: 0.5.1 +version: 0.7.3.3 license: BSD3 license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman -synopsis: HTTP client package with enumerator interface and HTTPS support. +synopsis: HTTP client package with enumerator interface and HTTPS support. (deprecated) description: - This package uses attoparsec for parsing the actual contents of the HTTP connection. The only gotcha is the withHttpEnumerator function, otherwise should do exactly what you expect. + This package has been deprecated in favor of http-conduit (), which provides a more powerful and simpler interface. The API is very similar, and migrating should not be problematic. Send concerns about this move to the maintainer (address listed above). category: Web, Enumerator -stability: Experimental +stability: Stable cabal-version: >= 1.6 build-type: Simple homepage: http://github.com/snoyberg/http-enumerator @@ -17,25 +17,31 @@ description: Build the test executable. default: False flag network-bytestring + default: False library build-depends: base >= 4 && < 5 , bytestring >= 0.9.1.4 && < 0.10 - , transformers >= 0.2 && < 0.3 - , failure >= 0.1 && < 0.2 - , enumerator >= 0.4.7 && < 0.5 - , attoparsec >= 0.8.0.2 && < 0.9 - , attoparsec-enumerator >= 0.2 && < 0.3 + , transformers >= 0.2 && < 0.4 + , failure >= 0.1 && < 0.3 + , enumerator >= 0.4.9 && < 0.5 + , attoparsec >= 0.8.0.2 && < 0.11 + , attoparsec-enumerator >= 0.2.0.4 && < 0.4 , utf8-string >= 0.3.4 && < 0.4 , blaze-builder >= 0.2.1 && < 0.4 , zlib-enum >= 0.2 && < 0.3 , http-types >= 0.6 && < 0.7 , blaze-builder-enumerator >= 0.2 && < 0.3 - , tls >= 0.4 && < 0.5 - , monad-control >= 0.2 && < 0.3 - , containers >= 0.2 && < 0.5 - , certificate >= 0.7 && < 0.8 - , case-insensitive >= 0.2 && < 0.3 + , cprng-aes >= 0.2 && < 0.3 + , tls >= 0.9 && < 0.10 + , tls-extra >= 0.4.3 && < 0.5 + , monad-control >= 0.2 && < 0.4 + , containers >= 0.2 + , certificate >= 1.1 && < 1.2 + , case-insensitive >= 0.2 + , base64-bytestring >= 0.1 && < 0.2 + , asn1-data >= 0.5.1 && < 0.7 + , data-default >= 0.3 && < 0.5 if flag(network-bytestring) build-depends: network >= 2.2.1 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4 diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -11,7 +11,7 @@ main :: IO () main = withSocketsDo $ do [url] <- getArgs - _req2 <- parseUrl $ S8.pack url + _req2 <- parseUrl url {- let req = urlEncodedBody [ ("foo", "bar")