diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -37,7 +37,7 @@ import qualified Filesystem as F import qualified Filesystem.Path.CurrentOS as F import Filesystem.Path.CurrentOS ((), hasExtension) -import qualified Network.HTTP.Conduit as HTTP (newManager) +import qualified Network.HTTP.Conduit as HTTP (newManager, conduitManagerSettings) import qualified System.FSNotify as FSN import System.Posix.User (getUserEntryForID, getUserEntryForName, userGroupID, @@ -175,7 +175,7 @@ startListening :: KeterConfig -> HostMan.HostManager -> IO () startListening KeterConfig {..} hostman = do - manager <- HTTP.newManager def + manager <- HTTP.newManager HTTP.conduitManagerSettings runAndBlock kconfigListeners $ Proxy.reverseProxy kconfigIpFromHeader manager diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -111,12 +111,12 @@ | encodeUtf8 path == Wai.rawPathInfo req = sendTo $ mkUrl dest | otherwise = other - noAction = Wai.ResponseBuilder + noAction = Wai.responseBuilder status404 [("Content-Type", "text/plain")] (copyByteString "File not found") - sendTo url = Wai.ResponseBuilder + sendTo url = Wai.responseBuilder status [("Location", url)] (copyByteString url) @@ -144,13 +144,13 @@ ] missingHostResponse :: Wai.Response -missingHostResponse = Wai.ResponseBuilder +missingHostResponse = Wai.responseBuilder status200 [("Content-Type", "text/html; charset=utf-8")] $ copyByteString "\nWelcome to Keter

Welcome to Keter

You did not provide a virtual hostname for this request.

" unknownHostResponse :: ByteString -> Wai.Response -unknownHostResponse host = Wai.ResponseBuilder +unknownHostResponse host = Wai.responseBuilder status200 [("Content-Type", "text/html; charset=utf-8")] (copyByteString "\nWelcome to Keter

Welcome to Keter

The hostname you have provided, " diff --git a/Network/HTTP/ReverseProxy/Rewrite.hs b/Network/HTTP/ReverseProxy/Rewrite.hs --- a/Network/HTTP/ReverseProxy/Rewrite.hs +++ b/Network/HTTP/ReverseProxy/Rewrite.hs @@ -17,6 +17,8 @@ import Data.Map ( Map ) import Data.Array ((!)) import Data.Aeson +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as S import qualified Data.Text as T @@ -40,6 +42,8 @@ import qualified Network.Wai as Wai import Network.HTTP.Conduit +import Network.HTTP.Client (responseOpen, responseClose) +import Network.HTTP.Client.Internal (brRead) import Network.HTTP.Types data RPEntry = RPEntry @@ -111,7 +115,7 @@ mkRuleMap :: Set RewriteRule -> Map HeaderName RewriteRule mkRuleMap = Map.fromList . map (\k -> (CI.mk . encodeUtf8 $ ruleHeader k, k)) . Set.toList -mkRequest :: ReverseProxyConfig -> Wai.Request -> Request (ResourceT IO) +mkRequest :: ReverseProxyConfig -> Wai.Request -> Request mkRequest rpConfig request = def { method = Wai.requestMethod request , secure = reverseUseSSL rpConfig @@ -122,8 +126,8 @@ , requestHeaders = filterHeaders $ rewriteHeaders reqRuleMap (Wai.requestHeaders request) , requestBody = case Wai.requestBodyLength request of - Wai.ChunkedBody -> RequestBodySourceChunked (mapOutput fromByteString $ Wai.requestBody request) - Wai.KnownLength n -> RequestBodySource (fromIntegral n) (mapOutput fromByteString $ Wai.requestBody request) + Wai.ChunkedBody -> requestBodySourceChunkedIO (Wai.requestBody request) + Wai.KnownLength n -> requestBodySourceIO (fromIntegral n) (Wai.requestBody request) , decompress = const False , redirectCount = 0 , checkStatus = \_ _ _ -> Nothing @@ -134,9 +138,16 @@ reqRuleMap = mkRuleMap $ rewriteRequestRules rpConfig simpleReverseProxy :: Manager -> ReverseProxyConfig -> Wai.Application -simpleReverseProxy mgr rpConfig request = +simpleReverseProxy mgr rpConfig request = Wai.responseSourceBracket + (responseOpen proxiedRequest mgr) + responseClose + $ \res -> return + ( responseStatus res + , rewriteHeaders respRuleMap $ responseHeaders res + , bodyReaderSource $ responseBody res + ) + {- do - let proxiedRequest = mkRequest rpConfig request response <- http proxiedRequest mgr (body, _) <- unwrapResumable $ responseBody response return $ @@ -144,8 +155,18 @@ (responseStatus response) (rewriteHeaders respRuleMap $ responseHeaders response) (mapOutput (Chunk . fromByteString) body) + -} where + proxiedRequest = mkRequest rpConfig request respRuleMap = mkRuleMap $ rewriteResponseRules rpConfig + bodyReaderSource br = + loop + where + loop = do + bs <- liftIO $ brRead br + unless (S.null bs) $ do + yield $ Chunk $ fromByteString bs + loop data ReverseProxyConfig = ReverseProxyConfig { reversedHost :: Text diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -1,5 +1,5 @@ Name: keter -Version: 1.0.1.2 +Version: 1.1.0 Synopsis: Web application deployment manager, focusing on Haskell web frameworks Description: Handles deployment of web apps, providing a reverse proxy to achieve zero downtime deployments. For more information, please see the README on Github: @@ -51,15 +51,17 @@ , conduit >= 0.5 , network-conduit >= 0.6 , network-conduit-tls >= 1.0.0.2 - , http-reverse-proxy >= 0.2 && < 0.3 + , http-reverse-proxy >= 0.3 && < 0.4 , unix-process-conduit >= 0.2.2 && < 0.3 , unix >= 2.5 && < 2.7 - , wai-app-static >= 1.3 && < 1.4 - , wai >= 1.4 && < 1.5 + , wai-app-static >= 2.0 && < 2.1 + , wai >= 2.0 && < 2.1 , http-types , regex-tdfa >= 1.1 , attoparsec >= 0.10 - , http-conduit + , http-conduit >= 2.0 + , http-client + , http-client-conduit , case-insensitive , array , mtl