diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/Network/HTTP/ReverseProxy.hs b/Network/HTTP/ReverseProxy.hs --- a/Network/HTTP/ReverseProxy.hs +++ b/Network/HTTP/ReverseProxy.hs @@ -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: +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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/http-reverse-proxy.cabal b/http-reverse-proxy.cabal --- a/http-reverse-proxy.cabal +++ b/http-reverse-proxy.cabal @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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