diff --git a/Network/HTTP/Enumerator.hs b/Network/HTTP/Enumerator.hs --- a/Network/HTTP/Enumerator.hs +++ b/Network/HTTP/Enumerator.hs @@ -118,7 +118,41 @@ import qualified Data.ByteString.Base64 as B64 import System.IO (hClose, hFlush) import Blaze.ByteString.Builder (toByteString) +#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 { @@ -141,7 +175,8 @@ -> 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' @@ -152,13 +187,26 @@ -> 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 -> if isManaged + then withManagedConn man key open req step + else throwError se) withSslConn :: MonadIO m => ([X509] -> IO TLS.TLSCertificateUsage) @@ -166,7 +214,8 @@ -> 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) @@ -179,7 +228,8 @@ -> String -- ^ Proxy host -> Int -- ^ Proxy 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 withSslProxyConn checkCert thost tport man phost pport = withManagedConn man (phost, pport, True) $ doConnect >>= TLS.sslClientConn checkCert @@ -188,7 +238,11 @@ 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 @@ -365,12 +419,18 @@ if not rawBody && ("content-encoding", "gzip") `elem` hs' then joinI $ Z.ungzip x else returnI x - if method == "HEAD" - then bodyStep s hs' - else body' $ decompress $$ do - x <- bodyStep s hs' - flushStream - return 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 bodyStep s hs' + else body' $ decompress $$ do + x <- bodyStep s hs' + flushStream + return x + let toPut = Just "close" /= lookup "connection" hs' + return (toPut, res) flushStream :: Monad m => Iteratee a m () flushStream = do @@ -670,7 +730,7 @@ 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) } 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 @@ -17,10 +17,11 @@ 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 ) import Data.Certificate.X509 (X509) import Network.TLS.Extra (ciphersuite_all) @@ -38,7 +39,7 @@ where go EOF = return () go (Chunks bss) = do - liftIO $ write bss + tryIO $ write bss continue go connEnum :: MonadIO m => ConnInfo -> Enumerator ByteString m b @@ -46,7 +47,7 @@ go where go (Continue k) = do - bs <- liftIO read' + bs <- tryIO read' if all S.null bs then continue k else do @@ -70,16 +71,16 @@ , onCertificatesRecv = onCerts } gen <- makeSystem - istate <- liftIO $ client tcp gen h - _ <- liftIO $ handshake istate + 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 + x <- recvData istate if L.null x then recvD istate else return $ L.toChunks x diff --git a/http-enumerator.cabal b/http-enumerator.cabal --- a/http-enumerator.cabal +++ b/http-enumerator.cabal @@ -1,5 +1,5 @@ name: http-enumerator -version: 0.6.5.5 +version: 0.6.5.6 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -24,7 +24,7 @@ , bytestring >= 0.9.1.4 && < 0.10 , transformers >= 0.2 && < 0.3 , failure >= 0.1 && < 0.2 - , enumerator >= 0.4.7 && < 0.5 + , 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 @@ -38,7 +38,7 @@ , monad-control >= 0.2 && < 0.3 , containers >= 0.2 && < 0.5 , certificate >= 0.7 && < 0.10 - , case-insensitive >= 0.2 && < 0.3 + , case-insensitive >= 0.2 && < 0.4 , base64-bytestring >= 0.1 && < 0.2 , asn1-data >= 0.5.1 && < 0.6 if flag(network-bytestring)