http-reverse-proxy 0.2.1.1 → 0.3.0
raw patch · 3 files changed
+93/−67 lines, 3 filesdep +http-clientdep +resourcetdep ~http-conduitdep ~network-conduitdep ~wai
Dependencies added: http-client, resourcet
Dependency ranges changed: http-conduit, network-conduit, wai, warp
Files
- Network/HTTP/ReverseProxy.hs +81/−57
- http-reverse-proxy.cabal +5/−5
- test/main.hs +7/−5
Network/HTTP/ReverseProxy.hs view
@@ -18,38 +18,36 @@ , wpsSetIpHeader , wpsProcessBody , SetIpHeader (..)+ {- FIXME -- * WAI to Raw , waiToRaw+ -} ) where import BasicPrelude import Data.Conduit+import Data.Default (def) import qualified Network.Wai as WAI-import qualified Network.HTTP.Conduit as HC-import Control.Exception.Lifted (try, finally)-import Blaze.ByteString.Builder (fromByteString, flush)-import Data.Word8 (isSpace, _colon, toLower, _cr)+import qualified Network.HTTP.Client as HC+import Network.HTTP.Client (BodyReader, brRead)+import qualified Network.HTTP.Client.Internal as HC+import Control.Exception (bracketOnError)+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.Encoding as TE 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 Control.Monad.Trans.Control (MonadBaseControl)-import Network.Wai.Handler.Warp-import Data.Conduit.Binary (sourceFileRange)-import qualified Data.IORef as I-import Network.Socket (PortNumber (PortNum), SockAddr (SockAddrInet))-import Data.Default (Default (def))-import Data.Version (showVersion)-import qualified Paths_http_reverse_proxy-import Network.Wai.Logger.Utils (showSockAddr)+import Data.Default (Default (..))+import Network.Wai.Logger (showSockAddr) import Blaze.ByteString.Builder (Builder) import qualified Data.Set as Set+import Data.IORef -- | Host\/port combination to which we want to proxy. data ProxyDest = ProxyDest@@ -143,7 +141,7 @@ -- 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, Snap, and Happstack, for example, do).-waiProxyTo :: (WAI.Request -> ResourceT IO WaiProxyResponse)+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. -> (SomeException -> WAI.Application)@@ -162,7 +160,7 @@ -- Default: SIHFromSocket -- -- Since 0.2.0- , wpsProcessBody :: HC.Response () -> Maybe (Conduit ByteString (ResourceT IO) (Flush Builder))+ , wpsProcessBody :: HC.Response () -> Maybe (Conduit ByteString IO (Flush Builder)) -- ^ Post-process the response body returned from the host. -- -- Since 0.2.1@@ -183,6 +181,10 @@ , wpsProcessBody = const Nothing } +waiProxyToSettings :: (WAI.Request -> IO WaiProxyResponse)+ -> WaiProxySettings+ -> HC.Manager+ -> WAI.Application waiProxyToSettings getDest wps manager req0 = do edest' <- getDest req0 let edest =@@ -193,7 +195,7 @@ case edest of Left response -> return response Right (ProxyDest host port, req) -> do- let req' = HC.def+ let req' = def { HC.method = WAI.requestMethod req , HC.host = host , HC.port = port@@ -210,40 +212,37 @@ $ WAI.requestHeaders req , HC.requestBody = body , HC.redirectCount = 0-#if MIN_VERSION_http_conduit(1, 9, 0) , HC.checkStatus = \_ _ _ -> Nothing-#else- , HC.checkStatus = \_ _ -> Nothing-#endif , HC.responseTimeout = wpsTimeout wps }- fbs bs = fromByteString bs <> flush- bodySrc = mapOutput fbs $ WAI.requestBody req- bodyChunked = HC.RequestBodySourceChunked bodySrc-#if MIN_VERSION_wai(1, 4, 0)+ bodyChunked = requestBodySourceChunked $ WAI.requestBody req body = case WAI.requestBodyLength req of- WAI.KnownLength i -> HC.RequestBodySource+ WAI.KnownLength i -> requestBodySource (fromIntegral i)- bodySrc+ (WAI.requestBody req) WAI.ChunkedBody -> bodyChunked-#else- body = bodyChunked-#endif- ex <- try $ HC.http req' manager- case ex of- Left e -> wpsOnExc wps e req- Right res -> do- (src, _) <- unwrapResumable $ HC.responseBody res- let conduit =- case wpsProcessBody wps $ fmap (const ()) res of- Nothing -> awaitForever (\bs -> yield (Chunk $ fromByteString bs) >> yield Flush)- Just conduit -> conduit- return $ WAI.ResponseSource- (HC.responseStatus res)- (filter (\(key, _) -> not $ key `Set.member` strippedHeaders) $ HC.responseHeaders res) $ do- yield Flush- src =$= conduit+ bracketOnError+ (try $ HC.responseOpen req' manager)+ (either (const $ return ()) HC.responseClose)+ $ \ex -> do+ case ex of+ Left e -> wpsOnExc wps e req+ Right res -> do+ let conduit =+ case wpsProcessBody wps $ fmap (const ()) res of+ Nothing -> awaitForever (\bs -> yield (Chunk $ fromByteString bs) >> yield Flush)+ Just conduit' -> conduit'+ WAI.responseSourceBracket+ (return ())+ (\() -> HC.responseClose res)+ $ \() -> do+ let src = bodyReaderSource $ HC.responseBody res+ return+ ( HC.responseStatus res+ , filter (\(key, _) -> not $ key `Set.member` strippedHeaders) $ HC.responseHeaders res+ , src $= conduit+ ) where strippedHeaders = Set.fromList ["content-length", "transfer-encoding", "accept-encoding", "content-encoding"] @@ -275,32 +274,24 @@ (key, bs') = S.break (== _colon) bs val = S.takeWhile (/= _cr) $ S.dropWhile isSpace $ S.drop 1 bs' +{- FIXME -- | Convert a WAI application into a raw application, using Warp. waiToRaw :: WAI.Application -> DCN.Application IO waiToRaw app appdata0 =- loop $ transPipe lift fromClient0+ loop fromClient0 where fromClient0 = DCN.appSource appdata0 toClient = DCN.appSink appdata0 loop fromClient = do- mfromClient <- runResourceT $ do- ex <- try $ parseRequest conn 0 dummyAddr fromClient+ mfromClient <- runResourceT $ withInternalState $ \internalState -> do+ ex <- try $ parseRequest conn internalState dummyAddr fromClient case ex of Left (_ :: SomeException) -> return Nothing Right (req, fromClient') -> do res <- app req keepAlive <- sendResponse-#if MIN_VERSION_warp(1, 3, 8) defaultSettings- { settingsServerName = S8.pack $ concat- [ "Warp/"- , warpVersion- , " + http-reverse-proxy/"- , showVersion Paths_http_reverse_proxy.version- ]- }-#endif- dummyCleaner req conn res+ req conn res (fromClient'', _) <- liftIO fromClient' >>= unwrapResumable return $ if keepAlive then Just fromClient'' else Nothing maybe (return ()) loop mfromClient@@ -318,3 +309,36 @@ , connClose = return () , connRecv = error "connRecv should not be used" }+ -}++requestBodySource :: Int64 -> Source IO ByteString -> HC.RequestBody+requestBodySource size = HC.RequestBodyStream size . srcToPopper++requestBodySourceChunked :: Source IO ByteString -> HC.RequestBody+requestBodySourceChunked = HC.RequestBodyStreamChunked . srcToPopper++srcToPopper :: Source IO ByteString -> HC.GivesPopper ()+srcToPopper src f = do+ (rsrc0, ()) <- src $$+ return ()+ irsrc <- newIORef rsrc0+ let popper :: IO ByteString+ popper = do+ rsrc <- readIORef irsrc+ (rsrc', mres) <- rsrc $$++ await+ writeIORef irsrc rsrc'+ case mres of+ Nothing -> return S.empty+ Just bs+ | S.null bs -> popper+ | otherwise -> return bs+ f popper++bodyReaderSource :: MonadIO m => BodyReader -> Source m ByteString+bodyReaderSource br =+ loop+ where+ loop = do+ bs <- liftIO $ brRead br+ unless (S.null bs) $ do+ yield bs+ loop
http-reverse-proxy.cabal view
@@ -1,5 +1,5 @@ name: http-reverse-proxy-version: 0.2.1.1+version: 0.3.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@@ -24,14 +24,14 @@ , http-types >= 0.6 , word8 >= 0.0 , blaze-builder >= 0.3- , http-conduit >= 1.6- , wai >= 1.3+ , http-client >= 0.1+ , wai >= 2.0 , basic-prelude >= 0.3.5 , network , conduit >= 0.5- , warp >= 1.3.4 , data-default , wai-logger+ , resourcet , containers test-suite test@@ -40,7 +40,6 @@ hs-source-dirs: test build-depends: base , http-reverse-proxy- , http-conduit , network-conduit , wai , http-types@@ -52,6 +51,7 @@ , transformers , lifted-base , network+ , http-conduit source-repository head type: git
test/main.hs view
@@ -23,13 +23,13 @@ import Network.HTTP.ReverseProxy (ProxyDest (..), WaiProxyResponse (..), defaultOnExc, rawProxyTo,- waiProxyTo, waiToRaw)+ waiProxyTo{- FIXME, waiToRaw-}) import Network.HTTP.Types (status200) import Network.Socket (sClose)-import Network.Wai (Response (ResponseFile, ResponseSource),+import Network.Wai (responseSource, rawPathInfo, responseLBS) import qualified Network.Wai-import Network.Wai.Handler.Warp (defaultSettings, run, runSettings,+import Network.Wai.Handler.Warp (defaultSettings, runSettings, settingsBeforeMainLoop, settingsPort) import System.IO.Unsafe (unsafePerformIO)@@ -100,7 +100,7 @@ lbs <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port3 S8.concat (L8.toChunks lbs) `shouldBe` content it "deals with streaming data" $- let app _ = return $ ResponseSource status200 [] $ forever $ do+ let app _ = return $ responseSource status200 [] $ forever $ do yield $ Chunk $ fromByteString "hello" yield Flush liftIO $ threadDelay 10000000@@ -136,6 +136,7 @@ $ fromIntegral $ S.length body) #endif+ {- FIXME describe "waiToRaw" $ do it "works" $ do let content = "waiToRaw"@@ -147,9 +148,10 @@ it "sends files" $ do let content = "PONG" fp = "pong"- waiApp = const $ return $ ResponseFile status200 [] fp Nothing+ waiApp = const $ return $ responseFile status200 [] fp Nothing rawApp = waiToRaw waiApp writeFile fp content withCApp (rawProxyTo (const $ return $ Left rawApp)) $ \port -> do lbs <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port lbs `shouldBe` L8.pack content+ -}