├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── Makefile ├── Network └── HTTP │ ├── Proxy.hs │ └── Proxy │ └── Request.hs ├── Notes └── http-post-problem.txt ├── Readme.md ├── Setup.hs ├── cabal.project ├── cabal.project.local ├── examples ├── request-rewrite-proxy.hs └── simple-proxy.hs ├── http-proxy.cabal ├── stack.yaml └── test ├── Test ├── Gen.hs ├── Request.hs ├── ServerDef.hs ├── TestServer.hs ├── Util.hs └── Wai.hs ├── certificate.csr ├── certificate.pem ├── create_certificate.mk ├── key.pem ├── test-io.hs └── test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: required 2 | language: c 3 | 4 | os: linux 5 | dist: xenial 6 | 7 | env: 8 | - GHCVER=8.2.2 9 | - GHCVER=8.4.4 10 | - GHCVER=8.6.5 11 | - GHCVER=8.10.4 12 | 13 | before_install: 14 | - sudo add-apt-repository -y ppa:hvr/ghc 15 | - sudo apt-get update 16 | - sudo apt-get install cabal-install-3.0 ghc-$GHCVER 17 | - export PATH=/opt/cabal/bin:/opt/ghc/$GHCVER/bin:$PATH 18 | 19 | install: 20 | - cabal-3.0 update 21 | 22 | script: 23 | - cabal-3.0 configure --enable-tests 24 | - cabal-3.0 build all 25 | - cabal-3.0 test --test-show-details=streaming -j1 26 | - cabal-3.0 haddock 27 | - cabal-3.0 sdist 28 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 0.1.2.0 2 | 3 | * Update dependencies. 4 | 5 | ## 0.1.1.0 6 | 7 | * Make it build with version 1.3.* of conduit. 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The following license covers this documentation, and the source code, except 2 | where otherwise indicated. 3 | 4 | Copyright 2010, Michael Snoyman. All rights reserved. 5 | Copyright 2011, Stephen Blackheath. All rights reserved. 6 | Copyright 2011, Erik de Castro Lopo. All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions are met: 10 | 11 | * Redistributions of source code must retain the above copyright notice, this 12 | list of conditions and the following disclaimer. 13 | 14 | * Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR 19 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 20 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO 21 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, 22 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 23 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, 24 | OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 25 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 26 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 27 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | TARGETS = debug-proxy request-rewrite-proxy simple-proxy dist/build/testsuite/testsuite 2 | 3 | GHC = cabal exec -- ghc 4 | GHCFLAGS = -Wall -fwarn-tabs 5 | 6 | HSRC := $(shell find Network Test -name \*.hs) 7 | 8 | all : $(TARGETS) 9 | 10 | clean : 11 | find Network Test example -name \*.o -exec rm -f {} \; 12 | find Network Test example -name \*.hi -exec rm -f {} \; 13 | rm -rf $(TARGETS) 14 | 15 | check : dist/build/testsuite/testsuite 16 | dist/build/testsuite/testsuite 17 | 18 | hlint : 19 | hlint Network Test 20 | 21 | init : cabal.sandbox.config 22 | 23 | cabal.sandbox.config : 24 | cabal sandbox init 25 | cabal install --dependencies-only 26 | 27 | #------------------------------------------------------------------------------- 28 | 29 | dist/build/testsuite/testsuite : $(HSRC) 30 | mkdir -p dist/build/testsuite 31 | $(GHC) $(GHCFLAGS) -with-rtsopts="-M64m" -Wall -O2 -threaded Test/testsuite.hs -o $@ 32 | 33 | simple-proxy : example/simple-proxy.hs $(HSRC) 34 | $(GHC) $(GHCFLAGS) --make $< -o $@ 35 | 36 | debug-proxy : example/debug-proxy.hs $(HSRC) 37 | $(GHC) $(GHCFLAGS) --make $< -o $@ 38 | 39 | request-rewrite-proxy : example/request-rewrite-proxy.hs $(HSRC) 40 | $(GHC) $(GHCFLAGS) --make $< -o $@ 41 | 42 | print-%: ; @echo $*=$($*) 43 | -------------------------------------------------------------------------------- /Network/HTTP/Proxy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings #-} 2 | -------------------------------------------------------------------------------- 3 | -- Copyright : Michael Snoyman, Erik de Castro Lopo 4 | -- Maintainer : Erik de Castro Lopo 5 | -- License : BSD3 6 | -- 7 | -- History: 8 | -- Previous versions of http-proxy included a modified version of the Warp 9 | -- web server. Thankfully, Michael Snoyman made changes to Warp and Wai to 10 | -- allow both a HTTP and a HTTPS proxy to be implemented solely as a Wai 11 | -- Application. 12 | -- This version of http-proxy is based on a piece of code Michael Snoyman 13 | -- published as a gist on github.com. 14 | -- 15 | -------------------------------------------------------------------------------- 16 | 17 | -- | This module contains a simple HTTP and HTTPS proxy. In the most basic 18 | -- setup, the caller specifies a port and runs it as follows: 19 | -- 20 | -- > -- Run a HTTPS and HTTPS proxy on port 3128. 21 | -- > import Network.HTTP.Proxy 22 | -- > 23 | -- > main :: IO () 24 | -- > main = runProxy 3128 25 | -- > 26 | -- 27 | 28 | module Network.HTTP.Proxy 29 | ( Port 30 | , Request (..) 31 | , Settings (..) 32 | , UpstreamProxy (..) 33 | 34 | , httpProxyApp 35 | , warpSettings 36 | 37 | , runProxy 38 | , runProxySettings 39 | , runProxySettingsSocket 40 | , defaultProxySettings 41 | ) 42 | where 43 | 44 | import Data.ByteString.Builder (byteString) 45 | import Control.Concurrent.Async (race_) 46 | import Control.Exception -- (SomeException, catch, toException) 47 | import Data.ByteString.Char8 (ByteString) 48 | import Data.Conduit (ConduitT, Flush (..), (.|), mapOutput, runConduit, yield) 49 | import Data.Conduit.Network 50 | #if ! MIN_VERSION_base(4,11,0) 51 | import Data.Monoid ((<>)) 52 | #endif 53 | import Data.Void (Void) 54 | import Network.Socket 55 | import Network.Wai.Conduit hiding (Request, requestMethod) 56 | 57 | import qualified Data.ByteString.Char8 as BS 58 | import qualified Data.ByteString.Lazy.Char8 as LBS 59 | import qualified Data.CaseInsensitive as CI 60 | import qualified Data.Conduit.Network as NC 61 | import qualified Network.HTTP.Client as HC 62 | import qualified Network.HTTP.Conduit as HC 63 | import qualified Network.HTTP.Client.Conduit as HCC 64 | import qualified Network.HTTP.Types as HT 65 | import qualified Network.Wai as Wai 66 | import qualified Network.Wai.Handler.Warp as Warp 67 | 68 | import Network.HTTP.Proxy.Request 69 | 70 | #if 0 71 | import Data.Version (showVersion) 72 | import qualified Paths_httpProxy 73 | 74 | httpProxyVersion :: String 75 | httpProxyVersion = showVersion Paths_warp.version 76 | #endif 77 | 78 | 79 | -- | Run a HTTP and HTTPS proxy server on the specified port. This calls 80 | -- 'runProxySettings' with 'defaultProxySettings'. 81 | runProxy :: Port -> IO () 82 | runProxy port = runProxySettings $ defaultProxySettings { proxyPort = port } 83 | 84 | -- | Run a HTTP and HTTPS proxy server with the specified settings. 85 | runProxySettings :: Settings -> IO () 86 | runProxySettings set = do 87 | mgr <- HC.newManager HC.tlsManagerSettings 88 | Warp.runSettings (warpSettings set) $ httpProxyApp set mgr 89 | 90 | -- | Run a HTTP and HTTPS proxy server with the specified settings but provide 91 | -- it with a Socket to accept connections on. The Socket should have already 92 | -- have had `bind` and `listen` called on it so that the proxy can simple 93 | -- `accept` connections. 94 | runProxySettingsSocket :: Settings -> Socket -> IO () 95 | runProxySettingsSocket set sock = do 96 | port <- socketPort sock 97 | mgr <- HC.newManager HC.tlsManagerSettings 98 | Warp.runSettingsSocket (warpSettings set) sock 99 | $ httpProxyApp set { proxyPort = fromIntegral port } mgr 100 | 101 | -- | Various proxy server settings. This is purposely kept as an abstract data 102 | -- type so that new settings can be added without breaking backwards 103 | -- compatibility. In order to create a 'Settings' value, use 'defaultProxySettings' 104 | -- and record syntax to modify individual records. For example: 105 | -- 106 | -- > defaultProxySettings { proxyPort = 3128 } 107 | data Settings = Settings 108 | { proxyPort :: Int 109 | -- ^ Port to listen on. Default value: 3100 110 | , proxyHost :: HostPreference 111 | -- ^ Default value: HostIPv4 112 | , proxyOnException :: SomeException -> Wai.Response 113 | -- ^ What to do with exceptions thrown by either the application or server. 114 | -- Default: ignore server-generated exceptions (see 'InvalidRequest') and print 115 | -- application-generated applications to stderr. 116 | , proxyTimeout :: Int 117 | -- ^ Timeout value in seconds. Default value: 30 118 | , proxyHttpRequestModifier :: Request -> IO (Either Response Request) 119 | -- ^ A function that allows the request to be modified before being run. Default: 'return . Right'. 120 | -- This only works for unencrypted HTTP requests (eg to upgrade the request to HTTPS) because 121 | -- HTTPS requests are encrypted. 122 | , proxyLogger :: ByteString -> IO () 123 | -- ^ A function for logging proxy internal state. Default: 'return ()'. 124 | , proxyUpstream :: Maybe UpstreamProxy 125 | -- ^ Optional upstream proxy. 126 | } 127 | 128 | -- | A http-proxy can be configured to use and upstream proxy by providing the 129 | -- proxy name, the port it listens to and an option username and password for 130 | -- proxy authorisation. 131 | data UpstreamProxy = UpstreamProxy 132 | { upstreamHost :: ByteString 133 | -- ^ The upstream proxy's hostname. 134 | , upstreamPort :: Int 135 | -- ^ The upstream proxy's port number. 136 | , upstreamAuth :: Maybe (ByteString, ByteString) 137 | -- ^ Optional username and password to use with upstream proxy. 138 | } 139 | 140 | 141 | warpSettings :: Settings -> Warp.Settings 142 | warpSettings pset = Warp.setPort (proxyPort pset) 143 | . Warp.setHost (proxyHost pset) 144 | . Warp.setTimeout (proxyTimeout pset) 145 | . Warp.setOnException (\ _ _ -> return ()) 146 | . Warp.setOnExceptionResponse defaultExceptionResponse 147 | $ Warp.setNoParsePath True Warp.defaultSettings 148 | 149 | -- | The default settings for the Proxy server. See the individual settings for 150 | -- the default value. 151 | defaultProxySettings :: Settings 152 | defaultProxySettings = Settings 153 | { proxyPort = 3100 154 | , proxyHost = "*" 155 | , proxyOnException = defaultExceptionResponse 156 | , proxyTimeout = 30 157 | , proxyHttpRequestModifier = return . Right 158 | , proxyLogger = const $ return () 159 | , proxyUpstream = Nothing 160 | } 161 | 162 | defaultExceptionResponse :: SomeException -> Wai.Response 163 | defaultExceptionResponse e = 164 | Wai.responseLBS HT.internalServerError500 165 | [ (HT.hContentType, "text/plain; charset=utf-8") ] 166 | $ LBS.fromChunks [BS.pack $ show e] 167 | 168 | -- ----------------------------------------------------------------------------- 169 | -- Application == Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived 170 | 171 | httpProxyApp :: Settings -> HC.Manager -> Application 172 | httpProxyApp settings mgr wreq respond = do 173 | mwreq <- proxyHttpRequestModifier settings $ proxyRequest wreq 174 | either respond (doUpstreamRequest settings mgr respond . waiRequest wreq) mwreq 175 | 176 | 177 | doUpstreamRequest :: Settings -> HC.Manager -> (Wai.Response -> IO Wai.ResponseReceived) -> Wai.Request -> IO Wai.ResponseReceived 178 | doUpstreamRequest settings mgr respond mwreq 179 | | Wai.requestMethod mwreq == "CONNECT" = 180 | respond $ responseRawSource (handleConnect mwreq) 181 | (Wai.responseLBS HT.status500 [("Content-Type", "text/plain")] "No support for responseRaw") 182 | | otherwise = do 183 | hreq0 <- HC.parseRequest $ BS.unpack (Wai.rawPathInfo mwreq <> Wai.rawQueryString mwreq) 184 | let hreq = hreq0 185 | { HC.method = Wai.requestMethod mwreq 186 | , HC.requestHeaders = filter dropRequestHeader $ Wai.requestHeaders mwreq 187 | , HC.redirectCount = 0 -- Always pass redirects back to the client. 188 | , HC.requestBody = 189 | case Wai.requestBodyLength mwreq of 190 | Wai.ChunkedBody -> 191 | HC.requestBodySourceChunkedIO (sourceRequestBody mwreq) 192 | Wai.KnownLength l -> 193 | HC.requestBodySourceIO (fromIntegral l) (sourceRequestBody mwreq) 194 | -- Do not touch response body. Otherwise there may be discrepancy 195 | -- between response headers and the response content. 196 | , HC.decompress = const False 197 | } 198 | handle (respond . errorResponse) $ 199 | HC.withResponse hreq mgr $ \res -> do 200 | let body = mapOutput (Chunk . byteString) . HCC.bodyReaderSource $ HC.responseBody res 201 | headers = (CI.mk "X-Via-Proxy", "yes") : filter dropResponseHeader (HC.responseHeaders res) 202 | respond $ responseSource (HC.responseStatus res) headers body 203 | where 204 | dropRequestHeader (k, _) = k `notElem` 205 | [ "content-encoding" 206 | , "content-length" 207 | ] 208 | dropResponseHeader (k, _) = k `notElem` [] 209 | 210 | errorResponse :: SomeException -> Wai.Response 211 | errorResponse = proxyOnException settings . toException 212 | 213 | 214 | handleConnect :: Wai.Request -> ConduitT () ByteString IO () -> ConduitT ByteString Void IO a -> IO () 215 | handleConnect wreq fromClient toClient = do 216 | let (host, port) = 217 | case BS.break (== ':') $ Wai.rawPathInfo wreq of 218 | (x, "") -> (x, 80) 219 | (x, y) -> 220 | case BS.readInt $ BS.drop 1 y of 221 | Just (port', _) -> (x, port') 222 | Nothing -> (x, 80) 223 | settings = clientSettings port host 224 | runTCPClient settings $ \ad -> do 225 | _ <- runConduit $ yield "HTTP/1.1 200 OK\r\n\r\n" .| toClient 226 | race_ 227 | (runConduit $ fromClient .| NC.appSink ad) 228 | (runConduit $ NC.appSource ad .| toClient) 229 | -------------------------------------------------------------------------------- /Network/HTTP/Proxy/Request.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, OverloadedStrings #-} 2 | ------------------------------------------------------------ 3 | -- Copyright : Erik de Castro Lopo 4 | -- License : BSD3 5 | ------------------------------------------------------------ 6 | 7 | module Network.HTTP.Proxy.Request 8 | ( Port 9 | , Request (..) 10 | 11 | , proxyRequest 12 | , waiRequest 13 | , waiRequestHost 14 | ) 15 | where 16 | 17 | import Data.ByteString.Char8 (ByteString) 18 | import Data.Maybe (fromMaybe) 19 | import Network.HTTP.Types (Method) 20 | 21 | import qualified Network.HTTP.Types as HT 22 | import qualified Network.Wai as Wai 23 | 24 | type Port = Int 25 | 26 | 27 | -- | 28 | data Request = Request 29 | { 30 | -- | Request method such as GET. 31 | requestMethod :: Method 32 | -- | HTTP version such as 1.1. 33 | , httpVersion :: HT.HttpVersion 34 | -- | A list of header (a pair of key and value) in an HTTP request. 35 | , requestHeaders :: HT.RequestHeaders 36 | -- | The part of the URL before the query part. 37 | , requestPath :: ByteString 38 | -- | Parsed query string information 39 | , queryString :: ByteString 40 | } deriving (Show, Eq) 41 | 42 | 43 | proxyRequest :: Wai.Request -> Request 44 | proxyRequest wreq = Request 45 | (Wai.requestMethod wreq) 46 | (Wai.httpVersion wreq) 47 | (Wai.requestHeaders wreq) 48 | (Wai.rawPathInfo wreq) 49 | (Wai.rawQueryString wreq) 50 | 51 | waiRequest :: Wai.Request -> Request -> Wai.Request 52 | waiRequest original req = original 53 | { Wai.requestMethod = requestMethod req 54 | , Wai.httpVersion = httpVersion req 55 | , Wai.requestHeaders = requestHeaders req 56 | , Wai.rawPathInfo = requestPath req 57 | , Wai.rawQueryString = queryString req 58 | } 59 | 60 | 61 | waiRequestHost :: Wai.Request -> ByteString 62 | waiRequestHost req = fromMaybe "???" $ Wai.requestHeaderHost req 63 | -------------------------------------------------------------------------------- /Notes/http-post-problem.txt: -------------------------------------------------------------------------------- 1 | The Problem of Large POST Request Bodies 2 | ======================================== 3 | 4 | This problem was finally solved on 2011/12/22. This file documents some of the 5 | crazy things that were tried when trying to come up with a solution. 6 | 7 | The Problem 8 | ----------- 9 | HTTP POST requests have a request body. Usually these are small, but in the case 10 | of doing a HTTP upload to a server (eg submitting a package to Hackage) the 11 | request body can be quite large. 12 | 13 | One of the main goals of http-proxy is to have all operations scale with the 14 | number of concurrent connections and independently of size of the items being 15 | up or down loaded. 16 | 17 | With the current implementation of http-proxy using Wai, Warp and http-enumerator 18 | which in turn all use John Millikin 's enumerator package, the problem is that 19 | the http-proxy uses an Iteratee to read the request from the client but needs to 20 | create an Enumerator to send the request upstream to the target server using 21 | http-enumerator. The http-enumerator request body is built using a RequestBody 22 | defined as: 23 | 24 | data RequestBody m 25 | = RequestBodyLBS ByteString 26 | | RequestBodyBS ByteString 27 | | RequestBodyBuilder Int64 Builder 28 | | RequestBodyEnum Int64 (Enumerator Builder m ()) 29 | | RequestBodyEnumChunked (Enumerator Builder m ()) 30 | 31 | Of these options, RequestBodyBS is obviously out because it uses a strict 32 | ByteString and even RequestBodyLBS is out because even if you supply it with a 33 | lazy ByteString, http-enumerator still renders it into a single Blaze.Builder 34 | using: 35 | 36 | enumSingle :: Monad m => a -> Enumerator a m b 37 | enumSingle x (Continue k) = k $ Chunks [x] 38 | enumSingle _ step = returnI step 39 | 40 | However, in writing a simple http client program I have proved to myself that 41 | HTTP POSTing large files (eg files larger than the amount of RAM on the machine) 42 | is possible doing something like this: 43 | 44 | doRequest $ req 45 | { HE.method = "POST" 46 | , HE.requestBody = HE.RequestBodyEnum size enumBuilder 47 | } 48 | where 49 | enumBuilder :: Enumerator Builder IO () 50 | enumBuilder = EB.enumFile fname $= EL.map fromByteString 51 | 52 | so the whole Enumerator Builder thing can do it, because it avoids the 53 | enumSingle function. 54 | 55 | I list below various attempts to fix this problem. 56 | 57 | 58 | a) Use RequestBodyEnum 59 | ---------------------- 60 | 61 | The idea here is to use an Iteratee to pull the data from the client and the do 62 | something like enumBuilder above to pass the data to http-enumerator. 63 | Unfortunately this simply didn't work, the Iteratee would read zero bytes of 64 | data. I'm pretty sure the reason for this was that my code assumed that in the 65 | context of enumBuilder, the Iteratee in scope was the one pulling data from the 66 | client when it was in fact the Iteratee in the http-enumerator context. 67 | 68 | 69 | b) Fix RequestBodyLBS 70 | --------------------- 71 | 72 | Inside http-enumerator, the http function turns the RequestBody data type into 73 | an Enumerator, the existing code did the following: 74 | 75 | RequestBodyLBS lbs -> 76 | (Just $ L.length lbs, enumSingle $ Blaze.fromLazyByteString lbs) 77 | 78 | Obviously, calculating the length of a lazy ByteString will cause the whole 79 | thing to be loaded into memory and enumSingle also problematic. 80 | 81 | However, it is not unreasonable to require that every POST operation that uses 82 | the RequestBodyLBS should also provide a Content-Length header. The content 83 | length can then be calculated with a function like this: 84 | 85 | getContentLength hdrs = 86 | read $ S8.unpack $ fromMaybe "0" $ lookup "content-length" hdrs 87 | 88 | which sanely defaults to zero if there is no Content-Length header. The 89 | RequestBodyLBS handler can then be re-written as: 90 | 91 | RequestBodyLBS lbs -> 92 | (Just $ getContentLength requestHeaders, enumLazyBuilder lbs) 93 | 94 | with enumLazyBuilder implemented as: 95 | 96 | enumLazyBuilder :: Monad m => L.ByteString -> Enumerator Blaze.Builder m b 97 | enumLazyBuilder x (Continue k) = 98 | k $ Chunks (map Blaze.fromByteString (L.toChunks x)) 99 | enumLazyBuilder _ step = returnI step 100 | 101 | but that still isn't lazy enough or rather, implemented like this, my proxy 102 | still tries to pull the whole request body into memory before starting to send 103 | it to the server. 104 | 105 | 106 | c) Force Chunking in enumLazyBuilder 107 | ------------------------------------ 108 | 109 | At this point I suspected that I needed to re-write enumLazyBuilder to chunk 110 | up the lazy ByteString before converting it to a Blaze.Builder. I came up with 111 | this: 112 | 113 | enumLazyBuilder :: Monad m => L.ByteString -> Enumerator Blaze.Builder m b 114 | enumLazyBuilder = EI.checkContinue1 $ \loop lbs k -> do 115 | let (start, rest) = L.splitAt 4096 lbs 116 | if L.null start 117 | then continue k 118 | else k (Chunks [Blaze.fromLazyByteString start]) >>== loop rest 119 | 120 | Unfortunately even with this this the proxy still tried to load the whole 121 | of the POST body into memory before sending it. 122 | 123 | 124 | d) Make EB.take lazier 125 | ---------------------- 126 | 127 | In http-proxy I have code that looks like: 128 | 129 | postBody <- EB.take contentLength 130 | doRequest $ req 131 | { HE.method = "POST" 132 | , HE.requestBody = HE.RequestBodyLBS postBody 133 | } 134 | 135 | My next hypothesis was that EB.take was being more eager than it should be. The 136 | actual implementation of EB.take seemed to confirm this: 137 | 138 | take :: Monad m => Integer -> Iteratee B.ByteString m BL.ByteString 139 | take n | n <= 0 = return BL.empty 140 | take n = continue (loop id n) where 141 | loop acc n' (Chunks xs) = iter where 142 | lazy = BL.fromChunks xs 143 | len = toInteger (BL.length lazy) 144 | 145 | iter = if len < n' 146 | then continue (loop (acc . BL.append lazy) (n' - len)) 147 | else let 148 | (xs', extra) = BL.splitAt (fromInteger n') lazy 149 | in yield (acc xs') (toChunks extra) 150 | loop acc _ EOF = yield (acc BL.empty) EOF 151 | 152 | One obvious problem here is the call of BL.length on the lazy ByteString. With 153 | this implementation, my http-proxy would try to load the whole of the request 154 | body into memory so that the length could calculated. 155 | 156 | Rewriting a lazier replacement function is pretty easy: 157 | 158 | lazyTake :: Monad m => Integer -> Iteratee ByteString m LBS.ByteString 159 | lazyTake n | n <= 0 = return LBS.empty 160 | lazyTake n = continue (loop id n) where 161 | loop acc n' (Chunks []) = continue (loop acc n') 162 | loop acc n' (Chunks (x:xs)) = iter where 163 | len = toInteger (B.length x) 164 | 165 | iter = if len <= n' 166 | then continue (loop (acc . LBS.append (LBS.fromChunks [x])) (n' - len)) 167 | else let 168 | (start, extra) = B.splitAt (fromInteger n') x 169 | in yield (acc (LBS.fromChunks [start])) (Chunks (extra:xs)) 170 | loop acc _ EOF = yield (acc LBS.empty) EOF 171 | 172 | Plugging this into the http-proxy doesn't fix the problem. Using it like: 173 | 174 | postBody <- lazyTake contentLength 175 | 176 | still sucks the whole request body into memory. Wrapping the call in E.run_ 177 | like this: 178 | 179 | postBody <- E.run_ $ lazyTake contentLength 180 | 181 | nor does this: 182 | 183 | postBody <- liftIO $ E.run_ $ lazyTake contentLength 184 | 185 | but these two have a different failure mode. With E.run_, the client program 186 | connecting to the proxy and doing the HTTP POST receives a "Connection reset by 187 | peer" error. 188 | 189 | 190 | e) Nesting Iteratee inside an Enumerator 191 | ---------------------------------------- 192 | 193 | This is the trick that finally made the whole thing work. Specifically the 194 | function: 195 | 196 | -- Create an Enumerator from an Iteratee. 197 | -- The first parameter is the number of bytes to be pulled from the Iteratee. 198 | -- The second is an Iteratee that can pull the data from the source in chunks. 199 | -- The return value is an Enumerator that operates inside the Iteratee monad. 200 | enumIteratee :: MonadIO m => Int64 201 | -> (Int64 -> Iteratee ByteString m ByteString) 202 | -> Enumerator ByteString (Iteratee ByteString m) c 203 | 204 | 205 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # http-proxy 2 | 3 | [![Build Status](https://secure.travis-ci.org/erikd/http-proxy.png?branch=master)](http://travis-ci.org/erikd/http-proxy) 4 | 5 | A Haskell library for creating HTTP and HTTPS web proxies. 6 | 7 | The aim is to make all proxying operations work in constant space (per 8 | connection) so that memory usage scales linearly with the number of concurrent 9 | connections and is completely independent of the size of either the POST 10 | request body or the response body. 11 | 12 | This library relies heavily on the following libraries: 13 | 14 | * wai : A common protocol between web servers and clients. 15 | * warp : The web servers the proxy application runs in. 16 | * http-conduit / http-client : Perform the upstream requests. 17 | 18 | This is still beta quality. 19 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Distribution.Simple 3 | 4 | main :: IO () 5 | main = defaultMain 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./ 3 | -------------------------------------------------------------------------------- /cabal.project.local: -------------------------------------------------------------------------------- 1 | tests: True 2 | test-show-details: direct 3 | -------------------------------------------------------------------------------- /examples/request-rewrite-proxy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Data.ByteString.Char8 as BS 4 | 5 | import Network.HTTP.Proxy (Settings (..), Request (..)) 6 | import qualified Network.HTTP.Proxy as Proxy 7 | import Network.URI (URI (..), URIAuth (..), parseURI) 8 | import Network.Wai.Internal (Response) 9 | 10 | main :: IO () 11 | main = 12 | Proxy.runProxySettings $ 13 | Proxy.defaultProxySettings 14 | { proxyPort = 31081 15 | , proxyHttpRequestModifier = secureGoogle 16 | } 17 | 18 | -- Modifying the request like this is only possible for unencrypted HTTP connections 19 | -- by my be useful for eg redirecting HTTP to HTTPS. 20 | -- HTTPS cnnections cannot be modified like this because the for HTTPS connections 21 | -- even the request itself is encrypted. 22 | 23 | secureGoogle :: Request -> IO (Either Response Request) 24 | secureGoogle req = do 25 | case parseURI $ BS.unpack (requestPath req) of 26 | Nothing -> do 27 | putStrLn $ "Not able to parse: " ++ show (requestPath req) 28 | -- Not much to be done other than just return the Request unmodified. 29 | pure $ Right req 30 | Just uri -> 31 | pure . Right $ req { requestPath = BS.pack $ show (modifyURI uri) } 32 | 33 | modifyURI :: URI -> URI 34 | modifyURI uri = 35 | uri 36 | { uriAuthority = modifyUriAthority <$> uriAuthority uri 37 | , uriScheme = modifyUriScheme (uriScheme uri) 38 | } 39 | where 40 | modifyUriAthority :: URIAuth -> URIAuth 41 | modifyUriAthority auth = 42 | if uriRegName auth == "www.google.com" 43 | then auth { uriRegName = "encrypted.google.com", uriPort = "" } 44 | else auth 45 | 46 | modifyUriScheme :: String -> String 47 | modifyUriScheme scheme = 48 | if scheme =="http:" then "https:" else scheme 49 | -------------------------------------------------------------------------------- /examples/simple-proxy.hs: -------------------------------------------------------------------------------- 1 | 2 | import Network.HTTP.Proxy (runProxy) 3 | 4 | -- The simplest possible HTTP/HTTPS proxy. 5 | main :: IO () 6 | main = do 7 | putStrLn "Proxy running on port 31081. Ctrl-C to quit." 8 | runProxy 31081 9 | 10 | 11 | -------------------------------------------------------------------------------- /http-proxy.cabal: -------------------------------------------------------------------------------- 1 | name: http-proxy 2 | version: 0.1.2.0 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Michael Snoyman, Erik de Castro Lopo 6 | maintainer: erikd@mega-nerd.com 7 | homepage: https://github.com/erikd/http-proxy 8 | bug-reports: https://github.com/erikd/http-proxy/issues 9 | category: Web 10 | build-type: Simple 11 | cabal-version: >= 1.10 12 | stability: Experimental 13 | extra-source-files: ChangeLog.md Readme.md 14 | 15 | synopsis: A library for writing HTTP and HTTPS proxies 16 | 17 | description: 18 | http-proxy is a library for writing HTTP and HTTPS proxies. 19 | . 20 | Use of the Conduit library provides file streaming via the proxy in both 21 | directions. Memory usage of the proxy scales linearly with the number of 22 | simultaneous connections and is independent of the size of the files being 23 | uploaded or downloaded. 24 | . 25 | The Settings data type provided by the library allows the caller to supply 26 | a functions for exception reporting and request re-writing. Eventually, this 27 | capability will be expanded to allow optional logging, disk caching etc. 28 | 29 | source-repository head 30 | type: git 31 | location: https://github.com/erikd/http-proxy.git 32 | 33 | library 34 | default-language: Haskell2010 35 | ghc-options: -Wall -fwarn-tabs 36 | if os(windows) 37 | cpp-options: -DWINDOWS 38 | 39 | exposed-modules: Network.HTTP.Proxy 40 | Network.HTTP.Proxy.Request 41 | 42 | build-depends: base >= 4 && < 5 43 | , async == 2.2.* 44 | , bytestring >= 0.10.8 45 | , bytestring-lexing >= 0.5 46 | , case-insensitive >= 1.2 47 | , conduit == 1.3.* 48 | , conduit-extra == 1.3.* 49 | , http-client >= 0.6 && < 0.8 50 | , http-conduit == 2.3.* 51 | , http-types == 0.12.* 52 | , mtl >= 2.2 && < 2.4 53 | , network >= 3.1 54 | , resourcet >= 1.2 && < 1.4 55 | , streaming-commons == 0.2.* 56 | , tls >= 1.5 && < 2.2 57 | , text >= 2.0 && < 2.2 58 | , transformers >= 0.5 && < 0.7 59 | , wai == 3.2.* 60 | , wai-conduit == 3.0.* 61 | , warp >= 3.3 && < 3.5 62 | , warp-tls >= 3.3 && < 3.5 63 | 64 | 65 | 66 | test-suite test 67 | type: exitcode-stdio-1.0 68 | ghc-options: -Wall -fwarn-tabs -threaded -rtsopts "-with-rtsopts=-H1m -K1m" 69 | if os(windows) 70 | cpp-options: -DWINDOWS 71 | default-language: Haskell2010 72 | hs-source-dirs: test 73 | main-is: test.hs 74 | 75 | other-modules: Test.Gen 76 | , Test.Request 77 | , Test.ServerDef 78 | , Test.TestServer 79 | , Test.Util 80 | , Test.Wai 81 | 82 | build-depends: base 83 | , async 84 | , blaze-builder 85 | , bytestring 86 | , bytestring-lexing 87 | , case-insensitive 88 | , conduit 89 | , connection >= 0.2 90 | , conduit-extra 91 | , http-client 92 | , http-conduit 93 | , http-proxy 94 | , http-types 95 | , hspec >= 2.1 96 | , network 97 | , QuickCheck >= 2.7 98 | , random >= 1.1 99 | , resourcet 100 | , text 101 | , vault 102 | , wai 103 | , wai-conduit 104 | , warp 105 | , warp-tls 106 | 107 | test-suite test-io 108 | type: exitcode-stdio-1.0 109 | ghc-options: -Wall -fwarn-tabs -threaded -rtsopts "-with-rtsopts=-H1m -K1m" 110 | if os(windows) 111 | cpp-options: -DWINDOWS 112 | default-language: Haskell2010 113 | hs-source-dirs: test 114 | main-is: test-io.hs 115 | 116 | other-modules: Test.Gen 117 | , Test.Request 118 | , Test.ServerDef 119 | , Test.TestServer 120 | , Test.Util 121 | , Test.Wai 122 | 123 | build-depends: base 124 | , async 125 | , blaze-builder 126 | , bytestring 127 | , bytestring-lexing 128 | , case-insensitive 129 | , conduit 130 | , connection >= 0.2 131 | , conduit-extra 132 | , http-client 133 | , http-conduit 134 | , http-proxy 135 | , http-types 136 | , hspec >= 2.1 137 | , network 138 | , QuickCheck >= 2.7 139 | , random >= 1.1 140 | , resourcet 141 | , text 142 | , vault 143 | , wai 144 | , wai-conduit 145 | , warp 146 | , warp-tls 147 | 148 | executable request-rewrite-proxy 149 | default-language: Haskell2010 150 | ghc-options: -Wall -fwarn-tabs -threaded -rtsopts "-with-rtsopts=-H1m -K1m" 151 | hs-source-dirs: examples 152 | main-is: request-rewrite-proxy.hs 153 | 154 | build-depends: base 155 | , bytestring 156 | , http-proxy 157 | , network-uri 158 | , wai 159 | 160 | executable simple-proxy 161 | default-language: Haskell2010 162 | ghc-options: -Wall -fwarn-tabs -threaded -rtsopts "-with-rtsopts=-H1m -K1m" 163 | hs-source-dirs: examples 164 | main-is: simple-proxy.hs 165 | 166 | build-depends: base 167 | , http-proxy 168 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | resolver: lts-18.11 6 | -------------------------------------------------------------------------------- /test/Test/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | ------------------------------------------------------------ 3 | -- Copyright : Ambiata Pty Ltd 4 | -- Author : Sharif Olorin 5 | -- License : BSD3 6 | ------------------------------------------------------------ 7 | 8 | module Test.Gen 9 | ( genWaiRequest 10 | ) where 11 | 12 | import Data.ByteString.Char8 (ByteString) 13 | import Data.CaseInsensitive (CI) 14 | import Data.List (intersperse) 15 | import Data.Monoid ((<>)) 16 | import Network.HTTP.Types 17 | import Network.Socket (SockAddr (..), PortNumber) 18 | import Test.QuickCheck 19 | 20 | import qualified Data.ByteString.Char8 as BS 21 | import qualified Data.CaseInsensitive as CI 22 | import qualified Data.Text.Encoding as T 23 | import qualified Data.Vault.Lazy as Vault 24 | import qualified Network.Wai.Internal as Wai 25 | 26 | genWaiRequest :: Gen Wai.Request 27 | genWaiRequest = do 28 | method <- genHttpMethod 29 | version <- genHttpVersion 30 | pathList <- listOf genAscii 31 | secure <- elements [ False, True ] 32 | query <- genQuery 33 | port <- genPort 34 | sockAddr <- SockAddrInet port <$> arbitrary 35 | host <- genHostname 36 | headers <- genHeaderList 37 | (bodylen, body) <- genRequestBody 38 | return $ Wai.Request method version 39 | (BS.concat $ "/" : intersperse "/" pathList) 40 | (renderQueryBS query) 41 | headers secure sockAddr 42 | (map T.decodeUtf8 pathList) 43 | query 44 | (return body) -- requestBody 45 | Vault.empty 46 | bodylen -- requestBodyLength 47 | (Just host) -- requestHeaderHost 48 | Nothing -- requestHeaderRange 49 | Nothing -- requestHeaderReferer 50 | Nothing -- requestHeaderUserAgent 51 | 52 | 53 | genRequestBody :: Gen (Wai.RequestBodyLength, ByteString) 54 | genRequestBody = 55 | let mkResult body = (Wai.KnownLength (fromIntegral $ BS.length body), body) 56 | in mkResult <$> genAscii 57 | 58 | 59 | genHttpMethod :: Gen ByteString 60 | genHttpMethod = elements 61 | [ "GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT" 62 | , "OPTIONS", "PATCH" 63 | ] 64 | 65 | genHttpVersion :: Gen HttpVersion 66 | genHttpVersion = elements [ http09, http10, http11 ] 67 | 68 | genHostname :: Gen ByteString 69 | genHostname = BS.intercalate "." <$> listOf1 genAscii 70 | 71 | genPort :: Gen PortNumber 72 | genPort = fromIntegral <$> arbitrary `suchThat` (\x -> x > 1024 && x < (65536 :: Int)) 73 | 74 | genHeaderList :: Gen [Header] 75 | genHeaderList = listOf genHeader 76 | 77 | genHeader :: Gen Header 78 | genHeader = (,) <$> genHeaderName <*> genAscii 79 | 80 | genHeaderName :: Gen (CI ByteString) 81 | genHeaderName = CI.mk <$> genAscii 82 | 83 | renderQueryBS :: Query -> ByteString 84 | renderQueryBS [] = "" 85 | renderQueryBS ql = 86 | let mkPair (name, value) = name <> maybe "" ("=" <>) value 87 | in "?" <> BS.intercalate "&" (map mkPair ql) 88 | 89 | genQuery :: Gen Query 90 | genQuery = listOf genQueryItem 91 | 92 | genQueryItem :: Gen QueryItem 93 | genQueryItem = (,) <$> genAscii <*> oneof [Just <$> genAscii, pure Nothing] 94 | 95 | genAscii :: Gen ByteString 96 | genAscii = BS.pack <$> do 97 | srange <- choose (3, 10) 98 | vectorOf srange $ oneof [choose ('a', 'z'), choose ('0', '9')] 99 | -------------------------------------------------------------------------------- /test/Test/Request.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | ------------------------------------------------------------ 4 | -- Copyright (c) Erik de Castro Lopo 5 | -- License : BSD3 6 | ------------------------------------------------------------ 7 | 8 | module Test.Request 9 | ( UriScheme (..) 10 | , mkGetRequest 11 | , mkGetRequestWithBody 12 | , mkPostRequest 13 | , mkPostRequestBS 14 | , mkPostRequestBody 15 | ) where 16 | 17 | import Data.ByteString (ByteString) 18 | import Data.Char 19 | import Data.Maybe 20 | 21 | import qualified Network.HTTP.Client as HC 22 | import qualified Network.HTTP.Types as HT 23 | 24 | import Test.ServerDef 25 | 26 | 27 | data UriScheme 28 | = Http | Https 29 | 30 | instance Show UriScheme where 31 | show Http = "HTTP" 32 | show Https = "HTTPS" 33 | 34 | 35 | mkGetRequest :: UriScheme -> String -> IO HC.Request 36 | mkGetRequest scheme path = mkTestRequest get scheme path Nothing 37 | 38 | 39 | mkGetRequestWithBody :: UriScheme -> String -> ByteString -> IO HC.Request 40 | mkGetRequestWithBody scheme path body = mkTestRequestBS get scheme path (Just body) 41 | 42 | 43 | mkPostRequest :: UriScheme -> String -> IO HC.Request 44 | mkPostRequest scheme path = mkTestRequest post scheme path Nothing 45 | 46 | 47 | mkPostRequestBS :: UriScheme -> String -> ByteString -> IO HC.Request 48 | mkPostRequestBS scheme path body = mkTestRequestBS post scheme path (Just body) 49 | 50 | 51 | mkPostRequestBody :: UriScheme -> String -> HC.RequestBody -> IO HC.Request 52 | mkPostRequestBody scheme path body = mkTestRequest post scheme path (Just body) 53 | 54 | 55 | mkTestRequestBS :: HT.Method -> UriScheme -> String -> Maybe ByteString -> IO HC.Request 56 | mkTestRequestBS method scheme path mbody = mkTestRequest method scheme path $ HC.RequestBodyBS <$> mbody 57 | 58 | 59 | mkTestRequest :: HT.Method -> UriScheme -> String -> Maybe HC.RequestBody -> IO HC.Request 60 | mkTestRequest method scheme path mbody = do 61 | let port = show $ case scheme of 62 | Http -> httpTestPort portsDef 63 | Https -> httpsTestPort portsDef 64 | url = map toLower (show scheme) ++ "://localhost:" ++ port ++ path 65 | req <- HC.parseRequest url 66 | return $ req 67 | { HC.method = if HC.method req /= method then method else HC.method req 68 | , HC.requestBody = fromMaybe (HC.requestBody req) mbody 69 | } 70 | 71 | 72 | get, post :: HT.Method 73 | get = HT.methodGet 74 | post = HT.methodPost 75 | 76 | -------------------------------------------------------------------------------- /test/Test/ServerDef.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------ 2 | -- Copyright : Erik de Castro Lopo 3 | -- License : BSD3 4 | ------------------------------------------------------------ 5 | 6 | module Test.ServerDef 7 | ( PortsDef (..) 8 | , portsDef 9 | ) where 10 | 11 | import Data.List (sort) 12 | import System.IO.Unsafe (unsafePerformIO) 13 | import System.Random 14 | 15 | data PortsDef = PortsDef 16 | { httpTestPort :: Int 17 | , httpsTestPort :: Int 18 | } 19 | deriving Show 20 | 21 | 22 | -- Yeah, yeah, unsafePerformIO! Worst thing that can happen is that the tests 23 | -- fail. 24 | {-# NOINLINE portsDef #-} 25 | portsDef :: PortsDef 26 | portsDef = unsafePerformIO getPortsDef 27 | 28 | 29 | -- Grab three unique Ints in the range (30000, 60000) and stick them in a 30 | -- PortsDef constructor. 31 | getPortsDef :: IO PortsDef 32 | getPortsDef = do 33 | vals <- randomRL [] 34 | case sort vals of 35 | [a, b] -> return $ PortsDef a b 36 | _ -> getPortsDef 37 | where 38 | randomRL :: [Int] -> IO [Int] 39 | randomRL xs 40 | | length xs == 2 = return $ sort xs 41 | | otherwise = do 42 | x <- randomRIO portRange 43 | if x `elem` xs 44 | then randomRL xs 45 | else randomRL (x:xs) 46 | 47 | portRange :: (Int, Int) 48 | portRange = (30000, 60000) 49 | -------------------------------------------------------------------------------- /test/Test/TestServer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, OverloadedStrings #-} 2 | ------------------------------------------------------------ 3 | -- Copyright : Erik de Castro Lopo 4 | -- License : BSD3 5 | ------------------------------------------------------------ 6 | 7 | module Test.TestServer 8 | ( runTestServer 9 | , runTestServerTLS 10 | ) where 11 | 12 | import Data.ByteString (ByteString) 13 | import Data.Conduit (ConduitT) 14 | import Data.List (sort) 15 | #if ! MIN_VERSION_base(4,11,0) 16 | import Data.Monoid ((<>)) 17 | #endif 18 | import Data.String 19 | import Network.HTTP.Types 20 | import Network.Wai 21 | import Network.Wai.Conduit 22 | import Network.Wai.Handler.Warp 23 | import Network.Wai.Handler.WarpTLS 24 | 25 | import Data.ByteString.Lex.Integral (readDecimal_) 26 | import Data.Conduit ((.|)) 27 | import Data.Int (Int64) 28 | 29 | import qualified Data.ByteString.Char8 as BS 30 | import qualified Data.ByteString.Lazy.Char8 as LBS 31 | import qualified Data.Conduit as DC 32 | 33 | import qualified Network.HTTP.Proxy.Request as HPR 34 | 35 | import Test.ServerDef 36 | import Test.Util 37 | 38 | 39 | runTestServer :: IO () 40 | runTestServer = 41 | let settings = setPort (httpTestPort portsDef) $ setHost "*6" defaultSettings 42 | in catchAny (runSettings settings serverApp) print 43 | 44 | runTestServerTLS :: IO () 45 | runTestServerTLS = 46 | let settings = setPort (httpsTestPort portsDef) $ setHost "*6" defaultSettings 47 | tlsSettings' = tlsSettings "test/certificate.pem" "test/key.pem" 48 | in catchAny (runTLS tlsSettings' settings serverApp) print 49 | 50 | -------------------------------------------------------------------------------- 51 | 52 | serverApp :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived 53 | serverApp req respond 54 | | rawPathInfo req == "/forbidden" = 55 | respond $ simpleResponse status403 "This is the forbidden message.\n" 56 | 57 | | rawPathInfo req == "/301" = do 58 | let respHeaders = [ (hLocation, "http://other-server" <> rawPathInfo req) ] 59 | respond $ responseLBS status301 respHeaders mempty 60 | 61 | | rawPathInfo req == "/large-get" = do 62 | let len = readDecimal_ $ BS.drop 1 $ rawQueryString req 63 | let respHeaders = 64 | [ (hContentType, "text/plain") 65 | , (hContentLength, fromString $ show len) 66 | ] 67 | respond . responseSource status200 respHeaders $ builderSource len 68 | 69 | | rawPathInfo req == "/secure" = do 70 | let body = "Using SSL: " <> BS.pack (show $ isSecure req) 71 | let respHeaders = 72 | [ (hContentType, "text/plain") 73 | , (hContentLength, fromString . show $ BS.length body) 74 | ] 75 | respond $ responseBS status200 respHeaders body 76 | 77 | | rawPathInfo req == "/large-post" && requestMethod req == "POST" = do 78 | let len = maybe 0 readDecimal_ (lookup "content-length" $ requestHeaders req) :: Int64 79 | if len == 0 80 | then respond $ simpleResponse status400 "Error : POST Content-Length was either missing or zero.\n" 81 | else respond =<< largePostCheck len (sourceRequestBody req) 82 | 83 | | otherwise = do 84 | let text = "This is the not-found message.\n\n" : responseBody req 85 | respHeaders = [ (hContentType, "text/plain") ] 86 | respond . responseLBS status404 respHeaders $ LBS.fromChunks text 87 | 88 | 89 | responseBody :: Request -> [ByteString] 90 | responseBody req = 91 | [ " Method : " , requestMethod req , "\n" 92 | , " HTTP Version : " , fromString (show (httpVersion req)) , "\n" 93 | , " Path Info : " , rawPathInfo req , "\n" 94 | , " Query String : " , rawQueryString req , "\n" 95 | , " Server : " , HPR.waiRequestHost req , "\n" 96 | , " Secure (SSL) : " , fromString (show (isSecure req)), "\n" 97 | , " Request Headers :\n" 98 | , headerShow (sort $ requestHeaders req) 99 | , "\n" 100 | ] 101 | 102 | 103 | largePostCheck :: Int64 -> ConduitT () ByteString IO () -> IO Response 104 | largePostCheck len rbody = 105 | maybe success failure <$> (DC.runConduit $ rbody .| byteSink len) 106 | where 107 | success = simpleResponse status200 . BS.pack $ "Post-size: " ++ show len 108 | failure = simpleResponse status500 109 | -------------------------------------------------------------------------------- /test/Test/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, OverloadedStrings #-} 2 | ------------------------------------------------------------ 3 | -- Copyright : Erik de Castro Lopo 4 | -- License : BSD3 5 | ------------------------------------------------------------ 6 | 7 | module Test.Util where 8 | 9 | import Blaze.ByteString.Builder 10 | import Control.Concurrent.Async 11 | import Control.Exception hiding (assert) 12 | import Control.Monad (forM_, when, unless) 13 | import Control.Monad.Trans.Resource (runResourceT) 14 | import Data.ByteString (ByteString) 15 | import Data.Conduit (ConduitT, Flush (..), SealedConduitT) 16 | import Data.Int (Int64) 17 | import Data.Maybe 18 | import Data.String (fromString) 19 | import Network.Socket 20 | import Network.Connection 21 | 22 | import qualified Data.ByteString.Char8 as BS 23 | import qualified Data.ByteString.Lazy.Char8 as LBS 24 | import qualified Data.CaseInsensitive as CI 25 | import qualified Data.Conduit as DC 26 | import qualified Data.Conduit.Binary as CB 27 | import qualified Network.HTTP.Conduit as HC 28 | import qualified Network.HTTP.Types as HT 29 | import qualified Network.Wai as Wai 30 | 31 | import Network.HTTP.Proxy.Request 32 | 33 | 34 | dumpWaiRequest :: Wai.Request -> IO () 35 | dumpWaiRequest req = 36 | mapM_ BS.putStrLn 37 | [ "------- Wai Request --------------------------------------------------------------" 38 | , "Method : " , Wai.requestMethod req 39 | , "HTTP Version : " , fromString (show (Wai.httpVersion req)) 40 | , "Path Info : " , Wai.rawPathInfo req 41 | , "Query String : " , Wai.rawQueryString req 42 | , "Server : " , waiRequestHost req 43 | , "Secure (SSL) : " , fromString (show (Wai.isSecure req)) 44 | , "Remote Host : " , fromString (show (Wai.remoteHost req)) 45 | , "Request Headers :" 46 | , headerShow (Wai.requestHeaders req) 47 | ] 48 | 49 | 50 | dumpHttpConduitRequest :: HC.Request -> IO () 51 | dumpHttpConduitRequest req = 52 | mapM_ BS.putStrLn 53 | [ "------- HttpConduit Request ------------------------------------------------------" 54 | , "Method : " , HC.method req 55 | , "Secure (SSL) : " , fromString (show (HC.secure req)) 56 | , "Host Name : " , HC.host req 57 | , "Host Port : " , fromString (show (HC.port req)) 58 | , "Path : " , HC.path req 59 | , "Query String : " , HT.urlDecode False (HC.queryString req) 60 | , "Request Headers :" 61 | , headerShow (HC.requestHeaders req) 62 | ] 63 | 64 | 65 | dumpHttpResponse :: HT.Status -> HT.ResponseHeaders -> IO () 66 | dumpHttpResponse s rh = do 67 | mapM_ BS.putStrLn 68 | [ "------- Response from upsteam ----------------------------------------------------" 69 | , "HTTP/1.0 ", BS.pack (show (HT.statusCode s)), " ", HT.statusMessage s 70 | ] 71 | BS.putStr . BS.concat $ map (\ (f, v) -> BS.concat [ " ", CI.original f, ": ", v, "\n" ]) rh 72 | 73 | 74 | headerShow :: [HT.Header] -> ByteString 75 | headerShow headers = 76 | BS.concat $ map hdrShow headers 77 | where 78 | hdrShow (f, v) = BS.concat [ " ", CI.original f , ": " , v, "\n" ] 79 | 80 | 81 | -------------------------------------------------------------------------------- 82 | 83 | simpleResponse :: HT.Status -> ByteString -> Wai.Response 84 | simpleResponse status text = do 85 | let respHeaders = 86 | [ (HT.hContentType, "text/plain") 87 | , (HT.hContentLength, fromString . show $ BS.length text) 88 | ] 89 | responseBS status respHeaders text 90 | 91 | 92 | responseBS :: HT.Status -> HT.ResponseHeaders -> ByteString -> Wai.Response 93 | responseBS status headers text = 94 | Wai.responseLBS status headers$ LBS.fromChunks [text] 95 | 96 | -------------------------------------------------------------------------------- 97 | 98 | data Result = Result 99 | { resultSecure :: Bool 100 | , resultStatus :: Int 101 | , resultHeaders :: [HT.Header] 102 | , resultBS :: ByteString 103 | } 104 | 105 | 106 | printResult :: Result -> IO () 107 | printResult (Result _ status headers body) = do 108 | putStrLn $ "Response status : " ++ show status 109 | putStrLn "Response headers :" 110 | BS.putStr $ headerShow headers 111 | putStrLn "Response body :" 112 | BS.putStrLn body 113 | 114 | -------------------------------------------------------------------------------- 115 | 116 | -- | Compare results and error out if they're different. 117 | compareResult :: Result -> Result -> IO () 118 | compareResult (Result secure sa ha ba) (Result _ sb hb bb) = do 119 | assert (sa == sb) $ "HTTP status codes don't match : " ++ show sa ++ " /= " ++ show sb 120 | forM_ [ "server", "content-type", "content-length" ] $ \v -> 121 | assertMaybe (lookup v ha) (lookup v hb) $ \ ja jb -> 122 | "Header field '" ++ show v ++ "' doesn't match : '" ++ show ja ++ "' /= '" ++ show jb 123 | assert (ba == bb) $ "HTTP response bodies are different :\n" ++ BS.unpack ba ++ "\n-----------\n" ++ BS.unpack bb 124 | when (not secure && isJust (lookup "X-Via-Proxy" ha)) $ 125 | error "Error: Direct connection should not contain 'X-Via-Proxy' header." 126 | when (not secure && isNothing (lookup "X-Via-Proxy" hb)) $ 127 | error "Error: Direct connection should not contain 'X-Via-Proxy' header." 128 | where 129 | assert :: Bool -> String -> IO () 130 | assert b = unless b . error 131 | 132 | assertMaybe :: Eq a => Maybe a -> Maybe a -> (a -> a -> String) -> IO () 133 | assertMaybe Nothing _ _ = return () 134 | assertMaybe _ Nothing _ = return () 135 | assertMaybe (Just a) (Just b) fmsg = unless (a == b) . error $ fmsg a b 136 | 137 | 138 | testSingleUrl :: Bool -> Int -> HC.Request -> IO () 139 | testSingleUrl debug testProxyPort request = do 140 | direct <- httpRun request 141 | proxy <- httpRun $ addTestProxy testProxyPort request 142 | when debug $ do 143 | printResult direct 144 | printResult proxy 145 | compareResult direct proxy 146 | 147 | 148 | addTestProxy :: Int -> HC.Request -> HC.Request 149 | addTestProxy = HC.addProxy "localhost" 150 | 151 | 152 | -- | Use HC.http to fullfil a HC.Request. We need to wrap it because the 153 | -- Response contains a Source which we need to read to generate our result. 154 | httpRun :: HC.Request -> IO Result 155 | httpRun req = do 156 | mgr <- HC.newManager $ HC.mkManagerSettings (TLSSettingsSimple True False False) Nothing 157 | runResourceT $ do 158 | resp <- HC.http (modifyRequest req) mgr 159 | let contentLen = readInt64 <$> lookup HT.hContentLength (HC.responseHeaders resp) 160 | bodyText <- checkBodySize (DC.sealConduitT $ HC.responseBody resp) contentLen 161 | return $ Result (HC.secure req) (HT.statusCode $ HC.responseStatus resp) 162 | (HC.responseHeaders resp) bodyText 163 | where 164 | modifyRequest r = r { HC.redirectCount = 0 } 165 | 166 | 167 | checkBodySize :: Monad f => SealedConduitT () ByteString f () -> Maybe Int64 -> f ByteString 168 | checkBodySize bodySrc Nothing = fmap (BS.concat . LBS.toChunks) $ bodySrc DC.$$+- CB.take 1000 169 | checkBodySize bodySrc (Just len) = do 170 | let blockSize = 1000 171 | if len <= blockSize 172 | then checkBodySize bodySrc Nothing 173 | else fromMaybe "Success" <$> (bodySrc DC.$$+- byteSink len) 174 | 175 | 176 | byteSink :: Monad m => Int64 -> ConduitT ByteString a m (Maybe ByteString) 177 | byteSink bytes = sink 0 178 | where 179 | sink :: Monad m => Int64 -> ConduitT ByteString a m (Maybe ByteString) 180 | sink !count = DC.await >>= maybe (closeSink count) (sinkBlock count) 181 | 182 | sinkBlock :: Monad m => Int64 -> ByteString -> ConduitT ByteString a m (Maybe ByteString) 183 | sinkBlock !count bs = sink (count + fromIntegral (BS.length bs)) 184 | 185 | closeSink :: Monad m => Int64 -> m (Maybe ByteString) 186 | closeSink !count = return $ 187 | if count == bytes 188 | then Nothing 189 | else Just . BS.pack $ "Error : Body length " ++ show count 190 | ++ " should have been " ++ show bytes ++ "." 191 | 192 | 193 | builderSource :: Monad m => Int64 -> ConduitT () (Flush Builder) m () 194 | builderSource = DC.mapOutput (Chunk . fromByteString) . byteSource 195 | 196 | 197 | byteSource :: Monad m => Int64 -> ConduitT i ByteString m () 198 | byteSource bytes = loop 0 199 | where 200 | loop :: Monad m => Int64 -> ConduitT i ByteString m () 201 | loop !count 202 | | count >= bytes = return () 203 | | count + blockSize64 < bytes = do 204 | DC.yield bsbytes 205 | loop $ count + blockSize64 206 | | otherwise = do 207 | let n = fromIntegral $ bytes - count 208 | DC.yield $ BS.take n bsbytes 209 | pure () 210 | 211 | blockSize = 8192 :: Int 212 | blockSize64 = fromIntegral blockSize :: Int64 213 | bsbytes = BS.replicate blockSize '?' 214 | 215 | 216 | readInt64 :: ByteString -> Int64 217 | readInt64 = read . BS.unpack 218 | 219 | 220 | catchAny :: IO a -> (SomeException -> IO a) -> IO a 221 | catchAny action onE = 222 | withAsync action waitCatch >>= either onE return 223 | 224 | 225 | openLocalhostListenSocket :: IO (Socket, Port) 226 | openLocalhostListenSocket = do 227 | sock <- socket AF_INET Stream defaultProtocol 228 | addr:_ <- getAddrInfo Nothing (Just "127.0.0.1") Nothing 229 | bind sock (addrAddress addr) 230 | listen sock 10 231 | port <- fromIntegral <$> socketPort sock 232 | return (sock, port) 233 | 234 | -------------------------------------------------------------------------------- /test/Test/Wai.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | ------------------------------------------------------------ 3 | -- Copyright : Erik de Castro Lopo 4 | -- License : BSD3 5 | ------------------------------------------------------------ 6 | 7 | module Test.Wai where 8 | 9 | import Network.Wai.Internal 10 | import Test.Hspec 11 | 12 | waiShouldBe :: Request -> Request -> Expectation 13 | waiShouldBe a b = do 14 | requestMethod a `shouldBe` requestMethod b 15 | httpVersion a `shouldBe` httpVersion b 16 | rawPathInfo a `shouldBe` rawPathInfo b 17 | rawQueryString a `shouldBe` rawQueryString b 18 | requestHeaders a `shouldBe` requestHeaders b 19 | isSecure a `shouldBe` isSecure b 20 | remoteHost a `shouldBe` remoteHost b 21 | pathInfo a `shouldBe` pathInfo b 22 | queryString a `shouldBe` queryString b 23 | -- requestBody a 24 | -- vault a `shouldBe` vault b 25 | -- requestBodyLength a `shouldBe` requestBodyLength b 26 | requestHeaderHost a `shouldBe` requestHeaderHost b 27 | requestHeaderRange a `shouldBe` requestHeaderRange b 28 | 29 | 30 | -------------------------------------------------------------------------------- /test/certificate.csr: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE REQUEST----- 2 | MIIEkzCCAnsCAQAwTjELMAkGA1UEBhMCQVUxDDAKBgNVBAgMA05TVzEPMA0GA1UE 3 | BwwGU3lkbmV5MQwwCgYDVQQKDANEaXMxEjAQBgNVBAMMCWxvY2FsaG9zdDCCAiIw 4 | DQYJKoZIhvcNAQEBBQADggIPADCCAgoCggIBAL31MqGdFJps3iVNzSLx20wiCpZO 5 | gT7GhzVFyH6wgh8hYloWtBL9UqKOjJztMno/7a+HF7Bto6Z9C2hM2dN7nqiMsazQ 6 | bp0iKmnslCCCROO5FvZq/Sy508feOTs9tpYoNxNcg/O48uJYf7pP76RMp3i7OKNg 7 | JksKYxPSkmn9ioJsiHPMLw0YxxiHtuaWZEJzQwQOPm3gF/nUsSHJafnnF9W6axMH 8 | cJE4kRL7ctAdJ3xLokG6IQ8QlQSDuW/POYqEAICpd7nQt/+bsqWSbHyoY69Q9dj/ 9 | GLfHzQO2CWBML3+VlO+nAVjDTDJy/KVtFv84kIKQN1two4TieTRmHjMN0h07u0dD 10 | uGQQkz4Gf5mQCDBK7ehNPy2RO+3vfr9rTd4NCFIqQwUqPfe0AYRqioN7KZfpnPaS 11 | gPRiskN+nDWwfBGm6uCQKDR9KndxpTam/UzMFeH7IGReICc+ehzmNXplhImapXTi 12 | W6WE8wM6ai/db7jaCEW9T3UL9Jp6QzZW6o86yFw4rnimyx319bSRtU4FuTfQ6IVg 13 | iqmyIhExZnaopEOGG4irKfhkuhau8KlWNN2umhY7NokCXwJdA1VxU3sGU7O4m98K 14 | B5eQox/go9hvVSpzE4CQwE6opnLZ0vSj4v9e5DVNXDfHgdxv4qwGTFaugvqL0Qyj 15 | Op9AluZzprnocUgRAgMBAAGgADANBgkqhkiG9w0BAQsFAAOCAgEAhHTtRAU3WOhy 16 | UzvNu4uCN3UG5f52MJfqsguuyWtanaOv51b5i2LPA+IIk/TweEeeEELu1QTb08w7 17 | yxe5rurLwOEES3EJ0CtUSwfF+GdxdmQfwvbmgSDAKtfLJDhZSpdEVyQYSNi2Y/R5 18 | K4wwfYb3jt8qPLUeXwM2Hd1EvmIt9EbIgGkOZUZRJiYdw3HsXJY0tHMu1j5Yxj3j 19 | mZ0e1zzTaFiI/si8q0r3diuCt8e88HEca90sanWZ0yjY1RHFVfV07ah6jvwm9u3E 20 | 3K7xQO3uanLrx5eFtab2wWGIICqVw/cyol/E8MvCF2LtKQ08/LMFP0o+SqbLgS9/ 21 | FaKRBGvHszdSZeWxmsh3uUAGdH6UIDNeMmj696pFgFPfkYCWQEeTD7Q+AxeckWlu 22 | +8fhScRDyh4FuMfwj+e7X+Cwd7hd97+rUdRHD2HQb4+L49iPWHtaVQ150n6eFfrV 23 | PLLbguUFCkQ7+ctncTv6B8aXd/9supwi7n7JRQiIpKT61KKCxf9vsFaZ+Yj2qKZU 24 | O1NdW2PohkHSLKCrLGGZahRnluBZRbPNreZyJ2jdJoIE8Dzi9on4qlV7suM5kBwp 25 | BJwZda7RrD/zPVe0Si7KAehRExowtrLnVLd6KJfN5Z004fKkNIyXk41+/8k7fD4S 26 | /1i2GYnd8IgE/eLcfCkeviNVFes3i2I= 27 | -----END CERTIFICATE REQUEST----- 28 | -------------------------------------------------------------------------------- /test/certificate.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIFGDCCAwACCQDHKKu5PKDfkTANBgkqhkiG9w0BAQsFADBOMQswCQYDVQQGEwJB 3 | VTEMMAoGA1UECAwDTlNXMQ8wDQYDVQQHDAZTeWRuZXkxDDAKBgNVBAoMA0RpczES 4 | MBAGA1UEAwwJbG9jYWxob3N0MB4XDTE1MDQwMjA1MTgyNVoXDTE1MDUwMjA1MTgy 5 | NVowTjELMAkGA1UEBhMCQVUxDDAKBgNVBAgMA05TVzEPMA0GA1UEBwwGU3lkbmV5 6 | MQwwCgYDVQQKDANEaXMxEjAQBgNVBAMMCWxvY2FsaG9zdDCCAiIwDQYJKoZIhvcN 7 | AQEBBQADggIPADCCAgoCggIBAL31MqGdFJps3iVNzSLx20wiCpZOgT7GhzVFyH6w 8 | gh8hYloWtBL9UqKOjJztMno/7a+HF7Bto6Z9C2hM2dN7nqiMsazQbp0iKmnslCCC 9 | ROO5FvZq/Sy508feOTs9tpYoNxNcg/O48uJYf7pP76RMp3i7OKNgJksKYxPSkmn9 10 | ioJsiHPMLw0YxxiHtuaWZEJzQwQOPm3gF/nUsSHJafnnF9W6axMHcJE4kRL7ctAd 11 | J3xLokG6IQ8QlQSDuW/POYqEAICpd7nQt/+bsqWSbHyoY69Q9dj/GLfHzQO2CWBM 12 | L3+VlO+nAVjDTDJy/KVtFv84kIKQN1two4TieTRmHjMN0h07u0dDuGQQkz4Gf5mQ 13 | CDBK7ehNPy2RO+3vfr9rTd4NCFIqQwUqPfe0AYRqioN7KZfpnPaSgPRiskN+nDWw 14 | fBGm6uCQKDR9KndxpTam/UzMFeH7IGReICc+ehzmNXplhImapXTiW6WE8wM6ai/d 15 | b7jaCEW9T3UL9Jp6QzZW6o86yFw4rnimyx319bSRtU4FuTfQ6IVgiqmyIhExZnao 16 | pEOGG4irKfhkuhau8KlWNN2umhY7NokCXwJdA1VxU3sGU7O4m98KB5eQox/go9hv 17 | VSpzE4CQwE6opnLZ0vSj4v9e5DVNXDfHgdxv4qwGTFaugvqL0QyjOp9AluZzprno 18 | cUgRAgMBAAEwDQYJKoZIhvcNAQELBQADggIBAJD7mAKezWyicUnwkySUiZEb0ztA 19 | xWX7IDwnWvj/j3YRSfd18uPOSvhNQ9cQJlX1W6YNp2C0HWNaV2xCyinR5CtgIP+w 20 | noFhxjEPtGkDbefnM6gPv8HLjrbokr6QK4Eq6LDzpriJEEus4Sc9t2+5J8hMNduj 21 | GR4gN4+xtuQubI9+pLVN929HUjvgNxh8M4suXNaIkMZ4DdpbknZS8Evlzcy45eu2 22 | a4VV7o66rOfyMJ6dAB1JLm8xkIMOUdbMCXpBZsiCJ/5r2oDw9TWH3EQaMQrRqPjW 23 | QPuNy4B+Z/YaWSiYkvSIiNWYIWR6oQLJN1qN84blj5i8GEvAoM61wu518kUSs+Th 24 | HOPFW4AnvRLZamUGEZPK7Vgeji7AQjAWO7pAAeG2nbxX+ZbIvTYpYbXXz0p0dWvh 25 | hXbeMPxnGR3c7oHPRIX/bXMr+czUojQA52QcShbPbl2qLOed5YNLL/SltrUduYXo 26 | 7j2RNy3g5EXlBSXZlIWAutSjIQ0x9DQi4jWtKmMNjsOjGi5kO5h7x1y1SmXiQH4J 27 | CoTfo6nIAAkWF+uDJWrenwGZc+h2uBYI3UbfU7NcA9LcQ2Zf7m5Jwn7mCDP1mgMG 28 | G3CF962vJtkdiZ/EjBiCUdkAXxDxQnoTs8hQGLXKHhTSEtWTrvOODoTSWMxJZi27 29 | 0nxVdFmW9y7shBA4 30 | -----END CERTIFICATE----- 31 | -------------------------------------------------------------------------------- /test/create_certificate.mk: -------------------------------------------------------------------------------- 1 | #!/usr/bin/make -f 2 | 3 | # Generate SSL certificate and keys for the tests. 4 | # Partially taken from: 5 | # https://github.com/yesodweb/wai/blob/master/warp-tls/README.md 6 | 7 | KEY_EXPIRE = 3650 8 | KEY_COUNTRY = AU 9 | KEY_PROVINCE = NSW 10 | KEY_CITY = Sydney 11 | KEY_SIZE = 4096 12 | KEY_SUBJECT = "/C=$(KEY_COUNTRY)/ST=$(KEY_PROVINCE)/L=$(KEY_CITY)/O=Dis/CN=localhost" 13 | KEY_PASSWORD = "This is not so secret." 14 | 15 | certificate.pem : certificate.csr 16 | openssl x509 -req -in certificate.csr -signkey key.pem -out $@ 17 | 18 | certificate.csr : key.pem 19 | openssl req -new -key key.pem \ 20 | -days $(KEY_EXPIRE) \ 21 | -subj $(KEY_SUBJECT) \ 22 | -passout pass:$(KEY_PASSWORD) \ 23 | -out $@ 24 | 25 | key.pem : create_certificate.mk 26 | openssl genrsa -out $@ $(KEY_SIZE) 27 | -------------------------------------------------------------------------------- /test/key.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIIJKQIBAAKCAgEAvfUyoZ0UmmzeJU3NIvHbTCIKlk6BPsaHNUXIfrCCHyFiWha0 3 | Ev1Soo6MnO0yej/tr4cXsG2jpn0LaEzZ03ueqIyxrNBunSIqaeyUIIJE47kW9mr9 4 | LLnTx945Oz22lig3E1yD87jy4lh/uk/vpEyneLs4o2AmSwpjE9KSaf2KgmyIc8wv 5 | DRjHGIe25pZkQnNDBA4+beAX+dSxIclp+ecX1bprEwdwkTiREvty0B0nfEuiQboh 6 | DxCVBIO5b885ioQAgKl3udC3/5uypZJsfKhjr1D12P8Yt8fNA7YJYEwvf5WU76cB 7 | WMNMMnL8pW0W/ziQgpA3W3CjhOJ5NGYeMw3SHTu7R0O4ZBCTPgZ/mZAIMErt6E0/ 8 | LZE77e9+v2tN3g0IUipDBSo997QBhGqKg3spl+mc9pKA9GKyQ36cNbB8Eabq4JAo 9 | NH0qd3GlNqb9TMwV4fsgZF4gJz56HOY1emWEiZqldOJbpYTzAzpqL91vuNoIRb1P 10 | dQv0mnpDNlbqjzrIXDiueKbLHfX1tJG1TgW5N9DohWCKqbIiETFmdqikQ4YbiKsp 11 | +GS6Fq7wqVY03a6aFjs2iQJfAl0DVXFTewZTs7ib3woHl5CjH+Cj2G9VKnMTgJDA 12 | TqimctnS9KPi/17kNU1cN8eB3G/irAZMVq6C+ovRDKM6n0CW5nOmuehxSBECAwEA 13 | AQKCAgBxLg8ky/rip8sUXu7Cy2fmTMISHGRViuQ0kYeMNI7TDYkUNELGrbj2sgiF 14 | 164juMNduhgbPrgrEoYhduiyYQ1/T5TtaqL9bMXoptT7KaLyK+3KlKSUaYQNqhJf 15 | gb2wafWmy5CzPpc41ZIE6GvYcPO3s5Vjgn5OZ7nwrZ4fGLnWS+RhWl8OZpz5uKL5 16 | cNH75cEgQXxg6wxeBqQjhWZnR5Gj/padl+kyHYoSzU7zQOut20Kp9sSLvU2Miw+J 17 | 1uZp6YyDHHYBeKKo4ZPnov6Qp6P9aTeSOyv3FEzK0UN05O/IDM/YmqDqyjI0PN7b 18 | kcwJ9SHlKRhSmyJSor2kwtNrh+iQCgN6kdRlAWzCOBzn5bul44eSyd/FcNbJ+75K 19 | gATMl6XazfLHuov3Xqgz9/DFYRpLjkBpbcJ5lArJFxR1tAM1E6nnlzfzVsRIsfec 20 | hhV73P9CvZ+htje29Io+LfNtwpOBgV8rBEeUQAaJx26RAIAOZEJuaEQrJxWEXsh4 21 | Bli7fdHuSn+TDEzAgsuvaT7upf56tWrBV1cthUvrNIN5aIQ43CdHrBnvgaon1/WQ 22 | uFmvJSk6P5qI6bUmMef0AupjLtwJgXFlN7WjYYdpw1ApA2mZq3DLxAtJChBTVVkH 23 | mEgaPkIDhGTOjTT0F1ebRY74BUX9If+iq94pIwgmxiJVEQ0TgQKCAQEA9oratnGb 24 | G1X3zxhdVxekkroS29/4e0nTrXJnonAHrAdZqE3rrBKgmI5wJDTFtRLSRDjgWh70 25 | EH0hln8CpkqyoFVnqu1SAegXt9PbOVB1mOo7rt3RXKABWJt1CujAV7sRF2MBhqC7 26 | eWt31t5do6JUyIB+4G8KxzuucndO04yn8Bgts+q2uQF8XmhWr5Bw/obUAAkoxlrS 27 | t0reQw2uOsP7jDds+SrKNnHoYhSH9sTbOULgNcjsLP8PwKQaOYit3UMLVIkB1gFH 28 | QnI7J9sj81YqDwxulIsqEfmYXijC0EjD6wpGr3gv2em6iWugL9GtaOitArNhMK55 29 | 2/IDQRFnTirL5QKCAQEAxT6o7/2uA4vRYdbzMncasuv9m9aViLosmSm5t3VUilEl 30 | 5yVeAgABY7nd/WaYQtAlabs0mYs63PUBy87c3T0cynweT1X70okhUumLsijQyPE5 31 | VLBM5YlK5gTs0yjhWca3eJuwVUMRBEX46gVyJYzjBHciGufx+7XAoKbHXsDBpLTS 32 | macwduOCVfbg0HrTqPdUG7uZo2oT8qY1f4hDIcoIuJePouGTb06R1Ut5PMDjXTZH 33 | Ak1n8BVrWloNdthzTvAVwxdHTH/Q6f8ZNGRX1ljqv75UZ8kDgtc/q8iiehNEK3Hc 34 | 878WjEedpmbFJ/gUtehUguVPRdsnHbnABBtcBWnAvQKCAQEAs6E79c4UWvhqE8QG 35 | zhv11sooT3eCTiHeTvOaOqoxjM/WLWCIo9j2lfDCGD8zBdluxjJClKcU4KarQEHO 36 | JmcqetN/MvSy2ZzHGzMK+Vl8NSwEzEXl8vzJvkuWHZqz+bfcnhOO2w5lSfRZXn6p 37 | 7z2pVGT7DH8bdUowsknnbw9+lNqpAfuzolxIx2hyMHynN2v5LwV9Zfhqqw2rn2Nq 38 | XHrK3sDLb0gUCVM5I60d21hW+gOV5No96hL04UEvsle5hgsBSFiCs/A+gVVFcKak 39 | LPnMryY5s5Up0+rtbz13o9ZAmRHlqpeBFd7MALAgCHdXR6av19XmrFeThgNxB4ms 40 | oTFhWQKCAQB6sr/kiqn1CsT1WAFxIyY4pxTcHGBo7WdQ3+Pne9VbNZ+eamBQXjB/ 41 | GOA/AdM1vMWJQCs4WKQFT2QOpGBAQAPo8czpDVPZY/SW3zFHYpx+Y5CGXiV3pDAz 42 | Zlzr/kIw1qzLGg5W+6FaRyzQZxLayQlvfax5kE+3hRiO1zCugLn0+4cGjjpXuq8Z 43 | SroO9lk0gqaPmeO5BAPkrgAZlWotWsCSE7YGXMyaMQYG6SxB3ruRAHKru/ssHibp 44 | zZsSkxMnx7HB6nkv3VLYPRgwvzrk2+sr2/ollaXZfozdD7ICvnlpjSsldXlRSjuH 45 | h+adNnWrsxrfUkY97lYm56XK6DoWI/MBAoIBAQCC9fD4E40fSpqozZ4Nt0CuhdB7 46 | Vh0Aba5fsTadV7cFuztfU31RLnx59YkZx9OhBNy7FLdwJeXdPWPmXoXTOuWvf/Dj 47 | 9qnasT6L0FOl37qwlVAFECkL3YEZE7gyPmX/W98y3xNFqGVrWyzrjMQweNQfBLsk 48 | ldyEqYDfdDJ7RJenhYfvKURrkxiIqUhemmlljyQOFv3xro8Stp5GuddT3byNFMnb 49 | 3Bi6B7glrs4qfaeCrIop+C4DMunShVmC89BrmV1QIC1QEcH9DLoogPslJbeLQA9m 50 | /So0tMswXU0ghRuZ3NwMPYMtXiKMmQJ5pPzLOKLA1fjuYaY7EyBniL+NtV1r 51 | -----END RSA PRIVATE KEY----- 52 | -------------------------------------------------------------------------------- /test/test-io.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | ------------------------------------------------------------ 4 | -- Copyright : Erik de Castro Lopo 5 | -- License : BSD3 6 | ------------------------------------------------------------ 7 | 8 | import Control.Concurrent.Async 9 | import Control.Exception 10 | import Control.Monad 11 | import Data.Conduit 12 | import Data.Int (Int64) 13 | #if ! MIN_VERSION_base(4,11,0) 14 | import Data.Monoid ((<>)) 15 | #endif 16 | import System.Environment 17 | import Test.Hspec 18 | 19 | import qualified Data.ByteString.Char8 as BS 20 | import qualified Data.CaseInsensitive as CI 21 | import qualified Network.HTTP.Conduit as HC 22 | import qualified Network.HTTP.Types as HT 23 | import qualified Network.Wai as Wai 24 | 25 | import Network.HTTP.Proxy 26 | 27 | import Test.TestServer 28 | import Test.Util 29 | import Test.Request 30 | import Test.ServerDef 31 | 32 | 33 | proxyTestDebug :: Bool 34 | proxyTestDebug = False 35 | 36 | main :: IO () 37 | main = do 38 | -- Clear the `http_proxy` enviroment variable. 39 | unsetEnv "http_proxy" 40 | bracket 41 | (mapM async [ runTestServer, runTestServerTLS ]) 42 | (mapM_ cancel) 43 | (const $ runProxyTests proxyTestDebug) 44 | 45 | runProxyTests :: Bool -> IO () 46 | runProxyTests dbg = hspec $ do 47 | testHelpersTest 48 | proxyTest Http dbg 49 | protocolTest 50 | proxyTest Https dbg 51 | streamingTest dbg 52 | requestTest 53 | 54 | -- ----------------------------------------------------------------------------- 55 | 56 | testHelpersTest :: Spec 57 | testHelpersTest = 58 | -- Test the HTTP and HTTPS servers directly (ie bypassing the Proxy). 59 | describe "Test helper functionality:" $ do 60 | it "Byte Sink catches short response bodies." $ 61 | runConduit (byteSource 80 .| byteSink 100) 62 | `shouldReturn` Just "Error : Body length 80 should have been 100." 63 | it "Byte Source and Sink work in constant memory." $ 64 | runConduit (byteSource oneBillion .| byteSink oneBillion) `shouldReturn` Nothing 65 | it "Byte Sink catches long response bodies." $ 66 | runConduit (byteSource 110 .| byteSink 100) 67 | `shouldReturn` Just "Error : Body length 110 should have been 100." 68 | it "Client and server can stream GET response." $ do 69 | let size = oneBillion 70 | sizeStr = show size 71 | result <- httpRun =<< mkGetRequest Http ("/large-get?" ++ sizeStr) 72 | resultStatus result `shouldBe` 200 73 | lookup HT.hContentLength (resultHeaders result) `shouldBe` Just (BS.pack sizeStr) 74 | it "Client and server can stream POST request." $ do 75 | let size = oneMillion 76 | sizeStr = show size 77 | body = HC.requestBodySourceIO size $ byteSource size 78 | result <- httpRun =<< mkPostRequestBody Http ("/large-post?" ++ sizeStr) body 79 | resultStatus result `shouldBe` 200 80 | resultBS result `shouldBe` BS.pack ("Post-size: " ++ sizeStr) 81 | 82 | 83 | proxyTest :: UriScheme -> Bool -> Spec 84 | proxyTest uris dbg = around withDefaultTestProxy $ 85 | describe ("Simple " ++ show uris ++ " proxying:") $ do 86 | let tname = show uris 87 | it (tname ++ " GET.") $ \ testProxyPort -> 88 | testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/" 89 | it (tname ++ " GET with query.") $ \ testProxyPort -> 90 | testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/a?b=1&c=2" 91 | it (tname ++ " GET with request body.") $ \ testProxyPort -> 92 | testSingleUrl dbg testProxyPort =<< mkGetRequestWithBody uris "/" "Hello server!" 93 | it (tname ++ " GET /forbidden returns 403.") $ \ testProxyPort -> 94 | testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/forbidden" 95 | it (tname ++ " GET /not-found returns 404.") $ \ testProxyPort -> 96 | testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/not-found" 97 | it (tname ++ " POST.") $ \ testProxyPort -> 98 | testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/" 99 | it (tname ++ " POST with request body.") $ \ testProxyPort -> 100 | testSingleUrl dbg testProxyPort =<< mkPostRequestBS uris "/" "Hello server!" 101 | it (tname ++ " POST /forbidden returns 403.") $ \ testProxyPort -> 102 | testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/forbidden" 103 | it (tname ++ " POST /not-found returns 404.") $ \ testProxyPort -> 104 | testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/not-found" 105 | 106 | 107 | protocolTest :: Spec 108 | protocolTest = around withDefaultTestProxy $ 109 | describe "HTTP protocol:" $ 110 | it "Passes re-directs through to client." $ \ testProxyPort -> do 111 | req <- addTestProxy testProxyPort <$> mkGetRequest Http "/301" 112 | result <- httpRun req 113 | resultStatus result `shouldBe` 301 114 | lookup HT.hLocation (resultHeaders result) `shouldBe` Just "http://other-server/301" 115 | 116 | 117 | -- Only need to do this test for HTTP not HTTPS (because it just streams bytes 118 | -- back and forth). 119 | streamingTest :: Bool -> Spec 120 | streamingTest dbg = around withDefaultTestProxy $ 121 | describe "HTTP streaming via proxy:" $ do 122 | forM_ [ 100, oneThousand, oneMillion, oneBillion ] $ \ size -> 123 | it ("Http GET " ++ show (size :: Int64) ++ " bytes.") $ \ testProxyPort -> 124 | testSingleUrl dbg testProxyPort =<< mkGetRequest Http ("/large-get?" ++ show size) 125 | forM_ [ 100, oneThousand, oneMillion, oneBillion ] $ \ size -> 126 | it ("Http POST " ++ show (size :: Int64) ++ " bytes.") $ \ testProxyPort -> do 127 | let body = HC.requestBodySourceIO size $ byteSource size 128 | testSingleUrl dbg testProxyPort =<< mkPostRequestBody Http ("/large-post?" ++ show size) body 129 | 130 | 131 | -- Test that a Request can be pulled apart and reconstructed without losing 132 | -- anything. 133 | requestTest :: Spec 134 | requestTest = describe "Request:" $ do 135 | it "Can add a request header." $ 136 | withTestProxy proxySettingsAddHeader $ \ testProxyPort -> do 137 | req <- addTestProxy testProxyPort <$> mkGetRequest Http "/whatever" 138 | result <- httpRun req 139 | "X-Test-Header: Blah" `BS.isInfixOf` resultBS result `shouldBe` True 140 | it "Can rewrite HTTP to HTTPS." $ 141 | withTestProxy proxySettingsHttpsUpgrade $ \ testProxyPort -> do 142 | req <- addTestProxy testProxyPort <$> mkGetRequest Http "/secure" 143 | result <- httpRun req 144 | -- Getting a TlsException shows that we have successfully upgraded 145 | -- from HTTP to HTTPS. Its not possible to ignore this failure 146 | -- because its made by the http-conduit inside the proxy. 147 | BS.takeWhile (/= ' ') (resultBS result) `shouldBe` "HttpExceptionRequest" 148 | it "Can provide a proxy Response." $ 149 | withTestProxy proxySettingsProxyResponse $ \ testProxyPort -> do 150 | req <- addTestProxy testProxyPort <$> mkGetRequest Http "/whatever" 151 | result <- httpRun req 152 | resultBS result `shouldBe` "This is the proxy reqponse" 153 | 154 | -- ----------------------------------------------------------------------------- 155 | 156 | oneThousand, oneMillion, oneBillion :: Int64 157 | oneThousand = 1000 158 | oneMillion = oneThousand * oneThousand 159 | oneBillion = oneThousand * oneMillion 160 | 161 | 162 | withDefaultTestProxy :: (Int -> IO ()) -> IO () 163 | withDefaultTestProxy action = do 164 | (sock, portnum) <- openLocalhostListenSocket 165 | bracket (async $ runProxySettingsSocket defaultProxySettings sock) cancel (const $ action portnum) 166 | 167 | 168 | withTestProxy :: Settings -> (Int -> Expectation) -> Expectation 169 | withTestProxy settings expectation = do 170 | (sock, portnum) <- openLocalhostListenSocket 171 | bracket (async $ runProxySettingsSocket settings sock) cancel (const $ expectation portnum) 172 | 173 | 174 | proxySettingsAddHeader :: Settings 175 | proxySettingsAddHeader = defaultProxySettings 176 | { proxyHttpRequestModifier = \ req -> return . Right $ req 177 | { requestHeaders = (CI.mk "X-Test-Header", "Blah") : requestHeaders req 178 | } 179 | } 180 | 181 | proxySettingsHttpsUpgrade :: Settings 182 | proxySettingsHttpsUpgrade = defaultProxySettings 183 | { proxyHttpRequestModifier = \ req -> return . Right $ req { requestPath = httpsUpgrade $ requestPath req } 184 | } 185 | where 186 | httpsUpgrade bs = 187 | let (start, end) = BS.breakSubstring (bsShow $ httpTestPort portsDef) bs 188 | https = bsShow $ httpsTestPort portsDef 189 | in "https" <> BS.drop 4 start <> https <> BS.drop 5 end 190 | bsShow = BS.pack . show 191 | 192 | proxySettingsProxyResponse :: Settings 193 | proxySettingsProxyResponse = defaultProxySettings 194 | { proxyHttpRequestModifier = const . return $ Left proxyResponse 195 | } 196 | where 197 | proxyResponse :: Wai.Response 198 | proxyResponse = simpleResponse HT.status200 "This is the proxy reqponse" 199 | -------------------------------------------------------------------------------- /test/test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | ------------------------------------------------------------ 4 | -- Copyright : Erik de Castro Lopo 5 | -- License : BSD3 6 | ------------------------------------------------------------ 7 | 8 | import Test.Hspec (Spec, describe, hspec) 9 | import Test.Hspec.QuickCheck (prop) 10 | 11 | import Network.HTTP.Proxy.Request 12 | 13 | import Test.Gen 14 | import Test.QuickCheck 15 | 16 | import Test.Wai 17 | 18 | 19 | 20 | main :: IO () 21 | main = 22 | hspec requestTest 23 | 24 | -- Test that a Request can be pulled apart and reconstructed without losing 25 | -- anything. 26 | requestTest :: Spec 27 | requestTest = describe "Request:" $ 28 | prop "Roundtrips with waiRequest." $ forAll genWaiRequest $ \wreq -> 29 | wreq `waiShouldBe` (waiRequest wreq . proxyRequest) wreq 30 | --------------------------------------------------------------------------------