diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -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 diff --git a/src/Keter/App.hs b/src/Keter/App.hs --- a/src/Keter/App.hs +++ b/src/Keter/App.hs @@ -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" } diff --git a/src/Keter/AppManager.hs b/src/Keter/AppManager.hs --- a/src/Keter/AppManager.hs +++ b/src/Keter/AppManager.hs @@ -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 diff --git a/src/Keter/Config/Middleware.hs b/src/Keter/Config/Middleware.hs --- a/src/Keter/Config/Middleware.hs +++ b/src/Keter/Config/Middleware.hs @@ -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) diff --git a/src/Keter/Config/V10.hs b/src/Keter/Config/V10.hs --- a/src/Keter/Config/V10.hs +++ b/src/Keter/Config/V10.hs @@ -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 "" +-- in the string representation since the actual middleware functions cannot be shown. +instance Show ProxyActionRaw where + show (PAPort port _ timeout) = + "PAPort " ++ show port ++ " " ++ show timeout + show (PAStatic config _) = + "PAStatic " ++ show config ++ " " + show (PARedirect config) = + "PARedirect " ++ show config + show (PAReverseProxy config _ timeout) = + "PAReverseProxy " ++ show config ++ " " ++ 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 diff --git a/src/Keter/Proxy.hs b/src/Keter/Proxy.hs --- a/src/Keter/Proxy.hs +++ b/src/Keter/Proxy.hs @@ -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 diff --git a/test/Keter/Proxy/MiddlewareSpec.hs b/test/Keter/Proxy/MiddlewareSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keter/Proxy/MiddlewareSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 + }