keter 0.3.5.4 → 0.3.6

raw patch · 5 files changed

+214/−3 lines, 5 filesdep +arraydep +attoparsecdep +case-insensitivedep ~waiPVP ok

version bump matches the API change (PVP)

Dependencies added: array, attoparsec, case-insensitive, http-conduit, mtl, regex-tdfa

Dependency ranges changed: wai

API changes (from Hackage documentation)

Files

• Keter/Main.hs +15/−0
• Keter/PortManager.hs +2/−1
• Keter/Proxy.hs +2/−0
• Keter/ReverseProxy.hs +186/−0
• keter.cabal +9/−2

@@ -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

@@ -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 ()

@@ -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 

@@ -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

@@ -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: <https://github.com/snoyberg/keter#readme>@@ -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