http-reverse-proxy 0.4.5 → 0.6.2.0
raw patch · 5 files changed
Files
- ChangeLog.md +35/−0
- Network/HTTP/ReverseProxy.hs +150/−61
- README.md +35/−0
- http-reverse-proxy.cabal +67/−56
- test/main.hs +60/−20
ChangeLog.md view
@@ -1,3 +1,38 @@+## 0.6.2.0++# Changes internal handling of the `X-Forwarded-For` header (avoids `Text` round-trips, tolerates invalid UTF-8) [#49](https://github.com/fpco/http-reverse-proxy/pull/49)++## 0.6.1.0++* Add the `wpsModifyResponseHeaders` option to `WaiProxySettings` to tweak response headers before they are returned upstream. [#48](https://github.com/fpco/http-reverse-proxy/pull/48)++## 0.6.0.3++* Fix a regression introduced in 0.6.0.2: wrong 'Content-Length' header is preserved for responses with encoded content. [#47](https://github.com/fpco/http-reverse-proxy/pull/47)++## 0.6.0.2++* Fix docker registry reverse proxying by preserving the 'Content-Length' response header to HTTP/2 and HEAD requests. [#45](https://github.com/fpco/http-reverse-proxy/pull/45)++## 0.6.0.1++* Introduce a "semi cached body" to let the beginning of a request body be retried [#34](https://github.com/fpco/http-reverse-proxy/issues/34)+* Add `wpsLogRequest` function which provides the ability to log the+ constructed `Request`.++## 0.6.0++* Switch over to `unliftio` and conduit 1.3+* Drop dependency on `data-default-class`, drop `Default` instances++## 0.5.0.1++* Support http-conduit 2.3 in test suite [#26](https://github.com/fpco/http-reverse-proxy/issues/26)++## 0.5.0++* update `wpsProcessBody` to accept response's initial request+ ## 0.4.5 * add `Eq, Ord, Show, Read` instances to `ProxyDest`
Network/HTTP/ReverseProxy.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-}+ module Network.HTTP.ReverseProxy ( -- * Types ProxyDest (..)@@ -19,13 +20,15 @@ , WaiProxyResponse (..) -- ** Settings , WaiProxySettings- , def+ , defaultWaiProxySettings , wpsOnExc , wpsTimeout , wpsSetIpHeader , wpsProcessBody , wpsUpgradeToRaw , wpsGetDest+ , wpsLogRequest+ , wpsModifyResponseHeaders , SetIpHeader (..) -- *** Local settings , LocalWaiProxySettings@@ -40,15 +43,7 @@ import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString) import Control.Applicative ((<$>), (<|>))-import Control.Concurrent.Async (concurrently)-import Control.Concurrent.Lifted (fork, killThread)-import Control.Concurrent.MVar.Lifted (newEmptyMVar, putMVar,- takeMVar)-import Control.Exception (bracket)-import Control.Exception.Lifted (SomeException, finally, try)-import Control.Monad (unless, void)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad (unless) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8@@ -57,10 +52,11 @@ import Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Conduit.Network as DCN-import Data.Default.Class (Default (..), def) import Data.Functor.Identity (Identity (..)) import Data.IORef-import Data.Maybe (fromMaybe, listToMaybe)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromMaybe, isNothing, listToMaybe) import Data.Monoid (mappend, mconcat, (<>)) import Data.Set (Set) import qualified Data.Set as Set@@ -68,7 +64,6 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.Text as T-import qualified Data.Text.Encoding as TE import Data.Word8 (isSpace, _colon, _cr) import GHC.Generics (Generic) import Network.HTTP.Client (BodyReader, brRead)@@ -76,7 +71,7 @@ import qualified Network.HTTP.Types as HT import qualified Network.Wai as WAI import Network.Wai.Logger (showSockAddr)-import System.Timeout.Lifted (timeout)+import UnliftIO (MonadIO, liftIO, MonadUnliftIO, timeout, SomeException, try, bracket, concurrently_) -- | Host\/port combination to which we want to proxy. data ProxyDest = ProxyDest@@ -84,6 +79,23 @@ , pdPort :: !Int } deriving (Read, Show, Eq, Ord, Generic) +-- | Trim optional whitespace (OWS) from both ends of a strict 'ByteString'.++-- Per RFC 7230 §3.2.3, OWS = SP / HTAB. This function removes only leading+-- and trailing space (0x20) and horizontal tab (0x09) bytes. It does not+-- modify internal whitespace.++-- On newer @bytestring@ versions (those that provide+-- 'Data.ByteString.Char8.strip') this is a thin wrapper around that+-- function; on older versions we provide a compatible fallback.+trimOWS :: S8.ByteString -> S8.ByteString+#if MIN_VERSION_bytestring(0,12,0)+trimOWS = S8.strip+#else+trimOWS = S8.reverse . S8.dropWhile isOWS . S8.reverse . S8.dropWhile isOWS+ where isOWS c = c == ' ' || c == '\t'+#endif+ -- | Set up a reverse proxy server, which will have a minimal overhead. -- -- This function uses raw sockets, parsing as little of the request as@@ -98,7 +110,7 @@ -- 4. Pass all bytes across the wire unchanged. -- -- If you need more control, such as modifying the request or response, use 'waiProxyTo'.-rawProxyTo :: (MonadBaseControl IO m, MonadIO m)+rawProxyTo :: MonadUnliftIO m => (HT.RequestHeaders -> m (Either (DCN.AppData -> m ()) ProxyDest)) -- ^ How to reverse proxy. A @Left@ result will run the given -- 'DCN.Application', whereas a @Right@ will reverse proxy to the@@ -124,9 +136,9 @@ where fromClient = DCN.appSource appdata toClient = DCN.appSink appdata- withServer rsrc appdataServer = void $ concurrently+ withServer rsrc appdataServer = concurrently_ (rsrc $$+- toServer)- (fromServer $$ toClient)+ (runConduit $ fromServer .| toClient) where fromServer = DCN.appSource appdataServer toServer = DCN.appSink appdataServer@@ -142,17 +154,17 @@ -- -- If you need more control, such as modifying the request or response, use 'waiProxyTo'. ----- Since 0.4.4-rawTcpProxyTo :: (MonadBaseControl IO m, MonadIO m)+-- @since 0.4.4+rawTcpProxyTo :: MonadIO m => ProxyDest -> AppData -> m () rawTcpProxyTo (ProxyDest host port) appdata = liftIO $ DCN.runTCPClient (DCN.clientSettings port host) withServer where- withServer appdataServer = void $ concurrently- (DCN.appSource appdata $$ DCN.appSink appdataServer)- (DCN.appSource appdataServer $$ DCN.appSink appdata )+ withServer appdataServer = concurrently_+ (runConduit $ DCN.appSource appdata .| DCN.appSink appdataServer)+ (runConduit $ DCN.appSource appdataServer .| DCN.appSink appdata ) -- | Sends a simple 502 bad gateway error message with the contents of the -- exception.@@ -165,15 +177,15 @@ -- | The different responses that could be generated by a @waiProxyTo@ lookup -- function. ----- Since 0.2.0+-- @since 0.2.0 data WaiProxyResponse = WPRResponse WAI.Response -- ^ Respond with the given WAI Response. --- -- Since 0.2.0+ -- @since 0.2.0 | WPRProxyDest ProxyDest -- ^ Send to the given destination. --- -- Since 0.2.0+ -- @since 0.2.0 | WPRProxyDestSecure ProxyDest -- ^ Send to the given destination via HTTPS. | WPRModifiedRequest WAI.Request ProxyDest@@ -182,15 +194,18 @@ -- request. This can be useful for reverse proxying to -- a different path than the one specified. By the -- user.+ -- The path will be taken from rawPathInfo while+ -- the queryString from rawQueryString of the+ -- request. --- -- Since 0.2.0+ -- @since 0.2.0 | WPRModifiedRequestSecure WAI.Request ProxyDest -- ^ Same as WPRModifiedRequest but send to the -- given destination via HTTPS. | WPRApplication WAI.Application -- ^ Respond with the given WAI Application. --- -- Since 0.4.0+ -- @since 0.4.0 -- | Creates a WAI 'WAI.Application' which will handle reverse proxies. --@@ -213,7 +228,7 @@ -- simple 502 error page, use 'defaultOnExc'. -> HC.Manager -- ^ connection manager to utilize -> WAI.Application-waiProxyTo getDest onError = waiProxyToSettings getDest def { wpsOnExc = onError }+waiProxyTo getDest onError = waiProxyToSettings getDest defaultWaiProxySettings { wpsOnExc = onError } data LocalWaiProxySettings = LocalWaiProxySettings { lpsTimeBound :: Maybe Int@@ -221,22 +236,20 @@ -- -- Default: no timeouts --- -- Since 0.4.2+ -- @since 0.4.2 }-instance Default LocalWaiProxySettings where- def = LocalWaiProxySettings Nothing -- | Default value for 'LocalWaiProxySettings', same as 'def' but with a more explicit name. ----- Since 0.4.2+-- @since 0.4.2 defaultLocalWaiProxySettings :: LocalWaiProxySettings-defaultLocalWaiProxySettings = def+defaultLocalWaiProxySettings = LocalWaiProxySettings Nothing -- | Allows to specify the maximum time allowed for the conection on per request basis. -- -- Default: no timeouts ----- Since 0.4.2+-- @since 0.4.2 setLpsTimeBound :: Maybe Int -> LocalWaiProxySettings -> LocalWaiProxySettings setLpsTimeBound x s = s { lpsTimeBound = x } @@ -248,11 +261,13 @@ -- -- Default: SIHFromSocket --- -- Since 0.2.0- , wpsProcessBody :: HC.Response () -> Maybe (Conduit ByteString IO (Flush Builder))+ -- @since 0.2.0+ , wpsProcessBody :: WAI.Request -> HC.Response () -> Maybe (ConduitT ByteString (Flush Builder) IO ()) -- ^ Post-process the response body returned from the host.+ -- The API for this function changed to include the extra 'WAI.Request'+ -- parameter in version 0.5.0. --- -- Since 0.2.1+ -- @since 0.2.1 , wpsUpgradeToRaw :: WAI.Request -> Bool -- ^ Determine if the request should be upgraded to a raw proxy connection, -- as is needed for WebSockets. Requires WAI 2.1 or higher and a WAI@@ -260,7 +275,7 @@ -- -- Default: check if the upgrade header is websocket. --- -- Since 0.3.1+ -- @since 0.3.1 , wpsGetDest :: Maybe (WAI.Request -> IO (LocalWaiProxySettings, WaiProxyResponse)) -- ^ Allow to override proxy settings for each request. -- If you supply this field it will take precedence over@@ -268,25 +283,43 @@ -- -- Default: have one global setting --- -- Since 0.4.2+ -- @since 0.4.2+ , wpsLogRequest :: HC.Request -> IO ()+ -- ^ Function provided to log the 'Request' that is constructed.+ --+ -- Default: no op+ --+ -- @since 0.6.0.1+ , wpsModifyResponseHeaders :: WAI.Request -> HC.Response () -> HT.ResponseHeaders -> HT.ResponseHeaders+ -- ^ Allow to override the response headers before the response is returned upstream. Useful for example+ -- to override overly-strict 'Content-Security-Policy' when the source is known to be trustworthy.+ --+ -- Default: no op+ --+ -- @since 0.6.1.0 } -- | How to set the X-Real-IP request header. ----- Since 0.2.0+-- @since 0.2.0 data SetIpHeader = SIHNone -- ^ Do not set the header | SIHFromSocket -- ^ Set it from the socket's address. | SIHFromHeader -- ^ Set it from either X-Real-IP or X-Forwarded-For, if present -instance Default WaiProxySettings where- def = WaiProxySettings+-- | Default value for 'WaiProxySettings'+--+-- @since 0.6.0+defaultWaiProxySettings :: WaiProxySettings+defaultWaiProxySettings = WaiProxySettings { wpsOnExc = defaultOnExc , wpsTimeout = Nothing , wpsSetIpHeader = SIHFromSocket- , wpsProcessBody = const Nothing+ , wpsProcessBody = \_ _ -> Nothing , wpsUpgradeToRaw = \req -> (CI.mk <$> lookup "upgrade" (WAI.requestHeaders req)) == Just "websocket" , wpsGetDest = Nothing+ , wpsLogRequest = const (pure ())+ , wpsModifyResponseHeaders = \_ _ -> id } renderHeaders :: WAI.Request -> HT.RequestHeaders -> Builder@@ -324,9 +357,9 @@ loop toClient' = awaitForever $ liftIO . toClient headers = renderHeaders req $ fixReqHeaders wps req- in void $ concurrently- (fromClient $$ toServer)- (fromServer $$ toClient')+ in concurrently_+ (runConduit $ fromClient .| toServer)+ (runConduit $ fromServer .| toClient') | otherwise = fallback where backup = WAI.responseLBS HT.status500 [("Content-Type", "text/plain")]@@ -346,7 +379,7 @@ fromSocket = (("X-Real-IP", S8.pack $ showSockAddr $ WAI.remoteHost req):) fromForwardedFor = do h <- lookup "x-forwarded-for" (WAI.requestHeaders req)- listToMaybe $ map (TE.encodeUtf8 . T.strip) $ T.splitOn "," $ TE.decodeUtf8 h+ listToMaybe $ map trimOWS $ S8.split ',' h addXRealIP = case wpsSetIpHeader wps of SIHFromSocket -> fromSocket@@ -363,7 +396,7 @@ waiProxyToSettings getDest wps' manager req0 sendResponse = do let wps = wps'{wpsGetDest = wpsGetDest wps' <|> Just (fmap (LocalWaiProxySettings $ wpsTimeout wps',) . getDest)} (lps, edest') <- fromMaybe- (const $ return (def, WPRResponse $ WAI.responseLBS HT.status500 [] "proxy not setup"))+ (const $ return (defaultLocalWaiProxySettings, WPRResponse $ WAI.responseLBS HT.status500 [] "proxy not setup")) (wpsGetDest wps) req0 let edest =@@ -381,6 +414,12 @@ case edest of Left app -> maybe id timeBound (lpsTimeBound lps) $ app req0 sendResponse Right (ProxyDest host port, req, secure) -> tryWebSockets wps host port req sendResponse $ do+ scb <- semiCachedBody (WAI.requestBody req)+ let body =+ case WAI.requestBodyLength req of+ WAI.KnownLength i -> HC.RequestBodyStream (fromIntegral i) scb+ WAI.ChunkedBody -> HC.RequestBodyStreamChunked scb+ let req' = #if MIN_VERSION_http_client(0, 5, 0) HC.defaultRequest@@ -401,35 +440,85 @@ , HC.requestBody = body , HC.redirectCount = 0 }- body =- case WAI.requestBodyLength req of- WAI.KnownLength i -> HC.RequestBodyStream- (fromIntegral i)- ($ WAI.requestBody req)- WAI.ChunkedBody -> HC.RequestBodyStreamChunked ($ WAI.requestBody req) bracket- (try $ HC.responseOpen req' manager)+ (try $ do+ liftIO $ wpsLogRequest wps' req'+ HC.responseOpen req' manager) (either (const $ return ()) HC.responseClose) $ \case Left e -> wpsOnExc wps e req sendResponse Right res -> do- let conduit = fromMaybe+ let res' = const () <$> res+ conduit = fromMaybe (awaitForever (\bs -> yield (Chunk $ fromByteString bs) >> yield Flush))- (wpsProcessBody wps $ const () <$> res)+ (wpsProcessBody wps req res') src = bodyReaderSource $ HC.responseBody res+ headers = HC.responseHeaders res+ notEncoded = isNothing (lookup "content-encoding" headers)+ notChunked = HT.httpMajor (WAI.httpVersion req) >= 2 || WAI.requestMethod req == HT.methodHead sendResponse $ WAI.responseStream (HC.responseStatus res)- (filter (\(key, _) -> not $ key `Set.member` strippedHeaders) $ HC.responseHeaders res)- (\sendChunk flush -> src $= conduit $$ CL.mapM_ (\mb ->+ (filter (\(key, v) -> not (key `Set.member` strippedHeaders) ||+ key == "content-length" && (notEncoded && notChunked || v == "0"))+ (wpsModifyResponseHeaders wps req res' headers))+ (\sendChunk flush -> runConduit $ src .| conduit .| CL.mapM_ (\mb -> case mb of Flush -> flush Chunk b -> sendChunk b)) +-- | Introduce a minor level of caching to handle some basic+-- retry cases inside http-client. But to avoid a DoS attack,+-- don't cache more than 65535 bytes (the theoretical max TCP packet size).+--+-- See: <https://github.com/fpco/http-reverse-proxy/issues/34#issuecomment-719136064>+semiCachedBody :: IO ByteString -> IO (HC.GivesPopper ())+semiCachedBody orig = do+ ref <- newIORef $ SCBCaching 0 []+ pure $ \needsPopper -> do+ let fromChunks len chunks =+ case NE.nonEmpty (reverse chunks) of+ Nothing -> SCBCaching len chunks+ Just toDrain -> SCBDraining len chunks toDrain+ state0 <- readIORef ref >>=+ \case+ SCBCaching len chunks -> pure $ fromChunks len chunks+ SCBDraining len chunks _ -> pure $ fromChunks len chunks+ SCBTooMuchData -> error "Cannot retry this request body, need to force a new request"+ writeIORef ref $! state0+ let popper :: IO ByteString+ popper = do+ readIORef ref >>=+ \case+ SCBDraining len chunks (next:|rest) -> do+ writeIORef ref $!+ case rest of+ [] -> SCBCaching len chunks+ x:xs -> SCBDraining len chunks (x:|xs)+ pure next+ SCBTooMuchData -> orig+ SCBCaching len chunks -> do+ bs <- orig+ let newLen = len + S.length bs+ writeIORef ref $!+ if newLen > maxCache+ then SCBTooMuchData+ else SCBCaching newLen (bs:chunks)+ pure bs++ needsPopper popper+ where+ maxCache = 65535++data SCB+ = SCBCaching !Int ![ByteString]+ | SCBDraining !Int ![ByteString] !(NonEmpty ByteString)+ | SCBTooMuchData+ -- | Get the HTTP headers for the first request on the stream, returning on -- consumed bytes as leftovers. Has built-in limits on how many bytes it will -- consume (specifically, will not ask for another chunked after it receives -- 1000 bytes).-getHeaders :: Monad m => Sink ByteString m HT.RequestHeaders+getHeaders :: Monad m => ConduitT ByteString o m HT.RequestHeaders getHeaders = toHeaders <$> go id where@@ -490,7 +579,7 @@ } -} -bodyReaderSource :: MonadIO m => BodyReader -> Source m ByteString+bodyReaderSource :: MonadIO m => BodyReader -> ConduitT i ByteString m () bodyReaderSource br = loop where
README.md view
@@ -21,3 +21,38 @@ (\_headers -> return $ Right $ ProxyDest "www.example.com" 80) appData ```++## HTTPS example to proxy bing.com++The following example sets up reverse proxying froming to www.bing.com+from localhost port 3000:++``` haskell+import Network.HTTP.Client.TLS+import Network.HTTP.ReverseProxy+import Network.Wai+import Network.Wai.Handler.Warp (run)++main :: IO ()+main = bingExample >>= run 3000++bingExample :: IO Application+bingExample = do+ manager <- newTlsManager+ pure $+ waiProxyToSettings+ ( \request ->+ return $+ WPRModifiedRequestSecure+ ( request+ { requestHeaders = [("Host", "www.bing.com")]+ }+ )+ (ProxyDest "www.bing.com" 443)+ )+ defaultWaiProxySettings {wpsLogRequest = print}+ manager+```++After running it, you can visit [http://localhost:3000](http://localhost:3000) to visit+the search engine's page.
http-reverse-proxy.cabal view
@@ -1,63 +1,74 @@-name: http-reverse-proxy-version: 0.4.5-synopsis: Reverse proxy HTTP requests, either over raw sockets or with WAI-description: Provides a simple means of reverse-proxying HTTP requests. The raw approach uses the same technique as leveraged by keter, whereas the WAI approach performs full request/response parsing via WAI and http-conduit.-homepage: https://github.com/fpco/http-reverse-proxy-license: BSD3-license-file: LICENSE-author: Michael Snoyman-maintainer: michael@fpcomplete.com-category: Web-build-type: Simple-cabal-version: >=1.8-extra-source-files: README.md ChangeLog.md+name: http-reverse-proxy+version: 0.6.2.0+synopsis:+ Reverse proxy HTTP requests, either over raw sockets or with WAI +description:+ Provides a simple means of reverse-proxying HTTP requests. The raw approach uses the same technique as leveraged by keter, whereas the WAI approach performs full request/response parsing via WAI and http-conduit.++homepage: https://github.com/fpco/http-reverse-proxy+license: BSD3+license-file: LICENSE+author: Michael Snoyman+maintainer: michael@fpcomplete.com+category: Web+build-type: Simple+cabal-version: >=1.10+extra-source-files:+ ChangeLog.md+ README.md+ library- exposed-modules: Network.HTTP.ReverseProxy- other-modules: Paths_http_reverse_proxy- build-depends: base >= 4.6 && < 5- , monad-control >= 0.3- , lifted-base >= 0.1- , text >= 0.11- , bytestring >= 0.9- , case-insensitive >= 0.4- , http-types >= 0.6- , word8 >= 0.0- , blaze-builder >= 0.3- , http-client >= 0.3- , wai >= 3.0- , network- , conduit >= 1.1- , conduit-extra- , data-default-class- , wai-logger- , resourcet- , containers- , async- , transformers- , streaming-commons+ default-language: Haskell2010+ exposed-modules: Network.HTTP.ReverseProxy+ other-modules: Paths_http_reverse_proxy + if impl(ghc <8)+ buildable: False++ build-depends:+ base >=4.11 && <5+ , blaze-builder >=0.3 && <0.5+ , bytestring >=0.9 && <0.13+ , case-insensitive >=0.4 && <1.3+ , conduit >=1.3 && <1.4+ , conduit-extra <1.4+ , containers <0.9+ , http-client >=0.3 && <0.8+ , http-types >=0.6 && <0.13+ , network <3.3+ , resourcet <1.4+ , streaming-commons <0.3+ , text >=0.11 && <2.2+ , transformers <0.7+ , unliftio >=0.2 && <0.3+ , wai >=3.0 && <3.3+ , wai-logger >=2.0 && <2.6+ , word8 >=0.0 && <0.2+ test-suite test- type: exitcode-stdio-1.0- main-is: main.hs- hs-source-dirs: test- build-depends: base- , http-reverse-proxy- , wai- , http-types- , hspec >= 1.3- , warp >= 2.1- , bytestring- , conduit >= 1.1- , conduit-extra- , blaze-builder- , transformers- , lifted-base- , network- , http-conduit- , resourcet- , streaming-commons+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ build-depends:+ base <10+ , blaze-builder+ , bytestring+ , conduit >=1.1+ , conduit-extra+ , hspec >=1.3+ , http-conduit >=2.3+ , http-reverse-proxy+ , http-types+ , network+ , resourcet+ , streaming-commons+ , transformers+ , unliftio+ , wai+ , warp >=2.1 source-repository head type: git- location: git://github.com/fpco/http-reverse-proxy.git+ location: https://github.com/fpco/http-reverse-proxy.git
test/main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} import Blaze.ByteString.Builder (fromByteString)@@ -14,8 +15,8 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Char (toUpper)-import Data.Conduit (await, yield, ($$),- ($$+-), (=$), awaitForever)+import Data.Conduit (await, yield, (.|), runConduit,+ awaitForever) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.Network (ServerSettings,@@ -31,18 +32,19 @@ defaultOnExc, rawProxyTo, rawTcpProxyTo, WaiProxySettings (..), SetIpHeader (..),- def,+ defaultWaiProxySettings, waiProxyToSettings, waiProxyTo) import Network.HTTP.Types (status200, status500)-import Network.Socket (sClose)+import qualified Network.Socket import Network.Wai (rawPathInfo, responseLBS, responseStream, requestHeaders) import qualified Network.Wai import Network.Wai.Handler.Warp (defaultSettings, runSettings, setBeforeMainLoop, setPort) import System.IO.Unsafe (unsafePerformIO)-import System.Timeout.Lifted (timeout)+import UnliftIO (timeout)+import UnliftIO.IORef import Test.Hspec (describe, hspec, it, shouldBe) nextPort :: I.IORef Int@@ -56,7 +58,7 @@ case esocket of Left (_ :: IOException) -> getPort Right socket -> do- sClose socket+ Network.Socket.close socket return port withWApp :: Network.Wai.Application -> (Int -> IO ()) -> IO ()@@ -86,7 +88,7 @@ (const $ takeMVar baton >> f port) withMan :: (HC.Manager -> IO ()) -> IO ()-withMan = HC.withManager . (liftIO .)+withMan = (HC.newManager HC.tlsManagerSettings >>=) main :: IO () main = hspec $@@ -122,10 +124,10 @@ in withMan $ \manager -> withWApp app $ \port1 -> withWApp (waiProxyTo (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 -> do- req <- HC.parseUrl $ "http://127.0.0.1:" ++ show port2+ req <- HC.parseUrlThrow $ "http://127.0.0.1:" ++ show port2 mbs <- runResourceT $ timeout 1000000 $ do res <- HC.http req manager- HC.responseBody res $$+- await+ runConduit $ HC.responseBody res .| await mbs `shouldBe` Just (Just "hello") it "passes on body length" $ let app req f = f $ responseLBS@@ -138,7 +140,7 @@ in withMan $ \manager -> withWApp app $ \port1 -> withWApp (waiProxyTo (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 -> do- req' <- HC.parseUrl $ "http://127.0.0.1:" ++ show port2+ req' <- HC.parseUrlThrow $ "http://127.0.0.1:" ++ show port2 let req = req' { HC.requestBody = HC.RequestBodyBS body }@@ -155,23 +157,23 @@ bs <- liftIO src unless (S8.null bs) $ yield bs >> src' sink' = awaitForever $ liftIO . sink- src' $$ CL.iterM print =$ CL.map (S8.map toUpper) =$ sink'+ runConduit $ src' .| CL.iterM print .| CL.map (S8.map toUpper) .| sink' fallback = responseLBS status500 [] "fallback used" in withMan $ \manager -> withWApp app $ \port1 -> withWApp (waiProxyTo (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 -> runTCPClient (clientSettings port2 "127.0.0.1") $ \ad -> do- yield "GET / HTTP/1.1\r\nUpgrade: websockET\r\n\r\n" $$ appSink ad- yield "hello" $$ appSink ad- (appSource ad $$ CB.take 5) >>= (`shouldBe` "HELLO")+ runConduit $ yield "GET / HTTP/1.1\r\nUpgrade: websockET\r\n\r\n" .| appSink ad+ runConduit $ yield "hello" .| appSink ad+ (runConduit $ appSource ad .| CB.take 5) >>= (`shouldBe` "HELLO") it "get real ip" $ let getRealIp req = L8.fromStrict $ fromMaybe "" $ lookup "x-real-ip" (requestHeaders req) httpWithForwardedFor url = liftIO $ do man <- HC.newManager HC.tlsManagerSettings- oreq <- liftIO $ HC.parseUrl url+ oreq <- liftIO $ HC.parseUrlThrow url let req = oreq { HC.requestHeaders = [("X-Forwarded-For", "127.0.1.1, 127.0.0.1"), ("Connection", "close")] } HC.responseBody <$> HC.httpLbs req man- waiProxyTo' getDest onError = waiProxyToSettings getDest def { wpsOnExc = onError, wpsSetIpHeader = SIHFromHeader }+ waiProxyTo' getDest onError = waiProxyToSettings getDest defaultWaiProxySettings { wpsOnExc = onError, wpsSetIpHeader = SIHFromHeader } in withMan $ \manager -> withWApp (\r f -> f $ responseLBS status200 [] $ getRealIp r ) $ \port1 -> withWApp (waiProxyTo' (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->@@ -183,10 +185,10 @@ let getRealIp req = L8.fromStrict $ fromMaybe "" $ lookup "x-real-ip" (requestHeaders req) httpWithForwardedFor url = liftIO $ do man <- HC.newManager HC.tlsManagerSettings- oreq <- liftIO $ HC.parseUrl url+ oreq <- liftIO $ HC.parseUrlThrow url let req = oreq { HC.requestHeaders = [("X-Forwarded-For", "127.0.1.1"), ("Connection", "close")] } HC.responseBody <$> HC.httpLbs req man- waiProxyTo' getDest onError = waiProxyToSettings getDest def { wpsOnExc = onError, wpsSetIpHeader = SIHFromHeader }+ waiProxyTo' getDest onError = waiProxyToSettings getDest defaultWaiProxySettings { wpsOnExc = onError, wpsSetIpHeader = SIHFromHeader } in withMan $ \manager -> withWApp (\r f -> f $ responseLBS status200 [] $ getRealIp r ) $ \port1 -> withWApp (waiProxyTo' (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->@@ -198,10 +200,10 @@ let getRealIp req = L8.fromStrict $ fromMaybe "" $ lookup "x-real-ip" (requestHeaders req) httpWithForwardedFor url = liftIO $ do man <- HC.newManager HC.tlsManagerSettings- oreq <- liftIO $ HC.parseUrl url+ oreq <- liftIO $ HC.parseUrlThrow url let req = oreq { HC.requestHeaders = [("Connection", "close")] } HC.responseBody <$> HC.httpLbs req man- waiProxyTo' getDest onError = waiProxyToSettings getDest def { wpsOnExc = onError, wpsSetIpHeader = SIHFromHeader }+ waiProxyTo' getDest onError = waiProxyToSettings getDest defaultWaiProxySettings { wpsOnExc = onError, wpsSetIpHeader = SIHFromHeader } in withMan $ \manager -> withWApp (\r f -> f $ responseLBS status200 [] $ getRealIp r ) $ \port1 -> withWApp (waiProxyTo' (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->@@ -209,6 +211,44 @@ withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do lbs <- httpWithForwardedFor $ "http://127.0.0.1:" ++ show port4 lbs `shouldBe` "127.0.0.1"+ it "doesn't fail on invalid utf8 in x-forwarded-for header" $+ let getRealIp req = L8.fromStrict $ fromMaybe "" $ lookup "x-real-ip" (requestHeaders req)+ httpWithForwardedFor url = liftIO $ do+ man <- HC.newManager HC.tlsManagerSettings+ oreq <- liftIO $ HC.parseUrlThrow url+ let req = oreq { HC.requestHeaders = [("X-Forwarded-For", "\xbf\xf0\x9f\x92\xa1"), ("Connection", "close")] }+ HC.responseBody <$> HC.httpLbs req man+ waiProxyTo' getDest onError = waiProxyToSettings getDest defaultWaiProxySettings { wpsOnExc = onError, wpsSetIpHeader = SIHFromHeader }+ in withMan $ \manager ->+ withWApp (\r f -> f $ responseLBS status200 [] $ getRealIp r ) $ \port1 ->+ withWApp (waiProxyTo' (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->+ withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 ->+ withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do+ lbs <- httpWithForwardedFor $ "http://127.0.0.1:" ++ show port4+ lbs `shouldBe` "\xbf\xf0\x9f\x92\xa1"+ it "performs log action" $+ let ioref :: IO (IORef Int)+ ioref = newIORef 1+ performLogAction :: IORef Int -> IO ()+ performLogAction ref = writeIORef ref 2+ waiProxyTo' getDest onError manager ref =+ waiProxyToSettings+ getDest+ defaultWaiProxySettings+ { wpsOnExc = onError,+ wpsSetIpHeader = SIHFromHeader,+ wpsLogRequest = const (performLogAction ref)+ }+ manager+ in withMan $ \manager ->+ withWApp (\_ f -> f $ responseLBS status200 [] "works") $ \port1 -> do+ ref <- ioref+ withWApp (waiProxyTo' (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager ref) $ \port2 ->+ withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 ->+ withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do+ _ <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port4+ lhs <- liftIO $ readIORef ref+ lhs `shouldBe` 2 {- FIXME describe "waiToRaw" $ do it "works" $ do