Permalink
Browse files

Initial commit

  • Loading branch information...
1 parent eef04dd commit 79ddd6ca3655282e074c6c88d8e87915cdb74654 @snoyberg snoyberg committed Oct 2, 2012
Showing with 261 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +30 −0 LICENSE
  3. +160 −0 Network/HTTP/ReverseProxy.hs
  4. +2 −0 Setup.hs
  5. +45 −0 http-reverse-proxy.cabal
  6. +23 −0 test/main.hs
View
@@ -4,3 +4,4 @@ cabal-dev
*.hi
*.chi
*.chs.h
+*.swp
View
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2012, Michael Snoyman
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Michael Snoyman nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
@@ -0,0 +1,160 @@
+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
+module Network.HTTP.ReverseProxy
+ ( -- * Types
+ ProxyDest (..)
+ -- * Raw
+ , rawProxyTo
+ -- * WAI + http-conduit
+ , waiProxyTo
+ , defaultOnExc
+ ) where
+
+import ClassyPrelude.Conduit
+import qualified Network.Wai as WAI
+import qualified Network.HTTP.Conduit as HC
+import Control.Exception.Lifted (try, finally)
+import Blaze.ByteString.Builder (fromByteString)
+import Data.Word8 (isSpace, _colon, toLower)
+import qualified Data.ByteString.Char8 as S8
+import qualified Network.HTTP.Types as HT
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy.Encoding as TLE
+import Data.Conduit.Network
+import Control.Concurrent.MVar.Lifted (newEmptyMVar, putMVar, takeMVar)
+import Control.Concurrent.Lifted (fork, killThread)
+import Control.Monad.Trans.Control (MonadBaseControl)
+
+-- | Host\/port combination to which we want to proxy.
+data ProxyDest = ProxyDest
+ { pdHost :: !ByteString
+ , pdPort :: !Int
+ }
+
+-- | Set up a reverse 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. Parse the first request headers.
+--
+-- 2. Ask the supplied function to specify how to reverse proxy.
+--
+-- 3. Open up a connection to the given host\/port.
+--
+-- 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)
+ => (HT.RequestHeaders -> m (Either (Source m ByteString) ProxyDest))
+ -- ^ How to reverse proxy. A @Left@ result will simply return the
+ -- given content over the socket (useful for \"no such host\"
+ -- messages), whereas a @Right@ will reverse proxy to the given
+ -- host\/port.
+ -> ServerSettings -- ^ how we listen
+ -> m ()
+rawProxyTo getDest settings =
+ runTCPServer settings withClient
+ where
+ withClient fromClient toClient = do
+ (rsrc, headers) <- fromClient $$+ getHeaders
+ edest <- getDest headers
+ case edest of
+ Left src -> src $$ toClient
+ Right (ProxyDest host port) -> runTCPClient (ClientSettings port $ unpack $ TE.decodeUtf8 host) (withServer rsrc)
+ where
+ withServer rsrc fromServer toServer = 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
+
+-- | Sends a simple 502 bad gateway error message with the contents of the
+-- exception.
+defaultOnExc :: SomeException -> WAI.Application
+defaultOnExc exc _ = return $ WAI.responseLBS
+ HT.status502
+ [("content-type", "text/plain")]
+ ("Error connecting to gateway:\n\n" ++ TLE.encodeUtf8 (show exc))
+
+-- | Creates a WAI 'WAI.Application' which will handle reverse proxies.
+--
+-- Connections to the proxied server will be provided via http-conduit. As
+-- such, all requests and responses will be fully processed in your reverse
+-- proxy. This allows you much more control over the data sent over the wire,
+-- but also incurs overhead. For a lower-overhead approach, consider
+-- 'rawProxyTo'.
+--
+-- Most likely, the given application should be run with Warp, though in theory
+-- other WAI handlers will work as well.
+--
+-- Note: This function will use chunked request bodies for communicating with
+-- the proxied server. Not all servers necessarily support chunked request
+-- bodies, so please confirm that yours does (Warp, for example, does).
+waiProxyTo :: (WAI.Request -> ResourceT IO (Either WAI.Response ProxyDest))
+ -- ^ How to reverse proxy. A @Left@ result will be sent verbatim as
+ -- the response, whereas @Right@ will cause a 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 manager req = do
+ edest <- getDest req
+ case edest of
+ Left response -> return response
+ Right (ProxyDest host port) -> do
+ let req' = HC.def
+ { HC.method = WAI.requestMethod req
+ , HC.host = host
+ , HC.port = port
+ , HC.path = WAI.rawPathInfo req
+ , HC.queryString = WAI.rawQueryString req
+ , HC.requestHeaders = filter (\(key, _) -> not $ key `member` strippedHeaders) $ WAI.requestHeaders req
+ , HC.requestBody = HC.RequestBodySourceChunked $ mapOutput fromByteString $ WAI.requestBody req
+ , HC.redirectCount = 0
+ , HC.checkStatus = \_ _ -> Nothing
+ , HC.responseTimeout = Nothing
+ }
+ ex <- try $ HC.http req' manager
+ case ex of
+ Left e -> onError e req
+ Right res -> do
+ (src, _) <- unwrapResumable $ HC.responseBody res
+ return $ WAI.ResponseSource
+ (HC.responseStatus res)
+ (filter (\(key, _) -> not $ key `member` strippedHeaders) $ HC.responseHeaders res)
+ (mapOutput (Chunk . fromByteString) src)
+ where
+ strippedHeaders = asSet $ fromList ["content-length", "transfer-encoding", "accept-encoding"]
+ asSet :: Set a -> Set a
+ asSet = id
+
+-- | 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 =
+ toHeaders <$> go id
+ where
+ go front =
+ await >>= maybe close push
+ where
+ close = leftover bs >> return bs
+ where
+ bs = front empty
+ push bs'
+ | "\r\n\r\n" `S8.isInfixOf` bs
+ || "\n\n" `S8.isInfixOf` bs
+ || length bs > 1000 = leftover bs >> return bs
+ | otherwise = go $ append bs
+ where
+ bs = front bs'
+ toHeaders = map toHeader . takeWhile (not . null) . drop 1 . S8.lines
+ toHeader bs =
+ (CI.mk key, val)
+ where
+ (key, bs') = break (/= _colon) bs
+ val = dropWhile isSpace $ drop 1 bs'
View
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
View
@@ -0,0 +1,45 @@
+name: http-reverse-proxy
+version: 0.1.0.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.8
+
+library
+ exposed-modules: Network.HTTP.ReverseProxy
+ build-depends: base >= 4 && < 5
+ , monad-control >= 0.3
+ , lifted-base >= 0.1
+ , network-conduit >= 0.5
+ , text >= 0.11
+ , bytestring >= 0.9
+ , case-insensitive >= 0.4
+ , http-types >= 0.6
+ , word8 >= 0.0
+ , blaze-builder >= 0.3
+ , http-conduit >= 1.6
+ , wai >= 1.3
+ , classy-prelude-conduit >= 0.3
+
+test-suite test
+ type: exitcode-stdio-1.0
+ main-is: main.hs
+ hs-source-dirs: test
+ build-depends: base
+ , http-reverse-proxy
+ , http-conduit
+ , network-conduit
+ , wai
+ , http-types
+ , hspec >= 1.3
+ , warp >= 1.3
+
+source-repository head
+ type: git
+ location: git://github.com/fpco/http-reverse-proxy.git
View
@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Control.Concurrent (forkIO, threadDelay)
+import Data.Conduit.Network (ServerSettings (ServerSettings))
+import qualified Network.HTTP.Conduit as HC
+import Network.HTTP.ReverseProxy (ProxyDest (..), defaultOnExc,
+ rawProxyTo, waiProxyTo)
+import Network.HTTP.Types (status200)
+import Network.Wai (responseLBS)
+import Network.Wai.Handler.Warp (run)
+import Test.Hspec (describe, hspec, it, shouldBe)
+
+main :: IO ()
+main = hspec $ do
+ describe "http-reverse-proxy" $ do
+ it "works" $ do
+ let content = "mainApp"
+ manager <- HC.newManager HC.def
+ forkIO $ run 5000 $ const $ return $ responseLBS status200 [] content
+ forkIO $ run 5001 $ waiProxyTo (const $ return $ Right $ ProxyDest "localhost" 5000) defaultOnExc manager
+ forkIO $ rawProxyTo (const $ return $ Right $ ProxyDest "localhost" 5001) $ ServerSettings 5002 "*"
+ threadDelay 100000
+ lbs <- HC.simpleHttp "http://localhost:5002"
+ lbs `shouldBe` content

0 comments on commit 79ddd6c

Please sign in to comment.