diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 0.1.1.0 + +* Make it build with version 1.3.* of conduit. diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs --- a/Network/HTTP/Proxy.hs +++ b/Network/HTTP/Proxy.hs @@ -45,9 +45,12 @@ import Control.Concurrent.Async (race_) import Control.Exception -- (SomeException, catch, toException) import Data.ByteString.Char8 (ByteString) -import Data.Conduit (Flush (..), Sink, Source, ($$), mapOutput, yield) +import Data.Conduit (ConduitT, Flush (..), (.|), mapOutput, runConduit, yield) import Data.Conduit.Network -import Data.Monoid +#if ! MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif +import Data.Void (Void) import Network.Socket import Network.Wai.Conduit hiding (Request, requestMethod) @@ -194,7 +197,13 @@ errorResponse = proxyOnException settings . toException -handleConnect :: Wai.Request -> Source IO BS.ByteString -> Sink BS.ByteString IO () -> IO () +-- handleConnect :: Wai.Request -> ConduitT IO BS.ByteString -> ConduitT BS.ByteString IO () -> IO () + +handleConnect :: Wai.Request + -> ConduitT () ByteString IO () + -> ConduitT ByteString Void IO a + -> IO () + handleConnect wreq fromClient toClient = do let (host, port) = case BS.break (== ':') $ Wai.rawPathInfo wreq of @@ -205,7 +214,7 @@ Nothing -> (x, 80) settings = clientSettings port host runTCPClient settings $ \ad -> do - yield "HTTP/1.1 200 OK\r\n\r\n" $$ toClient + _ <- runConduit $ yield "HTTP/1.1 200 OK\r\n\r\n" .| toClient race_ - (fromClient $$ NC.appSink ad) - (NC.appSource ad $$ toClient) + (runConduit $ fromClient .| NC.appSink ad) + (runConduit $ NC.appSource ad .| toClient) diff --git a/Readme.md b/Readme.md new file mode 100644 --- /dev/null +++ b/Readme.md @@ -0,0 +1,18 @@ +# http-proxy + +[![Build Status](https://secure.travis-ci.org/erikd/http-proxy.png?branch=master)](http://travis-ci.org/erikd/http-proxy) + +A Haskell library for creating HTTP and HTTPS web proxies. + +The aim is to make all proxying operations work in constant space (per +connection) so that memory usage scales linearly with the number of concurrent +connections and is completely independent of the size of either the POST +request body or the response body. + +This library relies heavily on the following libraries: + +* wai : A common protocol between web servers and clients. +* warp : The web servers the proxy application runs in. +* http-conduit / http-client : Perform the upstream requests. + +This is still beta quality. diff --git a/http-proxy.cabal b/http-proxy.cabal --- a/http-proxy.cabal +++ b/http-proxy.cabal @@ -1,17 +1,18 @@ -name: http-proxy -version: 0.1.0.6 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman, Erik de Castro Lopo -maintainer: erikd@mega-nerd.com -homepage: https://github.com/erikd/http-proxy -bug-reports: https://github.com/erikd/http-proxy/issues -category: Web -build-type: Simple -cabal-version: >= 1.10 -stability: Experimental +name: http-proxy +version: 0.1.1.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman, Erik de Castro Lopo +maintainer: erikd@mega-nerd.com +homepage: https://github.com/erikd/http-proxy +bug-reports: https://github.com/erikd/http-proxy/issues +category: Web +build-type: Simple +cabal-version: >= 1.10 +stability: Experimental +extra-source-files: ChangeLog.md Readme.md -synopsis: A library for writing HTTP and HTTPS proxies +synopsis: A library for writing HTTP and HTTPS proxies description: http-proxy is a library for writing HTTP and HTTPS proxies. @@ -25,6 +26,10 @@ a functions for exception reporting and request re-writing. Eventually, this capability will be expanded to allow optional logging, disk caching etc. +source-repository head + type: git + location: https://github.com/erikd/http-proxy.git + library default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs @@ -35,35 +40,33 @@ Network.HTTP.Proxy.Request build-depends: base >= 4 && < 5 - , async >= 2.0 - , blaze-builder >= 0.4 - , bytestring >= 0.10 - , bytestring-lexing >= 0.4 - , case-insensitive >= 1.2 - , conduit >= 1.2 - , conduit-extra >= 1.1 && < 1.3 - , http-client - -- More recent versions seem to have broken proxy support. - , http-conduit >= 2.1.11 && < 2.2 - , http-types >= 0.8 - , mtl >= 2.1 - , network >= 2.6 - , resourcet >= 1.1 - -- Not used directly but necessary to enforce < 0.2 - , streaming-commons >= 0.1 && < 0.2 - , tls >= 1.2 - , text >= 1.2 - , transformers >= 0.3 - , wai >= 3.2 - , wai-conduit >= 3.0 - , warp >= 3.0 - , warp-tls >= 3.0 + , async == 2.2.* + , blaze-builder == 0.4.* + , bytestring == 0.10.* + , bytestring-lexing == 0.5.* + , case-insensitive == 1.2.* + , conduit == 1.3.* + , conduit-extra == 1.3.* + , http-client == 0.6.* + , http-conduit == 2.3.* + , http-types == 0.12.* + , mtl == 2.2.* + , network == 2.8.* + , resourcet == 1.2.* + , streaming-commons == 0.2.* + , tls == 1.4.* + , text == 1.2.* + , transformers == 0.5.* + , wai == 3.2.* + , wai-conduit == 3.0.* + , warp == 3.2.* + , warp-tls == 3.2.* test-suite test type: exitcode-stdio-1.0 - ghc-options: -Wall -fwarn-tabs -threaded + ghc-options: -Wall -fwarn-tabs -threaded -rtsopts "-with-rtsopts=-H1m -K1m" if os(windows) cpp-options: -DWINDOWS default-language: Haskell2010 @@ -104,7 +107,7 @@ test-suite test-io type: exitcode-stdio-1.0 - ghc-options: -Wall -fwarn-tabs -threaded + ghc-options: -Wall -fwarn-tabs -threaded -rtsopts "-with-rtsopts=-H1m -K1m" if os(windows) cpp-options: -DWINDOWS default-language: Haskell2010 @@ -142,9 +145,3 @@ , wai-conduit , warp , warp-tls - - - -source-repository head - type: git - location: https://github.com/erikd/http-proxy.git diff --git a/test/Test/TestServer.hs b/test/Test/TestServer.hs --- a/test/Test/TestServer.hs +++ b/test/Test/TestServer.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} ------------------------------------------------------------ -- Copyright : Erik de Castro Lopo -- License : BSD3 @@ -10,8 +10,11 @@ ) where import Data.ByteString (ByteString) +import Data.Conduit (ConduitT) import Data.List (sort) -import Data.Monoid +#if ! MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif import Data.String import Network.HTTP.Types import Network.Wai @@ -20,7 +23,7 @@ import Network.Wai.Handler.WarpTLS import Data.ByteString.Lex.Integral (readDecimal_) -import Data.Conduit (($$)) +import Data.Conduit ((.|)) import Data.Int (Int64) import qualified Data.ByteString.Char8 as BS @@ -97,9 +100,9 @@ ] -largePostCheck :: Int64 -> DC.Source IO ByteString -> IO Response +largePostCheck :: Int64 -> ConduitT () ByteString IO () -> IO Response largePostCheck len rbody = - maybe success failure <$> (rbody $$ byteSink len) + maybe success failure <$> (DC.runConduit $ rbody .| byteSink len) where success = simpleResponse status200 . BS.pack $ "Post-size: " ++ show len failure = simpleResponse status500 diff --git a/test/Test/Util.hs b/test/Test/Util.hs --- a/test/Test/Util.hs +++ b/test/Test/Util.hs @@ -10,8 +10,9 @@ import Control.Concurrent.Async import Control.Exception hiding (assert) import Control.Monad (forM_, when, unless) -import Control.Monad.Trans.Resource +import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString (ByteString) +import Data.Conduit (ConduitT, Flush (..), SealedConduitT) import Data.Int (Int64) import Data.Maybe import Data.String (fromString) @@ -156,14 +157,14 @@ runResourceT $ do resp <- HC.http (modifyRequest req) mgr let contentLen = readInt64 <$> lookup HT.hContentLength (HC.responseHeaders resp) - bodyText <- checkBodySize (HC.responseBody resp) contentLen + bodyText <- checkBodySize (DC.sealConduitT $ HC.responseBody resp) contentLen return $ Result (HC.secure req) (HT.statusCode $ HC.responseStatus resp) (HC.responseHeaders resp) bodyText where modifyRequest r = r { HC.redirectCount = 0 } -checkBodySize :: (Monad f, Functor f) => DC.ResumableSource f ByteString -> Maybe Int64 -> f ByteString +checkBodySize :: Monad f => SealedConduitT () ByteString f () -> Maybe Int64 -> f ByteString checkBodySize bodySrc Nothing = fmap (BS.concat . LBS.toChunks) $ bodySrc DC.$$+- CB.take 1000 checkBodySize bodySrc (Just len) = do let blockSize = 1000 @@ -172,13 +173,13 @@ else fromMaybe "Success" <$> (bodySrc DC.$$+- byteSink len) -byteSink :: Monad m => Int64 -> DC.Sink ByteString m (Maybe ByteString) +byteSink :: Monad m => Int64 -> ConduitT ByteString a m (Maybe ByteString) byteSink bytes = sink 0 where - sink :: Monad m => Int64 -> DC.Sink ByteString m (Maybe ByteString) + sink :: Monad m => Int64 -> ConduitT ByteString a m (Maybe ByteString) sink !count = DC.await >>= maybe (closeSink count) (sinkBlock count) - sinkBlock :: Monad m => Int64 -> ByteString -> DC.Sink ByteString m (Maybe ByteString) + sinkBlock :: Monad m => Int64 -> ByteString -> ConduitT ByteString a m (Maybe ByteString) sinkBlock !count bs = sink (count + fromIntegral (BS.length bs)) closeSink :: Monad m => Int64 -> m (Maybe ByteString) @@ -189,14 +190,14 @@ ++ " should have been " ++ show bytes ++ "." -builderSource :: Monad m => Int64 -> DC.Source m (DC.Flush Builder) -builderSource = DC.mapOutput (DC.Chunk . fromByteString) . byteSource +builderSource :: Monad m => Int64 -> ConduitT () (Flush Builder) m () +builderSource = DC.mapOutput (Chunk . fromByteString) . byteSource -byteSource :: Monad m => Int64 -> DC.Source m ByteString +byteSource :: Monad m => Int64 -> ConduitT i ByteString m () byteSource bytes = loop 0 where - loop :: Monad m => Int64 -> DC.Source m ByteString + loop :: Monad m => Int64 -> ConduitT i ByteString m () loop !count | count >= bytes = return () | count + blockSize64 < bytes = do @@ -205,7 +206,7 @@ | otherwise = do let n = fromIntegral $ bytes - count DC.yield $ BS.take n bsbytes - return () + pure () blockSize = 8192 :: Int blockSize64 = fromIntegral blockSize :: Int64 @@ -224,8 +225,9 @@ openLocalhostListenSocket :: IO (Socket, Port) openLocalhostListenSocket = do sock <- socket AF_INET Stream defaultProtocol - addr <- inet_addr "127.0.0.1" - bind sock (SockAddrInet aNY_PORT addr) + addr:_ <- getAddrInfo Nothing (Just "127.0.0.1") Nothing + bind sock (addrAddress addr) listen sock 10 port <- fromIntegral <$> socketPort sock return (sock, port) + diff --git a/test/test-io.hs b/test/test-io.hs --- a/test/test-io.hs +++ b/test/test-io.hs @@ -8,10 +8,11 @@ import Control.Concurrent.Async import Control.Exception import Control.Monad -import Control.Monad.Trans.Resource import Data.Conduit import Data.Int (Int64) -import Data.Monoid +#if ! MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif import System.Environment import Test.Hspec @@ -57,12 +58,12 @@ -- Test the HTTP and HTTPS servers directly (ie bypassing the Proxy). describe "Test helper functionality:" $ do it "Byte Sink catches short response bodies." $ - runResourceT (byteSource 80 $$ byteSink 100) + runConduit (byteSource 80 .| byteSink 100) `shouldReturn` Just "Error : Body length 80 should have been 100." it "Byte Source and Sink work in constant memory." $ - runResourceT (byteSource oneBillion $$ byteSink oneBillion) `shouldReturn` Nothing + runConduit (byteSource oneBillion .| byteSink oneBillion) `shouldReturn` Nothing it "Byte Sink catches long response bodies." $ - runResourceT (byteSource 110 $$ byteSink 100) + runConduit (byteSource 110 .| byteSink 100) `shouldReturn` Just "Error : Body length 110 should have been 100." it "Client and server can stream GET response." $ do let size = oneBillion @@ -143,7 +144,7 @@ -- Getting a TlsException shows that we have successfully upgraded -- from HTTP to HTTPS. Its not possible to ignore this failure -- because its made by the http-conduit inside the proxy. - BS.takeWhile (/= ' ') (resultBS result) `shouldBe` "TlsExceptionHostPort" + BS.takeWhile (/= ' ') (resultBS result) `shouldBe` "HttpExceptionRequest" it "Can provide a proxy Response." $ withTestProxy proxySettingsProxyResponse $ \ testProxyPort -> do req <- addTestProxy testProxyPort <$> mkGetRequest Http "/whatever"