keter 2.2.1 → 2.3.0
raw patch · 10 files changed
+596/−162 lines, 10 filesdep +binarydep +keter-rate-limiting-plugindep ~aesondep ~indexed-traversabledep ~tls
Dependencies added: binary, keter-rate-limiting-plugin
Dependency ranges changed: aeson, indexed-traversable, tls, unordered-containers
Files
- ChangeLog.md +6/−0
- README.md +20/−0
- keter.cabal +11/−2
- src/Keter/App.hs +43/−32
- src/Keter/AppManager.hs +47/−3
- src/Keter/Config/Middleware.hs +84/−37
- src/Keter/Config/V10.hs +34/−4
- src/Keter/Proxy.hs +100/−72
- test/Keter/Proxy/MiddlewareSpec.hs +233/−0
- test/Spec.hs +18/−12
ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog +## 2.3.0++- Add integration with keter-rate-limiting-plugin. [301](https://github.com/snoyberg/keter/issues/301), thanks @Oleksandr-Zhabenko+- Provided additional possibilities to apply middlewares per-app.+- Further improvements on unnecessary file reloading [318](https://github.com/snoyberg/keter/pull/323), thanks @ktak-007 + ## 2.2.1 - Fix unnecessary file reloading: https://github.com/snoyberg/keter/pull/320 - bump tar
README.md view
@@ -465,6 +465,26 @@ This option is disabled by default, but can be useful to figure out what keter is doing. +## Rate Limiting Middleware (New in 2.3.0)++The release 2.3.0 introduces a first-class, per-stanza rate-limiting +middleware you can attach to any app bundle (webapp, reverse-proxy, +static-files). It supports multiple algorithms (Fixed Window, +Sliding Window, Token Bucket, Leaky Bucket, TinyLRU), flexible +identifiers (IP, headers, cookies, combined), and zone separation +(by vhost, IP, or header). You can define multiple throttles +in one middleware block and also stack multiple middleware blocks. +It is related to the issue [#301](https://github.com/snoyberg/keter/issues/301)++More information about rate limiting middleware is available on the +Hackage webpage of it in the README there:+[https://hackage.haskell.org/package/keter-rate-limiting-plugin-0.2.0.2](https://hackage.haskell.org/package/keter-rate-limiting-plugin-0.2.0.2)++### Global daemon settings impacting behavior (keter-config.yaml):++* `ip-from-header`: influences throttles with `identifier_by: ip`.+* `healthcheck-path`: this path is always allowed and never rate-limited.+ ## Contributing If you are interested in contributing, see
keter.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: keter-version: 2.2.1+version: 2.3.0 synopsis: Web application deployment manager, focusing on Haskell web frameworks. It mitigates downtime. @@ -32,6 +32,7 @@ , async >=2.2.4 && <2.3 , attoparsec >=0.14.4 && <0.15 , base >=4 && <5+ , binary >= 0.8.9.1 , blaze-builder >=0.3 && <0.5 , bytestring >=0.10.12 && <0.12 || ^>=0.12.0.0 , case-insensitive >=1.2.1 && <1.3@@ -46,7 +47,8 @@ , http-conduit >=2.3.8 && <2.4 , http-reverse-proxy >=0.6.2 && <0.7 , http-types >=0.12.3 && <0.13- , indexed-traversable >=0.1.2 && <0.2+ , indexed-traversable >=0.1.2 && <0.2.1+ , keter-rate-limiting-plugin ==0.2.0.2 , lifted-base >=0.2.3 && <0.3 , monad-logger >=0.3.0 && <0.4.0 , mtl >=2.2.2 && <2.3 || ^>=2.3.1@@ -97,6 +99,7 @@ Keter.Rewrite Keter.SharedData.App Keter.SharedData.AppManager+ Keter.TempTarball Keter.Yaml.FilePath @@ -105,6 +108,7 @@ Paths_keter autogen-modules: Paths_keter+ ghc-options: -Wall c-sources: cbits/process-tracker.c hs-source-dirs: src@@ -128,8 +132,10 @@ hs-source-dirs: test default-extensions: ImportQualifiedPost main-is: Spec.hs+ other-modules: Keter.Proxy.MiddlewareSpec type: exitcode-stdio-1.0 build-depends:+ , aeson , base , bytestring , conduit@@ -138,14 +144,17 @@ , http-types , HUnit , keter+ , keter-rate-limiting-plugin , lens , monad-logger , mtl , stm , tasty , tasty-hunit+ , tls , transformers , unix+ , unordered-containers , wai , warp , wreq
src/Keter/App.hs view
@@ -66,6 +66,9 @@ import System.Posix.Types (EpochTime) import System.Timeout (timeout) +import Keter.Config.Middleware (processMiddlewareIO, MiddlewareConfig)+import Network.Wai (Middleware)+ unpackBundle :: FilePath -> AppId -> KeterM AppStartConfig (FilePath, BundleConfig)@@ -75,12 +78,9 @@ liftIO $ unpackTempTar (fmap snd ascSetuid) ascTempFolder bundle folderName $ \dir -> do -- Get the FilePath for the keter yaml configuration. Tests for -- keter.yml and defaults to keter.yaml.- configFP <- do- let yml = dir </> "config" </> "keter.yml"- exists <- doesFileExist yml- return $ if exists then yml- else dir </> "config" </> "keter.yaml"-+ let yml = dir </> "config" </> "keter.yml"+ exists <- doesFileExist yml+ let configFP = if exists then yml else dir </> "config" </> "keter.yaml" mconfig <- decodeFileRelative configFP config <- case mconfig of@@ -128,43 +128,52 @@ <$> TLS.credentialLoadX509Chain certFile (V.toList chainCertFiles) keyFile loadCert _ = return mempty + setupMW :: [Keter.Config.Middleware.MiddlewareConfig] -> IO Middleware+ setupMW = processMiddlewareIO+ loop [] wacs backs actions = f wacs backs actions loop (Stanza (StanzaWebApp wac) rs:stanzas) wacs backs actions = do AppStartConfig{..} <- ask withRunInIO $ \rio -> liftIO $ bracketOnError- (rio (getPort ascPortPool) >>= either throwIO- (\p -> fmap (p,) <$> loadCert $ waconfigSsl wac)+ (rio (getPort ascPortPool) >>= either throwIO pure)+ (\port -> releasePort ascPortPool port)+ (\port -> do+ mw <- setupMW (waconfigMiddleware wac)+ let wac' = wac { waconfigPort = port }+ action = PAPort port mw (waconfigTimeout wac)+ hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac)+ cert <- loadCert (waconfigSsl wac)+ rio $ loop+ stanzas+ (wac' : wacs)+ backs+ (Map.unions $ actions : map (\host -> Map.singleton host ((action, rs), cert)) hosts) )- (\(port, _) -> releasePort ascPortPool port)- (\(port, cert) -> rio $ loop- stanzas- (wac { waconfigPort = port } : wacs)- backs- (Map.unions $ actions : map (\host -> Map.singleton host ((PAPort port (waconfigTimeout wac), rs), cert)) hosts))- where- hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac) loop (Stanza (StanzaStaticFiles sfc) rs:stanzas) wacs backs actions0 = do cert <- liftIO $ loadCert $ sfconfigSsl sfc- loop stanzas wacs backs (actions cert)+ mw <- liftIO $ setupMW (sfconfigMiddleware sfc)+ let action = PAStatic sfc mw+ loop stanzas wacs backs (actions action cert) where- actions cert = Map.unions- $ actions0- : map (\host -> Map.singleton host ((PAStatic sfc, rs), cert))- (Set.toList (sfconfigHosts sfc))+ actions action cert =+ Map.unions $ actions0 :+ map (\host -> Map.singleton host ((action, rs), cert))+ (Set.toList (sfconfigHosts sfc)) loop (Stanza (StanzaRedirect red) rs:stanzas) wacs backs actions0 = do cert <- liftIO $ loadCert $ redirconfigSsl red- loop stanzas wacs backs (actions cert)+ let action = PARedirect red+ loop stanzas wacs backs (actions action cert) where- actions cert = Map.unions- $ actions0- : map (\host -> Map.singleton host ((PARedirect red, rs), cert))- (Set.toList (redirconfigHosts red))+ actions action cert =+ Map.unions $ actions0 :+ map (\host -> Map.singleton host ((action, rs), cert))+ (Set.toList (redirconfigHosts red)) loop (Stanza (StanzaReverseProxy rev mid to) rs:stanzas) wacs backs actions0 = do cert <- liftIO $ loadCert $ reversingUseSSL rev- loop stanzas wacs backs (actions cert)- where- actions cert = Map.insert (CI.mk $ reversingHost rev) ((PAReverseProxy rev mid to, rs), cert) actions0+ mw <- liftIO $ setupMW mid+ let action = PAReverseProxy rev mw to+ loop stanzas wacs backs (Map.insert (CI.mk $ reversingHost rev) ((action, rs), cert) actions0) loop (Stanza (StanzaBackground back) _:stanzas) wacs backs actions = loop stanzas wacs (back:backs) actions @@ -222,7 +231,7 @@ start aid input tstate = withLogger aid Nothing $ \tAppLogger appLogger -> withConfig aid input $ \newdir bconfig mmodtime ->- withSanityChecks bconfig $+ withSanityChecks bconfig $ withReservations aid bconfig $ \webapps backs actions -> withBackgroundApps aid bconfig newdir appLogger backs $ \runningBacks -> withWebApps aid bconfig newdir appLogger webapps $ \runningWebapps -> do@@ -578,7 +587,7 @@ withLogger appId (Just appLog) $ \_ appLogger -> withConfig appId input $ \newdir bconfig mmodtime -> withSanityChecks bconfig $- withReservations appId bconfig $ \webapps backs actions ->+ withReservations appId bconfig $ \webapps backs actions -> withBackgroundApps appId bconfig newdir appLogger backs $ \runningBacks -> withWebApps appId bconfig newdir appLogger webapps $ \runningWebapps -> do liftIO $ mapM_ (ensureAlive tstate) runningWebapps@@ -635,7 +644,9 @@ -> Maybe Logger -> KeterM AppStartConfig () terminateHelper aid apps backs mdir _appLogger = do- liftIO $ threadDelay $ 20 * 1000 * 1000+ AppStartConfig{..} <- ask+ let preDelay = maybe (20 * 1000 * 1000) id (kconfigGracefulDrainMicros ascKeterConfig)+ liftIO $ threadDelay preDelay $logInfo $ pack $ "Sending old process TERM signal: " ++ case aid of { AINamed t -> unpack t; AIBuiltin -> "builtin" }
src/Keter/AppManager.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | Used for management of applications. module Keter.AppManager ( -- * Types@@ -19,17 +20,26 @@ , renderApps ) where +import Conduit (sourceFile, (.|), ConduitT, ResourceT, runResourceT, runConduit, awaitForever, sinkNull) import Control.Applicative import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (MVar, newMVar, withMVar) import Control.Concurrent.STM import Control.Exception (SomeException) import Control.Exception qualified as E-import Control.Monad (forM_, void, when)+import Control.Monad (forM_, void, when, unless) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Unlift (withRunInIO) import Control.Monad.Logger import Control.Monad.Reader (ask)+import Control.Monad.State (runStateT, StateT, modify)+import Data.Binary (Word32)+import Data.Binary.Get (getWord32le, runGet)+import Data.Bits (Bits((.|.), shiftR))+import qualified Data.ByteString.Char8 as C+import Data.ByteString.Lazy qualified as BL+import Data.Conduit.Zlib (ungzip)+import Data.Conduit (yield) import Data.Foldable (fold) import Data.Map (Map) import Data.Map qualified as Map@@ -297,10 +307,12 @@ return () waitAndPerform = do waitUntilStable bundle+ runable <- isGzip bundle AppManager {..} <- ask removeBundleFromQueue loads- (input, action) <- liftIO $ getInputForBundle bundle- perform input action+ when runable $ do+ (input, action) <- liftIO $ getInputForBundle bundle+ perform input action putBundleIntoQueue loads = modifyTVar loads (bundle:) removeBundleFromQueue loads = liftIO $ atomically $ modifyTVar loads $ filter (/= bundle) @@ -322,3 +334,35 @@ when (new /= old) $ do threadDelay 1000000 -- wait 1 sec loop new++isGzip :: FilePath -> KeterM AppManager Bool+isGzip bundle = do+ res <- liftIO $ either (const $ return False) checkSizes+ =<< E.try @SomeException+ ( runResourceT . flip runStateT (0, 0) . runConduit+ $ sourceFile bundle+ .| readSize+ .| ungzip+ .| countSize+ .| sinkNull+ )+ unless res $ $logError $ pack $ "File '" <> bundle <> "' is not gzip"+ return res+ where+ checkSizes (_, (size, counter)) = return $ size >0 && size == counter++readSize :: ConduitT C.ByteString C.ByteString (StateT (Word32, Word32) (ResourceT IO)) ()+readSize = awaitForever $ \chunk -> do+ let footer = BL.takeEnd 4 $ BL.fromStrict chunk+ footerLength = BL.length footer+ nullPrefix = BL.take (4 - footerLength) (BL.repeat 0)+ size = runGet getWord32le $ nullPrefix <> footer+ modify $ \(prevSize, counter) ->+ let newSize = shiftR prevSize (8 * fromIntegral footerLength) .|. size+ in (newSize, counter)+ yield chunk++countSize :: ConduitT C.ByteString C.ByteString (StateT (Word32, Word32) (ResourceT IO)) ()+countSize = awaitForever $ \chunk -> do+ modify $ \(size, counter) -> (size, counter + fromIntegral (C.length chunk))+ yield chunk
src/Keter/Config/Middleware.hs view
@@ -21,25 +21,34 @@ import Network.Wai.Middleware.MethodOverride (methodOverride) import Network.Wai.Middleware.MethodOverridePost (methodOverridePost) -import Data.ByteString as S (ByteString)-import Data.ByteString.Lazy as L (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L import Data.String (fromString)-import Data.Text.Encoding as T (decodeUtf8, encodeUtf8)-import Data.Text.Lazy.Encoding as TL (decodeUtf8, encodeUtf8)-import Keter.Aeson.KeyHelper qualified as AK (empty, toKey, toList, toText)+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy.Encoding as TL+import qualified Keter.Aeson.KeyHelper as AK (empty, toKey, toList, toText) +-- Rate limiter (updated API: buildEnvFromConfig + buildRateLimiterWithEnv)+import Keter.RateLimiter.WAI+ ( RateLimiterConfig(..)+ , buildEnvFromConfig+ , buildRateLimiterWithEnv+ )+ data MiddlewareConfig = AcceptOverride | Autohead | Jsonp | MethodOverride | MethodOverridePost | AddHeaders ![(S.ByteString, S.ByteString)]- | BasicAuth !String ![(S.ByteString, S.ByteString)]+ | BasicAuth !String ![(S.ByteString, S.ByteString)] -- ^ Realm [(username,password)] | Local !Int !L.ByteString -- ^ Status Message- deriving (Show,Generic)+ | RateLimiter !RateLimiterConfig+ -- ^ Rate Limiter+ deriving (Show, Generic) instance FromJSON MiddlewareConfig where parseJSON (String "accept-override" ) = pure AcceptOverride@@ -48,13 +57,24 @@ parseJSON (String "method-override" ) = pure MethodOverride parseJSON (String "method-override-post") = pure MethodOverridePost parseJSON (Object o) =- case AK.toList o of- [("basic-auth", Object o')] -> BasicAuth <$> o' .:? "realm" .!= "keter"- <*> (map ((T.encodeUtf8 . AK.toText) *** T.encodeUtf8) . AK.toList <$> o' .:? "creds" .!= AK.empty)- [("headers" , Object _ )] -> AddHeaders . map ((T.encodeUtf8 . AK.toText) *** T.encodeUtf8) . AK.toList <$> o .:? "headers" .!= AK.empty- [("local" , Object o')] -> Local <$> o' .:? "status" .!= 401- <*> (TL.encodeUtf8 <$> o' .:? "message" .!= "Unauthorized Accessing from Localhost ONLY" )- _ -> mzero -- fail "Rule: unexpected format"+ case AK.toList o of+ [("basic-auth", Object o')] ->+ BasicAuth <$> o' .:? "realm" .!= "keter"+ <*> (map ((T.encodeUtf8 . AK.toText) *** T.encodeUtf8)+ . AK.toList <$> o' .:? "creds" .!= AK.empty)++ [("headers", Object _ )] ->+ AddHeaders . map ((T.encodeUtf8 . AK.toText) *** T.encodeUtf8)+ . AK.toList <$> o .:? "headers" .!= AK.empty++ [("local", Object o')] ->+ Local <$> o' .:? "status" .!= 401+ <*> (TL.encodeUtf8 <$> o' .:? "message"+ .!= "Unauthorized Accessing from Localhost ONLY")++ [("rate-limiter", v)] -> RateLimiter <$> parseJSON v++ _ -> mzero parseJSON _ = mzero instance ToJSON MiddlewareConfig where@@ -63,38 +83,65 @@ toJSON Jsonp = "jsonp" toJSON MethodOverride = "method-override" toJSON MethodOverridePost = "method-override-post"- toJSON (BasicAuth realm cred) = object [ "basic-auth" .= object [ "realm" .= realm- , "creds" .= object ( map ( (AK.toKey . T.decodeUtf8) *** (String . T.decodeUtf8)) cred )- ]- ]- toJSON (AddHeaders headers) = object [ "headers" .= object ( map ((AK.toKey . T.decodeUtf8) *** String . T.decodeUtf8) headers) ]- toJSON (Local sc msg) = object [ "local" .= object [ "status" .= sc- , "message" .= TL.decodeUtf8 msg- ]- ]-+ toJSON (BasicAuth realm cred) =+ object [ "basic-auth" .= object+ [ "realm" .= realm+ , "creds" .= object+ (map ((AK.toKey . T.decodeUtf8) *** (String . T.decodeUtf8)) cred)+ ] ]+ toJSON (AddHeaders headers) =+ object [ "headers" .= object+ (map ((AK.toKey . T.decodeUtf8) *** String . T.decodeUtf8) headers) ]+ toJSON (Local sc msg) =+ object [ "local" .= object [ "status" .= sc+ , "message" .= TL.decodeUtf8 msg ] ]+ toJSON (RateLimiter rl) = object [ "rate-limiter" .= toJSON rl ] {-- Still missing--- CleanPath+-- Clean path -- Gzip -- RequestLogger -- Rewrite -- Vhost --} -processMiddleware :: [MiddlewareConfig] -> Middleware-processMiddleware = composeMiddleware . map toMiddleware+-- Build middlewares in IO, because the RateLimiter needs mutable state.+processMiddlewareIO :: [MiddlewareConfig] -> IO Middleware+processMiddlewareIO cfgs = do+ mws <- mapM toMiddlewareIO cfgs+ pure (composeMiddleware mws) -toMiddleware :: MiddlewareConfig -> Middleware-toMiddleware AcceptOverride = acceptOverride-toMiddleware Autohead = autohead-toMiddleware Jsonp = jsonp-toMiddleware (Local s c ) = local ( responseLBS (toEnum s) [] c )-toMiddleware MethodOverride = methodOverride-toMiddleware MethodOverridePost = methodOverridePost-toMiddleware (BasicAuth realm cred) = basicAuth (\u p -> return $ (Just p ==) $ lookup u cred ) (fromString realm)-toMiddleware (AddHeaders headers) = addHeaders headers+processMiddleware :: [MiddlewareConfig] -> Middleware+processMiddleware = composeMiddleware . map toMiddlewarePure+ where+ toMiddlewarePure (RateLimiter _) = id+ toMiddlewarePure x = unsafeToMiddleware x --- composeMiddleware : composeMiddleware :: [Middleware] -> Middleware composeMiddleware = foldl (flip (.)) id++unsafeToMiddleware :: MiddlewareConfig -> Middleware+unsafeToMiddleware AcceptOverride = acceptOverride+unsafeToMiddleware Autohead = autohead+unsafeToMiddleware Jsonp = jsonp+unsafeToMiddleware MethodOverride = methodOverride+unsafeToMiddleware MethodOverridePost = methodOverridePost+unsafeToMiddleware (Local s c) = local (responseLBS (toEnum s) [] c)+unsafeToMiddleware (BasicAuth realm cred) =+ basicAuth (\u p -> pure $ (Just p ==) $ lookup u cred) (fromString realm)+unsafeToMiddleware (AddHeaders headers) = addHeaders headers+unsafeToMiddleware (RateLimiter _) = id++toMiddlewareIO :: MiddlewareConfig -> IO Middleware+toMiddlewareIO AcceptOverride = pure acceptOverride+toMiddlewareIO Autohead = pure autohead+toMiddlewareIO Jsonp = pure jsonp+toMiddlewareIO MethodOverride = pure methodOverride+toMiddlewareIO MethodOverridePost = pure methodOverridePost+toMiddlewareIO (Local s c) = pure $ local (responseLBS (toEnum s) [] c)+toMiddlewareIO (BasicAuth realm cred) =+ pure $ basicAuth (\u p -> pure $ (Just p ==) $ lookup u cred) (fromString realm)+toMiddlewareIO (AddHeaders headers) = pure $ addHeaders headers+toMiddlewareIO (RateLimiter rl) = do+ env <- buildEnvFromConfig rl+ pure (buildRateLimiterWithEnv env)
src/Keter/Config/V10.hs view
@@ -36,6 +36,7 @@ import Keter.Config.V04 qualified as V04 import Keter.Rewrite (ReverseProxyConfig) import Keter.Yaml.FilePath+import Network.Wai (Middleware) import Network.Wai.Handler.Warp qualified as Warp import System.FilePath qualified as F import System.Posix.Types (EpochTime)@@ -121,6 +122,8 @@ , kconfigRotateLogs :: !Bool , kconfigHealthcheckPath :: !(Maybe Text)++ , kconfigGracefulDrainMicros :: !(Maybe Int) } instance ToCurrent KeterConfig where@@ -142,6 +145,7 @@ , kconfigProxyException = Nothing , kconfigRotateLogs = True , kconfigHealthcheckPath = Nothing+ , kconfigGracefulDrainMicros = Nothing } where getSSL Nothing = V.empty@@ -171,6 +175,7 @@ , kconfigProxyException = Nothing , kconfigRotateLogs = True , kconfigHealthcheckPath = Nothing+ , kconfigGracefulDrainMicros = Nothing } instance ParseYamlFile KeterConfig where@@ -197,6 +202,7 @@ <*> o .:? "proxy-exception-response-file" <*> o .:? "rotate-logs" .!= True <*> o .:? "app-crash-hook"+ <*> o .:? "graceful-drain-micros" -- | Whether we should force redirect to HTTPS routes. type RequiresSecure = Bool@@ -220,13 +226,30 @@ -- 1. Webapps will be assigned ports. -- -- 2. Not all stanzas have an associated proxy action.+--+-- Now carries set up Wai.Middleware:+-- PAPort: webapp local proxy wrapped with 'Middleware'+-- PAStatic: StaticFilesConfig still holds middleware configs at parse time;+-- we set them up in App and then apply in Proxy.+-- PAReverseProxy: set up middleware baked in. data ProxyActionRaw- = PAPort Port !(Maybe Int)- | PAStatic StaticFilesConfig+ = PAPort Port !Middleware !(Maybe Int)+ | PAStatic StaticFilesConfig !Middleware | PARedirect RedirectConfig- | PAReverseProxy ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int)- deriving Show+ | PAReverseProxy ReverseProxyConfig !Middleware !(Maybe Int) +-- | The manual instance replaces the 'Middleware' values with "<middleware>" +-- in the string representation since the actual middleware functions cannot be shown.+instance Show ProxyActionRaw where+ show (PAPort port _ timeout) = + "PAPort " ++ show port ++ " <middleware> " ++ show timeout+ show (PAStatic config _) = + "PAStatic " ++ show config ++ " <middleware>"+ show (PARedirect config) = + "PARedirect " ++ show config+ show (PAReverseProxy config _ timeout) = + "PAReverseProxy " ++ show config ++ " <middleware> " ++ show timeout+ type ProxyAction = (ProxyActionRaw, RequiresSecure) instance ParseYamlFile (Stanza ()) where@@ -401,6 +424,9 @@ -- | how long in microseconds the app gets before we expect it to bind to -- a port (default 90 seconds) , waconfigEnsureAliveTimeout :: !(Maybe Int)+ -- | stanza-local WAI middlewares applied by Keter (e.g., rate limiter).+ -- Parsed from YAML key "middleware". Default: [].+ , waconfigMiddleware :: ![ MiddlewareConfig ] } deriving Show @@ -417,6 +443,7 @@ , waconfigForwardEnv = Set.empty , waconfigTimeout = Nothing , waconfigEnsureAliveTimeout = Nothing+ , waconfigMiddleware = [] } instance ParseYamlFile (WebAppConfig ()) where@@ -441,6 +468,7 @@ <*> o .:? "forward-env" .!= Set.empty <*> o .:? "connection-time-bound" <*> o .:? "ensure-alive-time-bound"+ <*> o .:? "middleware" .!= [] instance ToJSON (WebAppConfig ()) where toJSON WebAppConfig {..} = object@@ -451,6 +479,8 @@ , "ssl" .= waconfigSsl , "forward-env" .= waconfigForwardEnv , "connection-time-bound" .= waconfigTimeout+ , "ensure-alive-time-bound" .= waconfigEnsureAliveTimeout+ , "middleware" .= waconfigMiddleware ] data AppInput = AIBundle !FilePath !EpochTime
src/Keter/Proxy.hs view
@@ -32,7 +32,6 @@ import GHC.Exts (fromString) import Keter.Common import Keter.Config-import Keter.Config.Middleware import Keter.Context import Keter.HostManager qualified as HostMan import Keter.Rewrite qualified as Rewrite@@ -76,15 +75,16 @@ import WaiAppStatic.Listing (defaultListing) data ProxySettings = MkProxySettings- { -- | Mapping from virtual hostname to port number.- psHostLookup :: ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))- , psManager :: !Manager- , psIpFromHeader :: Bool+ { -- | Mapping from virtual hostname to action, credentials+ psHostLookup :: ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))+ , psManager :: !Manager+ , psIpFromHeader :: Bool+ , psTrustForwardedFor :: Wai.Request -> Bool , psConnectionTimeBound :: Int- , psHealthcheckPath :: !(Maybe ByteString)- , psUnknownHost :: ByteString -> ByteString- , psMissingHost :: ByteString- , psProxyException :: ByteString+ , psHealthcheckPath :: !(Maybe ByteString)+ , psUnknownHost :: ByteString -> ByteString+ , psMissingHost :: ByteString+ , psProxyException :: ByteString } makeSettings :: HostMan.HostManager -> KeterM KeterConfig ProxySettings@@ -99,6 +99,7 @@ let psConnectionTimeBound = kconfigConnectionTimeBound * 1000 let psIpFromHeader = kconfigIpFromHeader let psHealthcheckPath = encodeUtf8 <$> kconfigHealthcheckPath+ let psTrustForwardedFor _req = True pure $ MkProxySettings{..} where psHostLookup = HostMan.lookupAction hostman . CI.mk@@ -135,33 +136,35 @@ connectClientCertificates :: (ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))) -> Bool -> WarpTLS.TLSSettings -> WarpTLS.TLSSettings connectClientCertificates hl session s =- let- newHooks = WarpTLS.tlsServerHooks s- -- todo: add nested lookup- newOnServerNameIndication (Just n) =- maybe mempty snd <$> hl (S8.pack n)- newOnServerNameIndication Nothing =- return mempty -- we could return default certificate here- in- s { WarpTLS.tlsServerHooks = newHooks{TLS.onServerNameIndication = newOnServerNameIndication}- , WarpTLS.tlsSessionManagerConfig = if session then Just TLSSession.defaultConfig else Nothing }+ let+ newHooks = WarpTLS.tlsServerHooks s+ newOnSNI :: Maybe TLS.HostName -> IO TLS.Credentials+ newOnSNI (Just n) = do+ -- Return per-host certificate if available+ mx <- hl (S8.pack n)+ case mx of+ Just ((_, _), creds) -> pure creds+ Nothing -> pure mempty+ newOnSNI Nothing = pure mempty -- we could return default certificate here+ in+ s { WarpTLS.tlsServerHooks = newHooks { TLS.onServerNameIndication = newOnSNI }+ , WarpTLS.tlsSessionManagerConfig = if session then Just TLSSession.defaultConfig else Nothing+ } -withClient :: Bool -- ^ is secure?+withClient :: Bool -- ^ Is the outer listener secure (HTTPS)? -> KeterM ProxySettings Wai.Application withClient isSecure = do cfg@MkProxySettings{..} <- ask- let useHeader = psIpFromHeader+ let honourHeader req = psIpFromHeader && psTrustForwardedFor req withRunInIO $ \rio -> pure $ waiProxyToSettings (error "First argument to waiProxyToSettings forced, even thought wpsGetDest provided") defaultWaiProxySettings- { wpsSetIpHeader =- if useHeader- then SIHFromHeader- else SIHFromSocket- , wpsGetDest = Just (getDest cfg)- , wpsOnExc = handleProxyException (\app e -> rio $ logException app e) psProxyException+ { wpsSetIpHeader = SIHFromSocket -- Default, will be overridden per-request in getDest+ , wpsGetDest = Just (getDest cfg honourHeader)+ , wpsOnExc =+ handleProxyException (\app e -> rio $ logException app e) psProxyException } psManager where logException :: Wai.Request -> SomeException -> KeterM ProxySettings ()@@ -169,36 +172,36 @@ "Got a proxy exception on request " <> show a <> " with exception " <> show b - getDest :: ProxySettings -> Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse)+ getDest :: ProxySettings -> (Wai.Request -> Bool) -> Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse) -- respond to healthckecks, regardless of Host header value and presence- getDest MkProxySettings{..} req | psHealthcheckPath == Just (Wai.rawPathInfo req)+ getDest MkProxySettings{..} _ req+ | psHealthcheckPath == Just (Wai.rawPathInfo req) = return (defaultLocalWaiProxySettings, WPRResponse healthcheckResponse) -- inspect Host header to determine which App to proxy to- getDest cfg@MkProxySettings{..} req =+ getDest cfg@MkProxySettings{..} useHeaderPred req = case Wai.requestHeaderHost req of Nothing -> do return (defaultLocalWaiProxySettings, WPRResponse $ missingHostResponse psMissingHost)- Just host -> processHost cfg req host+ Just host -> processHost cfg useHeaderPred req host - processHost :: ProxySettings -> Wai.Request -> S.ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)- processHost cfg@MkProxySettings{..} req host = do+ processHost :: ProxySettings -> (Wai.Request -> Bool) -> Wai.Request -> S.ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)+ processHost cfg@MkProxySettings{..} useHeaderPred req host = do -- Perform two levels of lookup. First: look up the entire host. If -- that fails, try stripping off any port number and try again.- mport <- liftIO $ do- mport1 <- psHostLookup host- case mport1 of- Just _ -> return mport1- Nothing -> do- let host' = S.takeWhile (/= 58) host- if host' == host- then return Nothing- else psHostLookup host'- case mport of- Nothing -> do -- we don't know the host that was asked for- return (defaultLocalWaiProxySettings, WPRResponse $ unknownHostResponse host (psUnknownHost host))- Just ((action, requiresSecure), _)- | requiresSecure && not isSecure -> performHttpsRedirect cfg host req- | otherwise -> performAction psManager isSecure psConnectionTimeBound req action+ mEntry <- liftIO $ do+ let tryHost h = psHostLookup h+ m1 <- tryHost host+ case m1 of+ Just x -> pure (Just x)+ Nothing -> do+ let host' = S.takeWhile (/= 58) host+ if host' == host then pure Nothing else tryHost host'+ case mEntry of+ Nothing -> do -- we don't know the host that was asked for+ return (defaultLocalWaiProxySettings, WPRResponse $ unknownHostResponse host (psUnknownHost host))+ Just ((action, requiresSecure), _cert)+ | requiresSecure && not isSecure -> performHttpsRedirect cfg host req+ | otherwise -> performAction psManager psProxyException isSecure useHeaderPred psConnectionTimeBound host req action performHttpsRedirect MkProxySettings{..} host = return . (addjustGlobalBound psConnectionTimeBound Nothing,) . WPRResponse . redirectApp config@@ -226,31 +229,56 @@ Just x | x > 0 -> Just x _ -> Nothing +-- | Perform a stanza action, applying previously set up middlewares.+performAction :: Manager+ -> ByteString -- ^ onExceptBody+ -> Bool -- ^ isSecure+ -> (Wai.Request -> Bool) -- ^ should honour XFF?+ -> Int -- ^ global bound (us)+ -> ByteString -- ^ host (unused now; kept for parity)+ -> Wai.Request+ -> ProxyActionRaw+ -> IO (LocalWaiProxySettings, WaiProxyResponse)+performAction psManager onExceptBody isSecure useHeaderPred globalBound _host req = \case+ (PAPort port mw tbound) -> do+ let innerApp :: Wai.Application+ innerApp =+ waiProxyToSettings+ (error "inner default app forced, even though wpsGetDest is provided")+ defaultWaiProxySettings+ { wpsSetIpHeader =+ if useHeaderPred req then SIHFromHeader else SIHFromSocket+ , wpsGetDest = Just $ \r -> do+ let protocol = if isSecure then "https" else "http"+ r' = r { Wai.requestHeaders =+ ("X-Forwarded-Proto", protocol) : Wai.requestHeaders r+ }+ pure (defaultLocalWaiProxySettings, WPRModifiedRequest r' (ProxyDest "127.0.0.1" port))+ , wpsOnExc =+ handleProxyException (\_ _ -> pure ()) onExceptBody+ } psManager+ pure ( addjustGlobalBound globalBound tbound+ , WPRApplication (mw innerApp)+ ) -performAction :: Manager -> Bool -> Int -> Wai.Request -> ProxyActionRaw -> IO (LocalWaiProxySettings, WaiProxyResponse)-performAction psManager isSecure globalBound req = \case- (PAPort port tbound) ->- return (addjustGlobalBound globalBound tbound, WPRModifiedRequest req' $ ProxyDest "127.0.0.1" port)- where- req' = req- { Wai.requestHeaders = ("X-Forwarded-Proto", protocol)- : Wai.requestHeaders req- }- protocol- | isSecure = "https"- | otherwise = "http"- (PAStatic StaticFilesConfig {..}) ->- return (addjustGlobalBound globalBound sfconfigTimeout, WPRApplication $ processMiddleware sfconfigMiddleware $ staticApp (defaultFileServerSettings sfconfigRoot)- { ssListing =- if sfconfigListings- then Just defaultListing- else Nothing- })- (PARedirect config) -> return (addjustGlobalBound globalBound Nothing, WPRResponse $ redirectApp config req)- (PAReverseProxy config rpconfigMiddleware tbound) ->- return (addjustGlobalBound globalBound tbound, WPRApplication- $ processMiddleware rpconfigMiddleware- $ Rewrite.simpleReverseProxy psManager config+ (PAStatic StaticFilesConfig {..} mw) -> do+ let baseApp = staticApp (defaultFileServerSettings sfconfigRoot)+ { ssListing =+ if sfconfigListings+ then Just defaultListing+ else Nothing+ }+ return ( addjustGlobalBound globalBound sfconfigTimeout+ , WPRApplication (mw baseApp)+ )++ (PARedirect config) ->+ return (addjustGlobalBound globalBound Nothing, WPRResponse $ redirectApp config req)++ (PAReverseProxy config mw tbound) -> do+ let baseApp = Rewrite.simpleReverseProxy psManager config+ return ( addjustGlobalBound globalBound tbound+ , WPRApplication (mw baseApp) ) redirectApp :: RedirectConfig -> Wai.Request -> Wai.Response
+ test/Keter/Proxy/MiddlewareSpec.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE TypeApplications #-}++module Keter.Proxy.MiddlewareSpec (tests) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Exception (try)+import Control.Lens ((&), (.~), (^.))+import Control.Monad (void)+import Control.Monad.Logger+import Control.Monad.Reader+import Data.Aeson (eitherDecode)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy.Char8 as LBS+import Keter.Config.Middleware (MiddlewareConfig, processMiddlewareIO)+import Keter.Config.V10+import Keter.Context+import Keter.Proxy+import Network.HTTP.Conduit (Manager)+import qualified Network.HTTP.Conduit as HTTP+import qualified Network.TLS as TLS (Credentials)+import Network.HTTP.Types.Status (ok200, statusCode)+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wreq as Wreq+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "Keter.Proxy integration (middleware smoke tests)"+ [ testCase "Rate-limit via PAPort (FixedWindow, ip-from-header=False)" caseRateLimitFixedWindow+ , testCase "ip-from-header=True uses X-Forwarded-For" caseIpFromHeaderTrue+ , testCase "Healthcheck bypasses middleware" caseHealthcheckBypass+ , testCase "Proxy exception body on backend down" caseProxyExceptionBody+ ]++-- Helpers++startBackend :: Int -> IO ()+startBackend port = void . forkIO $+ Warp.run port $ \req respond -> do+ -- Drain body so HEAD/POST sequences don't leave unread input+ void $ Wai.strictRequestBody req+ respond $ Wai.responseLBS ok200 [] "ok"++runProxyOn :: Manager -> ProxySettings -> Int -> IO ()+runProxyOn _ settings listenPort = void . forkIO $+ flip runReaderT settings $+ flip runLoggingT (\_ _ _ _ -> pure ()) $ -- silence logs in tests+ runKeterM $+ reverseProxy (LPInsecure "*" listenPort)++mkSettings+ :: Manager+ -> (ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))) -- Updated signature+ -> Bool -- ip-from-header+ -> Maybe ByteString -- healthcheck-path+ -> ByteString -- proxy-exception body+ -> IO ProxySettings+mkSettings manager hostLookup useHeader mHealth exBody = do+ pure $ MkProxySettings+ { psHostLookup = hostLookup+ , psManager = manager+ , psTrustForwardedFor = \_ -> True+ , psUnknownHost = const ""+ , psMissingHost = ""+ , psProxyException = exBody+ , psIpFromHeader = useHeader+ , psConnectionTimeBound = 5 * 60 * 1000+ , psHealthcheckPath = mHealth+ }++decodeMids :: LBS.ByteString -> [MiddlewareConfig]+decodeMids lbs =+ case eitherDecode lbs of+ Right xs -> xs+ Left e -> error ("Failed to decode middleware config: " <> e)++-- Test cases++-- 1) Rate-limit via PAPort (FixedWindow)+caseRateLimitFixedWindow :: IO ()+caseRateLimitFixedWindow = do+ let backendPort = 6791+ proxyPort = 6790+ midsJSON = LBS.pack $ concat+ [ "[{ \"rate-limiter\": {"+ , " \"zone_by\":\"default\","+ , " \"throttles\":[{"+ , " \"name\":\"ip\","+ , " \"limit\":2,"+ , " \"period\":60,"+ , " \"algorithm\":\"FixedWindow\","+ , " \"identifier_by\":\"ip\""+ , " }]"+ , "}}]"+ ]+ mids = decodeMids midsJSON++ _ <- forkIO $ startBackend backendPort+ manager <- HTTP.newManager HTTP.tlsManagerSettings++ -- Compile middleware at setup time (like App.hs does)+ compiledMW <- processMiddlewareIO mids++ let host = "rl.test"+ let hostLookup :: ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))+ hostLookup _ =+ -- PAPort now contains compiled middleware+ return $ Just ((PAPort backendPort compiledMW Nothing, False), mempty)++ settings <- mkSettings manager hostLookup False Nothing "proxy error"+ runProxyOn manager settings proxyPort+ threadDelay 200_000++ let base = "http://127.0.0.1:" <> show proxyPort <> "/"+ req = Wreq.defaults & Wreq.header "Host" .~ [host]+ r1 <- Wreq.getWith req base+ r2 <- Wreq.getWith req base+ -- For the third request, we expect a 429, so we need to handle the exception+ r3Result <- try $ Wreq.getWith req base++ r1 ^. Wreq.responseStatus . Wreq.statusCode @?= 200+ r2 ^. Wreq.responseStatus . Wreq.statusCode @?= 200++ case r3Result of+ Left (HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException resp _)) ->+ statusCode (HTTP.responseStatus resp) @?= 429+ Left e -> assertFailure $ "Unexpected exception: " <> show e+ Right r3 -> r3 ^. Wreq.responseStatus . Wreq.statusCode @?= 429++-- 2) ip-from-header=True: X-Forwarded-For identifies client+caseIpFromHeaderTrue :: IO ()+caseIpFromHeaderTrue = do+ let backendPort = 6793+ proxyPort = 6792+ midsJSON = LBS.pack $ concat+ [ "[{ \"rate-limiter\": {"+ , " \"zone_by\":\"default\","+ , " \"throttles\":[{"+ , " \"name\":\"ip\","+ , " \"limit\":1,"+ , " \"period\":60,"+ , " \"algorithm\":\"FixedWindow\","+ , " \"identifier_by\":\"ip\""+ , " }]"+ , "}}]"+ ]+ mids = decodeMids midsJSON++ _ <- forkIO $ startBackend backendPort+ manager <- HTTP.newManager HTTP.tlsManagerSettings+ + compiledMW <- processMiddlewareIO mids++ let host = "xff.test"+ let hostLookup _ = return $ Just ((PAPort backendPort compiledMW Nothing, False), mempty)+ settings <- mkSettings manager hostLookup True Nothing "proxy error"+ runProxyOn manager settings proxyPort+ threadDelay 200_000++ let base = "http://127.0.0.1:" <> show proxyPort <> "/"+ req xff =+ Wreq.defaults+ & Wreq.header "Host" .~ [host]+ & Wreq.header "X-Forwarded-For" .~ [xff]++ r1 <- Wreq.getWith (req "1.1.1.1") base+ -- For the second request, we expect a 429, so we need to handle the exception+ r2Result <- try $ Wreq.getWith (req "1.1.1.1") base+ r3 <- Wreq.getWith (req "2.2.2.2") base++ r1 ^. Wreq.responseStatus . Wreq.statusCode @?= 200++ case r2Result of+ Left (HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException resp _)) ->+ statusCode (HTTP.responseStatus resp) @?= 429+ Left e -> assertFailure $ "Unexpected exception: " <> show e+ Right r2 -> r2 ^. Wreq.responseStatus . Wreq.statusCode @?= 429++ r3 ^. Wreq.responseStatus . Wreq.statusCode @?= 200++-- 3) Healthcheck bypass+caseHealthcheckBypass :: IO ()+caseHealthcheckBypass = do+ let backendPort = 6795+ proxyPort = 6794+ _ <- forkIO $ startBackend backendPort+ manager <- HTTP.newManager HTTP.tlsManagerSettings+ + -- No middleware for this test - use id middleware+ idMW <- processMiddlewareIO []++ let host = "hc.test"+ let hostLookup _ = return $ Just ((PAPort backendPort idMW Nothing, False), mempty)+ settings <- mkSettings manager hostLookup False (Just "/keter-health") "proxy error"++ runProxyOn manager settings proxyPort+ threadDelay 200_000++ let base = "http://127.0.0.1:" <> show proxyPort <> "/keter-health"+ req = Wreq.defaults & Wreq.header "Host" .~ [host]+ r <- Wreq.getWith req base+ r ^. Wreq.responseStatus . Wreq.statusCode @?= 200++-- 4) Proxy exception body when backend is down+caseProxyExceptionBody :: IO ()+caseProxyExceptionBody = do+ let proxyPort = 6796+ manager <- HTTP.newManager HTTP.tlsManagerSettings++ -- No middleware for this test+ idMW <- processMiddlewareIO []++ let host = "down.test"+ exBody = "my branded proxy error"+ let hostLookup _ = return $ Just ((PAPort 59999 idMW Nothing, False), mempty) -- no backend here++ settings <- mkSettings manager hostLookup False Nothing exBody+ runProxyOn manager settings proxyPort+ threadDelay 200_000++ let base = "http://127.0.0.1:" <> show proxyPort <> "/"+ req = Wreq.defaults & Wreq.header "Host" .~ [host]+ -- We expect a 502, so we need to handle the exception+ rResult <- try $ Wreq.getWith req base++ case rResult of+ Left (HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException resp _)) ->+ statusCode (HTTP.responseStatus resp) @?= 502+ Left e -> assertFailure $ "Unexpected exception: " <> show e+ Right r -> r ^. Wreq.responseStatus . Wreq.statusCode @?= 502
test/Spec.hs view
@@ -23,6 +23,7 @@ import Network.Wreq qualified as Wreq import Test.Tasty import Test.Tasty.HUnit+import qualified Keter.Proxy.MiddlewareSpec as ProxyMW main :: IO () main = defaultMain keterTests@@ -34,6 +35,7 @@ [ testCase "Subdomain Integrity" caseSubdomainIntegrity , testCase "Wildcard Domains" caseWildcards , testCase "Head then post doesn't crash" headThenPostNoCrash+ , ProxyMW.tests ] caseSubdomainIntegrity :: IO ()@@ -64,8 +66,10 @@ void $ Wai.strictRequestBody req resp $ Wai.responseLBS ok200 [] "ok" + settings' <- settings manager -- Now use <- since settings returns IO+ _ <- forkIO $- flip runReaderT (settings manager) $+ flip runReaderT settings' $ flip runLoggingT (\_ _ _ msg -> atomically $ writeTQueue exceptions msg) $ filterLogger isException $ runKeterM $@@ -88,14 +92,16 @@ isException _ LevelError = True isException _ _ = False - settings :: Manager -> ProxySettings- settings manager = MkProxySettings {- psHostLookup = const $ pure $ Just ((PAPort 6781 Nothing, False), error "unused tls certificate")- , psManager = manager- , psUnknownHost = const ""- , psMissingHost = ""- , psProxyException = ""- , psIpFromHeader = False- , psConnectionTimeBound = 5 * 60 * 1000- , psHealthcheckPath = Nothing- }+ settings :: Manager -> IO ProxySettings -- Now returns IO ProxySettings+ settings manager = do+ -- Remove MiddlewareCache usage - middlewares are now compiled at activation+ pure $ MkProxySettings {+ psHostLookup = const $ pure $ Just ((PAPort 6781 id Nothing, False), error "unused tls certificate")+ , psManager = manager+ , psUnknownHost = const ""+ , psMissingHost = ""+ , psProxyException = ""+ , psIpFromHeader = False+ , psConnectionTimeBound = 5 * 60 * 1000+ , psHealthcheckPath = Nothing+ }