diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/Network/HTTP/ReverseProxy.hs b/Network/HTTP/ReverseProxy.hs --- a/Network/HTTP/ReverseProxy.hs +++ b/Network/HTTP/ReverseProxy.hs @@ -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: +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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. 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.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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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