http-reverse-proxy 0.4.0.1 → 0.6.2.0
raw patch · 5 files changed
Files
- ChangeLog.md +67/−0
- Network/HTTP/ReverseProxy.hs +276/−93
- README.md +58/−0
- http-reverse-proxy.cabal +67/−56
- test/main.hs +115/−21
+ ChangeLog.md view
@@ -0,0 +1,67 @@+## 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`++## 0.4.4++* add `rawTcpProxyTo` which can handle proxying connections without http headers+ [#21](https://github.com/fpco/http-reverse-proxy/issues/21)++## 0.4.3.3++* `fixReqHeaders` may create weird `x-real-ip` header [#19](https://github.com/fpco/http-reverse-proxy/issues/19)++## 0.4.3.2++* Minor doc cleanup++## 0.4.3.1++* Use CPP so we can work with `http-client` pre and post 0.5 [#17](https://github.com/fpco/http-reverse-proxy/pull/17)++## 0.4.3++* Allow proxying to HTTPS servers. [#15](https://github.com/fpco/http-reverse-proxy/pull/15)++## 0.4.2++* Add configurable timeouts [#8](https://github.com/fpco/http-reverse-proxy/pull/8)++## 0.4.1.3++* Include README.md and ChangeLog.md
Network/HTTP/ReverseProxy.hs view
@@ -1,9 +1,18 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-}+ module Network.HTTP.ReverseProxy ( -- * Types ProxyDest (..) -- * Raw , rawProxyTo+ , rawTcpProxyTo -- * WAI + http-conduit , waiProxyTo , defaultOnExc@@ -11,62 +20,82 @@ , WaiProxyResponse (..) -- ** Settings , WaiProxySettings- , def+ , defaultWaiProxySettings , wpsOnExc , wpsTimeout , wpsSetIpHeader , wpsProcessBody , wpsUpgradeToRaw+ , wpsGetDest+ , wpsLogRequest+ , wpsModifyResponseHeaders , SetIpHeader (..)+ -- *** Local settings+ , LocalWaiProxySettings+ , defaultLocalWaiProxySettings+ , setLpsTimeBound {- FIXME -- * WAI to Raw , waiToRaw -} ) where -import Data.Conduit-import Data.Streaming.Network (readLens, AppData)-import Data.Functor.Identity (Identity (..))-import Data.Maybe (fromMaybe)-import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Default.Class (def)-import qualified Network.Wai as WAI-import qualified Network.HTTP.Client as HC-import Network.HTTP.Client (BodyReader, brRead)-import Control.Exception (bracket)-import Blaze.ByteString.Builder (fromByteString)-import Data.Word8 (isSpace, _colon, _cr)-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Network.HTTP.Types as HT-import qualified Data.CaseInsensitive as CI-import qualified Data.Text.Lazy.Encoding as TLE-import qualified Data.Text.Lazy as TL-import qualified Data.Conduit.Network as DCN-import Control.Concurrent.MVar.Lifted (newEmptyMVar, putMVar, takeMVar)-import Control.Concurrent.Lifted (fork, killThread)-import Data.Default.Class (Default (..))-import Network.Wai.Logger (showSockAddr)-import qualified Data.Set as Set-import Data.IORef-import qualified Data.ByteString.Lazy as L-import Control.Concurrent.Async (concurrently)-import Blaze.ByteString.Builder (Builder, toLazyByteString)-import Data.ByteString (ByteString)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad (unless, void)-import Data.Monoid (mappend, (<>), mconcat)-import Control.Exception.Lifted (try, SomeException, finally)-import Control.Applicative ((<$>), (<|>))-import Data.Set (Set)-import qualified Data.Conduit.List as CL+import Blaze.ByteString.Builder (Builder, fromByteString,+ toLazyByteString)+import Control.Applicative ((<$>), (<|>))+import Control.Monad (unless)+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import qualified Data.CaseInsensitive as CI+import Data.Conduit+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Network as DCN+import Data.Functor.Identity (Identity (..))+import Data.IORef+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+import Data.Streaming.Network (AppData, readLens)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import qualified Data.Text as T+import Data.Word8 (isSpace, _colon, _cr)+import GHC.Generics (Generic)+import Network.HTTP.Client (BodyReader, brRead)+import qualified Network.HTTP.Client as HC+import qualified Network.HTTP.Types as HT+import qualified Network.Wai as WAI+import Network.Wai.Logger (showSockAddr)+import UnliftIO (MonadIO, liftIO, MonadUnliftIO, timeout, SomeException, try, bracket, concurrently_) -- | Host\/port combination to which we want to proxy. data ProxyDest = ProxyDest { pdHost :: !ByteString , 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@@ -81,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@@ -107,16 +136,36 @@ where fromClient = DCN.appSource appdata toClient = DCN.appSink appdata- withServer rsrc appdataServer = do- x <- newEmptyMVar- tid1 <- fork $ (rsrc $$+- toServer) `finally` putMVar x True- tid2 <- fork $ (fromServer $$ toClient) `finally` putMVar x False- y <- takeMVar x- killThread $ if y then tid2 else tid1+ withServer rsrc appdataServer = concurrently_+ (rsrc $$+- toServer)+ (runConduit $ fromServer .| toClient) where fromServer = DCN.appSource appdataServer toServer = DCN.appSink appdataServer +-- | Set up a reverse tcp proxy server, which will have a minimal overhead.+--+-- This function uses raw sockets, parsing as little of the request as+-- possible. The workflow is:+--+-- 1. Open up a connection to the given host\/port.+--+-- 2. Pass all bytes across the wire unchanged.+--+-- If you need more control, such as modifying the request or response, use 'waiProxyTo'.+--+-- @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 = 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. defaultOnExc :: SomeException -> WAI.Application@@ -128,27 +177,35 @@ -- | 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 -- ^ Send to the given destination, but use the given -- modified Request for computing the reverse-proxied -- 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. --@@ -165,15 +222,37 @@ -- the proxied server. Not all servers necessarily support chunked request -- bodies, so please confirm that yours does (Warp, Snap, and Happstack, for example, do). waiProxyTo :: (WAI.Request -> IO WaiProxyResponse)- -- ^ How to reverse proxy. A @Left@ result will be sent verbatim as- -- the response, whereas @Right@ will cause a reverse proxy.+ -- ^ How to reverse proxy. -> (SomeException -> WAI.Application) -- ^ How to handle exceptions when calling remote server. For a -- 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+ -- ^ Allows to specify the maximum time allowed for the conection on per request basis.+ --+ -- Default: no timeouts+ --+ -- @since 0.4.2+ }++-- | Default value for 'LocalWaiProxySettings', same as 'def' but with a more explicit name.+--+-- @since 0.4.2+defaultLocalWaiProxySettings :: LocalWaiProxySettings+defaultLocalWaiProxySettings = LocalWaiProxySettings Nothing++-- | Allows to specify the maximum time allowed for the conection on per request basis.+--+-- Default: no timeouts+--+-- @since 0.4.2+setLpsTimeBound :: Maybe Int -> LocalWaiProxySettings -> LocalWaiProxySettings+setLpsTimeBound x s = s { lpsTimeBound = x }+ data WaiProxySettings = WaiProxySettings { wpsOnExc :: SomeException -> WAI.Application , wpsTimeout :: Maybe Int@@ -182,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@@ -194,24 +275,51 @@ -- -- 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+ -- getDest parameter in waiProxyToSettings+ --+ -- Default: have one global setting+ --+ -- @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@@ -249,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")]@@ -269,11 +377,14 @@ $ WAI.requestHeaders req where fromSocket = (("X-Real-IP", S8.pack $ showSockAddr $ WAI.remoteHost req):)+ fromForwardedFor = do+ h <- lookup "x-forwarded-for" (WAI.requestHeaders req)+ listToMaybe $ map trimOWS $ S8.split ',' h addXRealIP = case wpsSetIpHeader wps of SIHFromSocket -> fromSocket SIHFromHeader ->- case lookup "x-real-ip" (WAI.requestHeaders req) <|> lookup "X-Forwarded-For" (WAI.requestHeaders req) of+ case lookup "x-real-ip" (WAI.requestHeaders req) <|> fromForwardedFor of Nothing -> fromSocket Just ip -> (("X-Real-IP", ip):) SIHNone -> id@@ -282,19 +393,45 @@ -> WaiProxySettings -> HC.Manager -> WAI.Application-waiProxyToSettings getDest wps manager req0 sendResponse = do- edest' <- getDest req0+waiProxyToSettings getDest wps' manager req0 sendResponse = do+ let wps = wps'{wpsGetDest = wpsGetDest wps' <|> Just (fmap (LocalWaiProxySettings $ wpsTimeout wps',) . getDest)}+ (lps, edest') <- fromMaybe+ (const $ return (defaultLocalWaiProxySettings, WPRResponse $ WAI.responseLBS HT.status500 [] "proxy not setup"))+ (wpsGetDest wps)+ req0 let edest = case edest' of WPRResponse res -> Left $ \_req -> ($ res)- WPRProxyDest pd -> Right (pd, req0)- WPRModifiedRequest req pd -> Right (pd, req)+ WPRProxyDest pd -> Right (pd, req0, False)+ WPRProxyDestSecure pd -> Right (pd, req0, True)+ WPRModifiedRequest req pd -> Right (pd, req, False)+ WPRModifiedRequestSecure req pd -> Right (pd, req, True) WPRApplication app -> Left app+ timeBound us f =+ timeout us f >>= \case+ Just res -> return res+ Nothing -> sendResponse $ WAI.responseLBS HT.status500 [] "timeBound" case edest of- Left app -> app req0 sendResponse- Right (ProxyDest host port, req) -> tryWebSockets wps host port req sendResponse $ do- let req' = def- { HC.method = WAI.requestMethod req+ 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+ { HC.checkResponse = \_ _ -> return ()+ , HC.responseTimeout = maybe HC.responseTimeoutNone HC.responseTimeoutMicro $ lpsTimeBound lps+#else+ def+ { HC.checkStatus = \_ _ _ -> Nothing+ , HC.responseTimeout = lpsTimeBound lps+#endif+ , HC.method = WAI.requestMethod req+ , HC.secure = secure , HC.host = host , HC.port = port , HC.path = WAI.rawPathInfo req@@ -302,40 +439,86 @@ , HC.requestHeaders = fixReqHeaders wps req , HC.requestBody = body , HC.redirectCount = 0- , HC.checkStatus = \_ _ _ -> Nothing- , HC.responseTimeout = wpsTimeout wps }- 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)- $ \ex -> do- case ex of+ $ \case Left e -> wpsOnExc wps e req sendResponse Right res -> do- let conduit =- case wpsProcessBody wps $ fmap (const ()) res of- Nothing -> awaitForever (\bs -> yield (Chunk $ fromByteString bs) >> yield Flush)- Just conduit' -> conduit'+ let res' = const () <$> res+ conduit = fromMaybe+ (awaitForever (\bs -> yield (Chunk $ fromByteString bs) >> yield Flush))+ (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@@ -396,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
@@ -0,0 +1,58 @@+http-reverse-proxy+==================++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.++## Raw example++The following sets up raw reverse proxying from local port 3000 to+www.example.com, port 80.++```haskell+{-# LANGUAGE OverloadedStrings #-}+import Network.HTTP.ReverseProxy+import Data.Conduit.Network++main :: IO ()+main = runTCPServer (serverSettings 3000 "*") $ \appData ->+ rawProxyTo+ (\_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.0.1-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+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 && < 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- , network-conduit- , 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,6 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} import Blaze.ByteString.Builder (fromByteString)+import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay) import Control.Exception (IOException, bracket,@@ -8,12 +10,13 @@ import Control.Monad (forever, unless) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (runResourceT)+import Data.Maybe (fromMaybe) import qualified Data.ByteString as S 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,@@ -26,17 +29,22 @@ import qualified Network.HTTP.Conduit as HC import Network.HTTP.ReverseProxy (ProxyDest (..), WaiProxyResponse (..),- defaultOnExc, rawProxyTo,+ defaultOnExc, rawProxyTo, rawTcpProxyTo,+ WaiProxySettings (..),+ SetIpHeader (..),+ defaultWaiProxySettings,+ waiProxyToSettings, waiProxyTo) import Network.HTTP.Types (status200, status500)-import Network.Socket (sClose)+import qualified Network.Socket import Network.Wai (rawPathInfo, responseLBS,- responseStream)+ 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@@ -46,11 +54,11 @@ getPort :: IO Int getPort = do port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p)- esocket <- try $ bindPortTCP port "*4"+ esocket <- try $ bindPortTCP port "127.0.0.1" case esocket of Left (_ :: IOException) -> getPort Right socket -> do- sClose socket+ Network.Socket.close socket return port withWApp :: Network.Wai.Application -> (Int -> IO ()) -> IO ()@@ -80,19 +88,21 @@ (const $ takeMVar baton >> f port) withMan :: (HC.Manager -> IO ()) -> IO ()-withMan = HC.withManager . (liftIO .)+withMan = (HC.newManager HC.tlsManagerSettings >>=) main :: IO ()-main = hspec $ do+main = hspec $ describe "http-reverse-proxy" $ do it "works" $ let content = "mainApp" in withMan $ \manager -> withWApp (\_ f -> f $ responseLBS status200 [] content) $ \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 -> do- lbs <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port3+ withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 ->+ withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do+ lbs <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port4 lbs `shouldBe` content+ it "modified path" $ let content = "/somepath" app req f = f $ responseLBS status200 [] $ L8.fromChunks [rawPathInfo req]@@ -102,8 +112,9 @@ in withMan $ \manager -> withWApp app $ \port1 -> withWApp (waiProxyTo (modReq $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->- withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 -> do- lbs <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port3+ withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 ->+ withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do+ lbs <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port4 S8.concat (L8.toChunks lbs) `shouldBe` content it "deals with streaming data" $ let app _ f = f $ responseStream status200 [] $ \sendChunk flush -> forever $ do@@ -113,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@@ -129,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 }@@ -146,15 +157,98 @@ 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.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 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` "127.0.1.1"+ it "get real ip 2" $+ 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", "127.0.1.1"), ("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` "127.0.1.1"+ it "get real ip 3" $+ 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 = [("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 -> do+ 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