diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -16,6 +16,7 @@ import qualified Keter.Logger as Logger import qualified Keter.PortManager as PortMan import qualified Keter.Proxy as Proxy +import qualified Keter.ReverseProxy as ReverseProxy import Data.Conduit.Network (serverSettings, HostPreference) import qualified Control.Concurrent.MVar as M @@ -36,6 +37,9 @@ import Data.String (fromString) import System.Posix.User (userID, userGroupID, getUserEntryForName, getUserEntryForID, userName) import qualified Data.Text.Read +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Network.HTTP.Conduit as HTTP (newManager) data Config = Config { configDir :: F.FilePath @@ -44,7 +48,9 @@ , configPort :: PortMan.Port , configSsl :: Maybe Proxy.TLSConfigNoDir , configSetuid :: Maybe Text + , configReverseProxy :: Set ReverseProxy.ReverseProxyConfig } + instance Default Config where def = Config { configDir = "." @@ -53,6 +59,7 @@ , configPort = 80 , configSsl = Nothing , configSetuid = Nothing + , configReverseProxy = Set.empty } instance FromJSON Config where @@ -63,6 +70,7 @@ <*> o .:? "port" .!= configPort def <*> o .:? "ssl" <*> o .:? "setuid" + <*> o .:? "reverse-proxy" .!= Set.empty parseJSON _ = mzero keter :: P.FilePath -- ^ root directory or config file @@ -168,6 +176,13 @@ bundles <- fmap (filter isKeter) $ listDirectory incoming runKIO' $ mapM_ addApp bundles + let staticReverse r = do + initMgr <- liftIO $ HTTP.newManager def + case initMgr of + Left e -> log $ ExceptionThrown "Failed to instantiate manager for reverse proxy." e + Right mgr -> PortMan.addEntry portman (ReverseProxy.reversingHost r) $ PortMan.PEReverseProxy $ ReverseProxy.RPEntry r mgr + runKIO' $ mapM_ staticReverse (Set.toList configReverseProxy) + let events = [I.MoveIn, I.MoveOut, I.Delete, I.CloseWrite] i <- I.initINotify _ <- I.addWatch i events (toString incoming) $ \e -> do diff --git a/Keter/PortManager.hs b/Keter/PortManager.hs --- a/Keter/PortManager.hs +++ b/Keter/PortManager.hs @@ -33,6 +33,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Yaml (FromJSON (parseJSON), Value (Object)) import Control.Applicative ((<$>)) +import qualified Keter.ReverseProxy as ReverseProxy (RPEntry) -- | A port for an individual app to listen on. type Port = Int @@ -150,7 +151,7 @@ "*" -> AddDefaultEntry p _ -> AddEntry h p -data PortEntry = PEPort Port | PEStatic FilePath | PERedirect S.ByteString +data PortEntry = PEPort Port | PEStatic FilePath | PERedirect S.ByteString | PEReverseProxy ReverseProxy.RPEntry -- | Remove an entry from the configuration and reload nginx. removeEntry :: PortManager -> Host -> KIO () diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -22,6 +22,7 @@ import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) import qualified Network.Wai as Wai import Network.HTTP.Types (status301) +import qualified Keter.ReverseProxy as ReverseProxy -- | Mapping from virtual hostname to port number. type PortLookup = ByteString -> IO (Maybe PortEntry) @@ -44,6 +45,7 @@ Just (PEPort port) -> return $ Right $ ProxyDest "127.0.0.1" port Just (PEStatic root) -> return $ Left $ waiToRaw $ staticApp $ defaultFileServerSettings root Just (PERedirect host) -> return $ Left $ waiToRaw $ redirectApp host + Just (PEReverseProxy rpentry) -> return $ Left $ waiToRaw $ ReverseProxy.simpleReverseProxy rpentry where mhost = lookup "host" headers diff --git a/Keter/ReverseProxy.hs b/Keter/ReverseProxy.hs new file mode 100644 --- /dev/null +++ b/Keter/ReverseProxy.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} +module Keter.ReverseProxy + ( ReverseProxyConfig (..) + , RewriteRule (..) + , RPEntry (..) + , simpleReverseProxy + ) + where + +import Control.Applicative ((<$>),(<*>),(<|>)) +import Data.Monoid ((<>)) + +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Map as Map +import Data.Map ( Map ) +import Data.Array ((!)) + +import qualified Data.ByteString as S +import qualified Data.Text as T +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import qualified Data.CaseInsensitive as CI + +import Blaze.ByteString.Builder (fromByteString) + +-- Configuration files +import Data.Yaml (FromJSON (..), Value (Object), (.:), (.:?), (.!=)) +import Data.Default + +-- Regular expression parsing, replacement, matching +import Data.Attoparsec.Text (string, takeWhile1, endOfInput, parseOnly, Parser) +import Text.Regex.TDFA (makeRegex, matchOnceText, MatchText) +import Text.Regex.TDFA.String (Regex) +import Data.Char (isDigit) + +-- Reverse proxy apparatus +import Data.Conduit + +import qualified Network.Wai as Wai +import Network.HTTP.Conduit +import Network.HTTP.Types + +data ReverseProxyConfig = ReverseProxyConfig + { reversedHost :: Text + , reversedPort :: Int + , reversingHost :: Text + , reverseUseSSL :: Bool + , rewriteResponseRules :: Set RewriteRule + , rewriteRequestRules :: Set RewriteRule + } deriving (Eq, Ord) + +instance FromJSON ReverseProxyConfig where + parseJSON (Object o) = ReverseProxyConfig + <$> o .: "reversed-host" + <*> o .: "reversed-port" + <*> o .: "reversing-host" + <*> o .: "ssl" .!= False + <*> o .:? "rewrite-response" .!= Set.empty + <*> o .:? "rewrite-request" .!= Set.empty + parseJSON _ = fail "Wanted an object" + +instance Default ReverseProxyConfig where + def = ReverseProxyConfig + { reversedHost = "" + , reversedPort = 80 + , reversingHost = "" + , reverseUseSSL = False + , rewriteResponseRules = Set.empty + , rewriteRequestRules = Set.empty + } + +data RewriteRule = RewriteRule + { ruleHeader :: Text + , ruleRegex :: Text + , ruleReplacement :: Text + } deriving (Eq, Ord) + +instance FromJSON RewriteRule where + parseJSON (Object o) = RewriteRule + <$> o .: "header" + <*> o .: "from" + <*> o .: "to" + parseJSON _ = fail "Wanted an object" + +data RPEntry = RPEntry + { config :: ReverseProxyConfig + , httpManager :: Manager + } + +getGroup :: MatchText String -> Int -> String +getGroup matches i = fst $ matches ! i + +rewrite :: (String, MatchText String, String) -> String -> String -> Text +rewrite (before, match, after) input replacement = + case parseOnly parseSubstitute (T.pack replacement) of + Left _ -> T.pack input + Right result -> T.pack before <> result <> T.pack after + where + parseSubstitute :: Parser Text + parseSubstitute = + (endOfInput >> "") + <|> do + { _ <- string "\\\\" + ; rest <- parseSubstitute + ; return $ "\\" <> rest + } + <|> do + { _ <- string "\\" + ; n <- (fmap (read . T.unpack) $ takeWhile1 isDigit) :: Parser Int + ; rest <- parseSubstitute + ; return $ T.pack (getGroup match n) <> rest + } + <|> do + { text <- takeWhile1 (/= '\\') + ; rest <- parseSubstitute + ; return $ text <> rest + } + +rewriteHeader :: Map HeaderName RewriteRule -> Header -> Header +rewriteHeader rules header@(name, value) = + case Map.lookup name rules of + Nothing -> header + Just r -> (name, regexRewrite r value) + +rewriteHeaders :: Map HeaderName RewriteRule -> [Header] -> [Header] +rewriteHeaders ruleMap = map (rewriteHeader ruleMap) + +regexRewrite :: RewriteRule -> S.ByteString -> S.ByteString +regexRewrite (RewriteRule _ regex' replacement) input = + case matchOnceText regex strInput of + Just match -> encodeUtf8 $ rewrite match strInput strReplacement + Nothing -> input + where + strRegex = T.unpack regex' + regex :: Regex + regex = makeRegex strRegex + strInput = T.unpack . decodeUtf8 $ input + strReplacement = T.unpack replacement + +filterHeaders :: [Header] -> [Header] +filterHeaders = filter useHeader + where + useHeader ("Transfer-Encoding", _) = False + useHeader ("Content-Length", _) = False + useHeader ("Host", _) = False + useHeader _ = True + +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 rpConfig request = + def { method = Wai.requestMethod request + , secure = reverseUseSSL rpConfig + , host = encodeUtf8 $ reversedHost rpConfig + , port = reversedPort rpConfig + , path = Wai.rawPathInfo request + , queryString = Wai.rawQueryString request + , 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) + , decompress = const False + , redirectCount = 0 + , checkStatus = \_ _ _ -> Nothing + --, responseTimeout = 5000 -- current default (as of 2013-03-18) + , cookieJar = Nothing + } + where + reqRuleMap = mkRuleMap $ rewriteRequestRules rpConfig + +simpleReverseProxy :: RPEntry -> Wai.Application +simpleReverseProxy (RPEntry { config = rpConfig, httpManager = mgr }) request = + do + let proxiedRequest = mkRequest rpConfig request + response <- http proxiedRequest mgr + (body, _) <- unwrapResumable $ responseBody response + return $ + Wai.ResponseSource + (responseStatus response) + (rewriteHeaders respRuleMap $ responseHeaders response) + (mapOutput (Chunk . fromByteString) body) + where + respRuleMap = mkRuleMap $ rewriteResponseRules rpConfig diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -1,5 +1,5 @@ Name: keter -Version: 0.3.5.4 +Version: 0.3.6 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: @@ -45,8 +45,14 @@ , unix-process-conduit >= 0.2 && < 0.3 , unix >= 2.5 && < 2.7 , wai-app-static >= 1.3 && < 1.4 - , wai >= 1.3 && < 1.5 + , wai >= 1.4 && < 1.5 , http-types + , regex-tdfa >= 1.1 + , attoparsec >= 0.10 + , http-conduit + , case-insensitive + , array + , mtl Exposed-Modules: Keter.Process Keter.ProcessTracker Keter.Postgres @@ -59,6 +65,7 @@ Keter.Proxy Keter.PortManager Keter.SSL + Keter.ReverseProxy c-sources: cbits/process-tracker.c ghc-options: -Wall