Merge branch 'master' of https://github.com/AaronFriel/keter

.gitignore

@@ -11,3 +11,5 @@ temp/
 test/app
 incoming/foo/hello
 log/
+.cabal-sandbox/
+cabal.sandbox.config

Keter/Main.hs

@@ -16,6 +16,7 @@ import qualified Keter.LogFile as LogFile
 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 Control.Applicative ((<$>), (<*>))
 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 @@ data Config = Config
     , 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 @@ instance Default Config where
         , configPort = 80
         , configSsl = Nothing
         , configSetuid = Nothing
+        , configReverseProxy = Set.empty
         }
 
 instance FromJSON Config where
@@ -63,6 +70,7 @@ instance FromJSON Config where
         <*> 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 @@ keter input' = do
     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

Keter/PortManager.hs

@@ -33,6 +33,7 @@ import qualified Data.ByteString as S
 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 @@ addEntry (PortManager f) h p = f $ case h of
     "*" -> 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 ()

Keter/Proxy.hs

@@ -22,6 +22,7 @@ import Network.HTTP.ReverseProxy (rawProxyTo, ProxyDest (ProxyDest), waiToRaw)
 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 @@ withClient portLookup =
             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
 

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

README.md

@@ -44,6 +44,24 @@ root: ..
 #   port:
 #   key:
 #   certificate:
+# reverse-proxy:
+#  - reversed-host: some-internal-site
+#    reversed-port: 80
+#    reversing-host: internal.example.com
+#    ssl: whether the reversed host uses SSL (defaults to False)
+#    # response headers can be rewritten as follows:
+#    rewrite-response:
+#      - header: Location
+#        from: ^http://internal-service.example.com
+#        to: https://service.example.com
+#    # request headers can be rewritten as well, though less likely
+#    # to be used.
+#    rewrite-request:
+#      - header: X-SomeApplicationHeader
+#        from: ^https://internal-service.example.com
+#        to: http://service.example.com
+# # Header rewriting supports POSIX regular expressions in the "from" and
+# # supports referencing matched groups in the "to" with "\1", "\2", ...
 ```
 
 Fourth, set up an Upstart job to start `keter` when your system boots.

keter-config.yaml

@@ -8,3 +8,15 @@ ssl:
     host: "*4"
     key: key.pem
     certificate: certificate.pem
+# Keter can act as a reverse proxy for other servers in your network
+# so that it can replace a front-end nginx or apache server. Example:
+# reverse-proxy:
+#   - reversed-host: internal-service          # hostname of internal server
+#     reversed-port: 8080                      # port to access
+#     ssl: False                               # whether to use SSL to access internal server
+#     reversing-host: service.example.com      # Keter will reverse proxy requests for this host to your server
+#     # Keter also supports rewriting headers. See the README.md for more information.
+#     rewrite-response:
+#       - header: Location
+#         from: ^http://internal-service.example.com
+#         to: https://service.example.com    

keter.cabal

@@ -47,6 +47,12 @@ Library
                      , wai-app-static            >= 1.3           && < 1.4
                      , wai                       >= 1.3           && < 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 @@ Library
                        Keter.Proxy
                        Keter.PortManager
                        Keter.SSL
+                       Keter.ReverseProxy
   c-sources:           cbits/process-tracker.c
   ghc-options:         -Wall