http-enumerator 0.5.1 → 0.7.3.3
raw patch · 5 files changed
Files
- Network/HTTP/Enumerator.hs +419/−83
- Network/HTTP/Enumerator/HttpParser.hs +10/−1
- Network/TLS/Client/Enumerator.hs +27/−20
- http-enumerator.cabal +20/−14
- test.hs +1/−1
Network/HTTP/Enumerator.hs view
@@ -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
Network/HTTP/Enumerator/HttpParser.hs view
@@ -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
Network/TLS/Client/Enumerator.hs view
@@ -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]
http-enumerator.cabal view
@@ -1,14 +1,14 @@ name: http-enumerator-version: 0.5.1+version: 0.7.3.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com>-synopsis: HTTP client package with enumerator interface and HTTPS support.+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 (<http://hackage.haskell.org/package/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
test.hs view
@@ -11,7 +11,7 @@ main :: IO () main = withSocketsDo $ do [url] <- getArgs- _req2 <- parseUrl $ S8.pack url+ _req2 <- parseUrl url {- let req = urlEncodedBody [ ("foo", "bar")