diff --git a/Network/HTTP/Enumerator.hs b/Network/HTTP/Enumerator.hs --- a/Network/HTTP/Enumerator.hs +++ b/Network/HTTP/Enumerator.hs @@ -60,9 +60,25 @@ , redirectIter -- * Datatypes , Proxy (..) - , Request (..) , RequestBody (..) , Response (..) + -- ** Request + , Request + , def + , method + , secure + , checkCerts + , host + , port + , path + , queryString + , requestHeaders + , requestBody + , proxy + , rawBody + , decompress + -- *** Defaults + , defaultCheckCerts -- * Manager , Manager , newManager @@ -93,11 +109,15 @@ import Data.Enumerator ( Iteratee (..), Stream (..), catchError, throwError , yield, Step (..), Enumeratee, ($$), joinI, Enumerator, run_ - , returnI, (>==>), enumEOF + , 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.Exception + ( Exception, bracket, throwIO, SomeException, try + , fromException + ) import Control.Arrow (first) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (lift) @@ -106,12 +126,17 @@ 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 @@ -122,6 +147,8 @@ 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) @@ -185,6 +212,13 @@ 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 @@ -208,9 +242,12 @@ then putInsecureSocket man key ci else TLS.connClose ci return a) - (\se -> if isManaged - then withManagedConn man key open req step - else throwError se) + (\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 TLS.TLSCertificateUsage) @@ -283,10 +320,16 @@ -- 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 TLS.TLSCertificateUsage -- ^ 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. @@ -301,17 +344,23 @@ -- | 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 \"user\" \"pass\" $ fromJust $ parseUrl url applyBasicAuth :: S.ByteString -> S.ByteString -> Request m -> Request m applyBasicAuth user passwd req = @@ -370,8 +419,8 @@ -> (W.Status -> W.ResponseHeaders -> Iteratee S.ByteString m a) -> Manager -> Iteratee S.ByteString m a -http Request {..} bodyStep m = do - withConn m connhost connport requestEnum $$ go +http req@(Request {..}) bodyStep m = + withConn m connhost connport requestEnum $$ getResponse req bodyStep where (useProxy, connhost, connport) = case proxy of @@ -380,22 +429,26 @@ withConn = case (secure, useProxy) of (False, _) -> withSocketConn - (True, False) -> withSslConn checkCerts - (True, True) -> withSslProxyConn checkCerts host port + (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) - : (if method `elem` ["GET", "HEAD"] && contentLength == 0 - then id - else (:) ("Content-Length", S8.pack $ show contentLength)) + : (contentLengthHeader contentLength) (("Accept-Encoding", "gzip") : requestHeaders) requestHeaders' = Blaze.fromByteString method @@ -421,36 +474,54 @@ `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 not rawBody && ("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 decompresser x = - if not rawBody - && ("content-encoding", "gzip") `elem` hs' - && decompress (fromMaybe "" $ lookup "content-type" hs') - then joinI $ Z.ungzip x - else returnI x - -- RFC 2616 section 4.4_1 defines responses that must not include a body - res <- - if method == "HEAD" || sc == 204 -- No Content - || sc == 304 -- Not Modified - || (sc < 200 && sc >= 100) - then enumEOF $$ bodyStep s hs' - else body' $ decompresser $$ do - x <- bodyStep s hs' - flushStream - return x - let toPut = Just "close" /= lookup "connection" hs' - return (toPut, res) +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 @@ -469,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 @@ -507,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 @@ -546,37 +647,50 @@ 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 -> 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 = \x -> - case certificateVerifyDomain hostname x of - TLS.CertificateUsageAccept -> certificateVerifyChain x - _ -> return TLS.CertificateUsageAccept - , requestHeaders = [] , path = S8.pack - $ if null path'' + $ (if null path' then "/" - else concatMap (encodeUrlCharPI parsePath) path'' + else concatMap (encodeUrlCharPI parsePath) path') + ++ + (if parsePath then "" else qstring') , queryString = if parsePath then W.parseQuery $ S8.pack qstring else [] - , requestBody = RequestBodyLBS L.empty - , method = "GET" - , proxy = Nothing - , rawBody = False - , decompress = alwaysDecompress } 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' @@ -625,7 +739,7 @@ -- | 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'. -- @@ -633,14 +747,14 @@ -- 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 :: MonadIO m => String -> m L.ByteString simpleHttp url = do - url' <- parseUrl 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 @@ -652,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 @@ -663,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) @@ -686,7 +800,7 @@ , S8.unpack l'' ] _ -> S8.unpack l'' - l <- lift $ parseUrl l' + l <- liftIO $ parseUrl l' let req' = req { host = host l , port = port l @@ -699,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 @@ -721,7 +835,7 @@ -- /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 :: MonadIO m => Request m -> Manager -> m Response httpLbsRedirect req = run_ . httpRedirect req lbsIter readMay :: Read a => String -> Maybe a @@ -784,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 @@ -14,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) @@ -66,7 +67,9 @@ 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,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} module Network.TLS.Client.Enumerator ( ConnInfo , connClose @@ -8,11 +9,14 @@ , 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) @@ -21,7 +25,7 @@ import Control.Monad.Trans.Class (lift) import Data.Enumerator ( Iteratee (..), Enumerator, Step (..), Stream (..), continue, returnI - , tryIO + , tryIO, throwError ) import Data.Certificate.X509 (X509) import Network.TLS.Extra (ciphersuite_all) @@ -33,6 +37,10 @@ , connClose :: IO () } +data ConnectionReset = ConnectionReset + deriving (Show,Typeable) +instance Exception ConnectionReset + connIter :: MonadIO m => ConnInfo -> Iteratee ByteString m () connIter ConnInfo { connWrite = write } = continue go @@ -72,7 +80,7 @@ } gen <- makeSystem istate <- client tcp gen h - _ <- handshake istate + handshake istate return ConnInfo { connRead = recvD istate , connWrite = sendData istate . L.fromChunks @@ -81,6 +89,6 @@ where recvD istate = do x <- recvData istate - if L.null x + if S.null x then recvD istate - else return $ L.toChunks x + 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.6.7 +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 @@ -22,25 +22,26 @@ library build-depends: base >= 4 && < 5 , bytestring >= 0.9.1.4 && < 0.10 - , transformers >= 0.2 && < 0.3 - , failure >= 0.1 && < 0.2 + , transformers >= 0.2 && < 0.4 + , failure >= 0.1 && < 0.3 , enumerator >= 0.4.9 && < 0.5 - , attoparsec >= 0.8.0.2 && < 0.10 - , attoparsec-enumerator >= 0.2.0.4 && < 0.3 + , 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 , cprng-aes >= 0.2 && < 0.3 - , tls >= 0.7 && < 0.8 - , tls-extra >= 0.3 && < 0.4 - , monad-control >= 0.2 && < 0.3 - , containers >= 0.2 && < 0.5 - , certificate >= 0.7 && < 0.10 - , case-insensitive >= 0.2 && < 0.4 + , 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.6 + , 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