diff --git a/Network/HTTP/ReverseProxy.hs b/Network/HTTP/ReverseProxy.hs --- a/Network/HTTP/ReverseProxy.hs +++ b/Network/HTTP/ReverseProxy.hs @@ -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 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.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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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 + -}