diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,12 @@ +## 0.6.0.2 + +* Add `wpsLogRequest` function which provides the ability to log the + constructed `Request`. + +## 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) + ## 0.6.0 * Switch over to `unliftio` and conduit 1.3 diff --git a/Network/HTTP/ReverseProxy.hs b/Network/HTTP/ReverseProxy.hs --- a/Network/HTTP/ReverseProxy.hs +++ b/Network/HTTP/ReverseProxy.hs @@ -26,6 +26,7 @@ , wpsProcessBody , wpsUpgradeToRaw , wpsGetDest + , wpsLogRequest , SetIpHeader (..) -- *** Local settings , LocalWaiProxySettings @@ -51,6 +52,8 @@ 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, listToMaybe) import Data.Monoid (mappend, mconcat, (<>)) import Data.Set (Set) @@ -133,7 +136,7 @@ -- -- If you need more control, such as modifying the request or response, use 'waiProxyTo'. -- --- Since 0.4.4 +-- @since 0.4.4 rawTcpProxyTo :: MonadIO m => ProxyDest -> AppData @@ -156,15 +159,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 @@ -173,15 +176,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. -- @@ -212,12 +218,12 @@ -- -- Default: no timeouts -- - -- Since 0.4.2 + -- @since 0.4.2 } -- | Default value for 'LocalWaiProxySettings', same as 'def' but with a more explicit name. -- --- Since 0.4.2 +-- @since 0.4.2 defaultLocalWaiProxySettings :: LocalWaiProxySettings defaultLocalWaiProxySettings = LocalWaiProxySettings Nothing @@ -225,7 +231,7 @@ -- -- Default: no timeouts -- --- Since 0.4.2 +-- @since 0.4.2 setLpsTimeBound :: Maybe Int -> LocalWaiProxySettings -> LocalWaiProxySettings setLpsTimeBound x s = s { lpsTimeBound = x } @@ -237,13 +243,13 @@ -- -- Default: SIHFromSocket -- - -- Since 0.2.0 + -- @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 @@ -251,7 +257,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 @@ -259,12 +265,18 @@ -- -- 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.2 } -- | 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 @@ -281,6 +293,7 @@ , wpsUpgradeToRaw = \req -> (CI.mk <$> lookup "upgrade" (WAI.requestHeaders req)) == Just "websocket" , wpsGetDest = Nothing + , wpsLogRequest = const (pure ()) } renderHeaders :: WAI.Request -> HT.RequestHeaders -> Builder @@ -375,6 +388,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 @@ -395,14 +414,10 @@ , 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 @@ -418,6 +433,54 @@ 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 diff --git a/http-reverse-proxy.cabal b/http-reverse-proxy.cabal --- a/http-reverse-proxy.cabal +++ b/http-reverse-proxy.cabal @@ -1,5 +1,5 @@ name: http-reverse-proxy -version: 0.6.0 +version: 0.6.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 @@ -9,15 +9,16 @@ maintainer: michael@fpcomplete.com category: Web build-type: Simple -cabal-version: >=1.8 +cabal-version: >=1.10 extra-source-files: README.md ChangeLog.md library + default-language: Haskell2010 exposed-modules: Network.HTTP.ReverseProxy other-modules: Paths_http_reverse_proxy if impl(ghc < 8) buildable: False - build-depends: base >= 4.6 && < 5 + build-depends: base >= 4.11 && < 5 , text >= 0.11 , bytestring >= 0.9 , case-insensitive >= 0.4 @@ -37,10 +38,11 @@ , streaming-commons test-suite test + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test - build-depends: base + build-depends: base < 10 , http-reverse-proxy , wai , http-types diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -44,6 +44,7 @@ setBeforeMainLoop, setPort) import System.IO.Unsafe (unsafePerformIO) import UnliftIO (timeout) +import UnliftIO.IORef import Test.Hspec (describe, hspec, it, shouldBe) nextPort :: I.IORef Int @@ -210,6 +211,29 @@ 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 "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