diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,20 @@ # Changelog +## 2.3.2 + +- Bump `tls` upper bound from `<2.2` to `<2.4` to allow tls 2.2.x and 2.3.x. +- Bump `tls-session-manager` to allow `^>=0.1.0` (needed for tls 2.3.x support). + +## 2.3.1 + +- Add `port-env-vars` option for webapp stanzas. Allows specifying additional + environment variable names (e.g., `YESOD_PORT`) that receive the same + port value as `PORT`. This avoids the need to change app configuration + when deploying with Keter. +- Add `preserve-host` option for reverse proxy stanzas. When set to `true`, + preserves the original `Host` header when proxying requests. + [299](https://github.com/snoyberg/keter/issues/299) + ## 2.3.0 - Add integration with keter-rate-limiting-plugin. [301](https://github.com/snoyberg/keter/issues/301), thanks @Oleksandr-Zhabenko diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -59,6 +59,21 @@ variable in `config/settings.yaml` from `YESOD_PORT` to `PORT` for compatibility with Keter. + Alternatively, you can use `port-env-vars` in your `config/keter.yaml` to + have Keter set the port under additional environment variable names: + + ```yaml + stanzas: + - type: webapp + exec: ../dist/bin/myapp + host: www.example.com + port-env-vars: + - YESOD_PORT + ``` + + With this configuration, both `PORT` and `YESOD_PORT` will be set to + the same Keter-assigned port, so you don't need to modify your app. + 2. Create a file `config/keter.yaml`. The minimal file just has two settings: ```yaml 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.3.0 +version: 2.3.2 synopsis: Web application deployment manager, focusing on Haskell web frameworks. It mitigates downtime. @@ -62,8 +62,8 @@ , template-haskell >=2.17.0 && <3.0 , text >=1.2.5 && <3.0 , time >=1.9.3 && <2.0 - , tls >=1.5.7 && <2.2 - , tls-session-manager >=0.0.4 && <0.1 + , tls >=1.5.7 && <2.4 + , tls-session-manager >=0.0.4 && <0.1 || ^>=0.1.0 , transformers >=0.5.6 && <0.7 , unix >=2.7.2 && <2.9 , unix-compat >=0.3 && <0.8 @@ -132,12 +132,15 @@ hs-source-dirs: test default-extensions: ImportQualifiedPost main-is: Spec.hs - other-modules: Keter.Proxy.MiddlewareSpec + other-modules: Keter.Config.V10Spec + , Keter.Proxy.MiddlewareSpec + , Keter.RewriteSpec type: exitcode-stdio-1.0 build-depends: , aeson , base , bytestring + , containers , conduit , http-client , http-conduit @@ -151,6 +154,7 @@ , stm , tasty , tasty-hunit + , temporary , tls , transformers , unix @@ -158,6 +162,7 @@ , wai , warp , wreq + , yaml ghc-options: -Wall -threaded diff --git a/src/Keter/App.hs b/src/Keter/App.hs --- a/src/Keter/App.hs +++ b/src/Keter/App.hs @@ -294,6 +294,7 @@ if waconfigSsl == SSLFalse then ("http://", if httpPort == 80 then "" else ':' : show httpPort) else ("https://", if httpsPort == 443 then "" else ':' : show httpsPort) + portText = pack $ show waconfigPort env = Map.toList $ Map.unions -- Ordering chosen specifically to precedence rules: app specific, -- plugins, global, and then auto-set Keter variables. @@ -301,7 +302,7 @@ , forwardedEnv , Map.fromList otherEnv , kconfigEnvironment ascKeterConfig - , Map.singleton "PORT" $ pack $ show waconfigPort + , Map.fromList $ map (, portText) ("PORT" : Set.toList waconfigPortEnvVars) , Map.singleton "APPROOT" $ scheme <> CI.original waconfigApprootHost <> pack extport ] exec <- liftIO $ canonicalizePath waconfigExec @@ -327,11 +328,13 @@ AIBuiltin -> "__builtin__" AINamed x -> x -killWebApp :: RunningWebApp -> KeterM cfg () +killWebApp :: RunningWebApp -> KeterM AppStartConfig () killWebApp RunningWebApp {..} = do + AppStartConfig{..} <- ask status <- liftIO $ printStatus rwaProcess $logInfo $ pack $ "Killing " <> unpack status <> " running on port: " <> show rwaPort liftIO $ terminateMonitoredProcess rwaProcess + liftIO $ releasePort ascPortPool rwaPort ensureAlive :: TVar AppState -> RunningWebApp -> IO () ensureAlive tstate RunningWebApp {..} = do @@ -341,7 +344,8 @@ else error $ "ensureAlive failed, this means keter couldn't " <> "detect your app at port " <> show rwaPort <> ", check your app logs detailed errors. " <> - " Also make sure your app binds to the PORT environment variable (not YESOD_PORT for example)." -- TODO domain name would be good to add as well + " Also make sure your app binds to the PORT environment variable" <> + " (or use port-env-vars in keter.yaml to set additional env var names like YESOD_PORT)." where testApp :: Port -> IO Bool testApp port = do 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 @@ -427,6 +427,10 @@ -- | stanza-local WAI middlewares applied by Keter (e.g., rate limiter). -- Parsed from YAML key "middleware". Default: []. , waconfigMiddleware :: ![ MiddlewareConfig ] + -- | Extra environment variable names that should also receive the + -- assigned port value (in addition to @PORT@). + -- Parsed from YAML key "port-env-vars". Default: empty. + , waconfigPortEnvVars :: !(Set Text) } deriving Show @@ -444,6 +448,7 @@ , waconfigTimeout = Nothing , waconfigEnsureAliveTimeout = Nothing , waconfigMiddleware = [] + , waconfigPortEnvVars = Set.empty } instance ParseYamlFile (WebAppConfig ()) where @@ -469,6 +474,7 @@ <*> o .:? "connection-time-bound" <*> o .:? "ensure-alive-time-bound" <*> o .:? "middleware" .!= [] + <*> o .:? "port-env-vars" .!= Set.empty instance ToJSON (WebAppConfig ()) where toJSON WebAppConfig {..} = object @@ -481,6 +487,7 @@ , "connection-time-bound" .= waconfigTimeout , "ensure-alive-time-bound" .= waconfigEnsureAliveTimeout , "middleware" .= waconfigMiddleware + , "port-env-vars" .= waconfigPortEnvVars ] data AppInput = AIBundle !FilePath !EpochTime diff --git a/src/Keter/Rewrite.hs b/src/Keter/Rewrite.hs --- a/src/Keter/Rewrite.hs +++ b/src/Keter/Rewrite.hs @@ -6,6 +6,7 @@ , RewriteRule (..) , RPEntry (..) , simpleReverseProxy + , filterHeaders ) where @@ -94,12 +95,12 @@ strInput = T.unpack . decodeUtf8 $ input strReplacement = T.unpack replacement -filterHeaders :: [Header] -> [Header] -filterHeaders = filter useHeader +filterHeaders :: Bool -> [Header] -> [Header] +filterHeaders preserveHost = filter useHeader where useHeader ("Transfer-Encoding", _) = False useHeader ("Content-Length", _) = False - useHeader ("Host", _) = False + useHeader ("Host", _) = preserveHost useHeader _ = True mkRuleMap :: Set RewriteRule -> Map HeaderName RewriteRule @@ -116,7 +117,7 @@ , port = reversedPort rpConfig , path = Wai.rawPathInfo request , queryString = Wai.rawQueryString request - , requestHeaders = filterHeaders $ rewriteHeaders reqRuleMap (Wai.requestHeaders request) + , requestHeaders = filterHeaders (reversePreserveHost rpConfig) $ rewriteHeaders reqRuleMap (Wai.requestHeaders request) , requestBody = case Wai.requestBodyLength request of Wai.ChunkedBody -> RequestBodyStreamChunked ($ I.getRequestBodyChunk request) @@ -155,6 +156,7 @@ , reverseTimeout :: Maybe Int , rewriteResponseRules :: Set RewriteRule , rewriteRequestRules :: Set RewriteRule + , reversePreserveHost :: Bool } deriving (Eq, Ord, Show) instance FromJSON ReverseProxyConfig where @@ -167,6 +169,7 @@ <*> o .:? "timeout" .!= Nothing <*> o .:? "rewrite-response" .!= Set.empty <*> o .:? "rewrite-request" .!= Set.empty + <*> o .:? "preserve-host" .!= False parseJSON _ = fail "Wanted an object" instance ToJSON ReverseProxyConfig where @@ -179,6 +182,7 @@ , "timeout" .= reverseTimeout , "rewrite-response" .= rewriteResponseRules , "rewrite-request" .= rewriteRequestRules + , "preserve-host" .= reversePreserveHost ] data RewriteRule = RewriteRule diff --git a/test/Keter/Config/V10Spec.hs b/test/Keter/Config/V10Spec.hs new file mode 100644 --- /dev/null +++ b/test/Keter/Config/V10Spec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Keter.Config.V10Spec (tests) where + +import Data.ByteString.Char8 qualified as BS +import Data.Set qualified as Set +import Keter.Config.V10 +import Keter.Yaml.FilePath (decodeFileRelative) +import System.IO (hClose) +import System.IO.Temp (withSystemTempFile) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "Keter.Config.V10 (WebAppConfig parsing)" + [ testCase "port-env-vars parses a list of variable names" casePortEnvVarsList + , testCase "port-env-vars defaults to empty when omitted" casePortEnvVarsDefault + , testCase "port-env-vars parses empty list" casePortEnvVarsEmpty + ] + +-- | Helper: write YAML bytes to a temp file, then parse as a 'WebAppConfig'. +parseWebAppConfig :: BS.ByteString -> IO (WebAppConfig ()) +parseWebAppConfig yaml = + withSystemTempFile "keter-test-.yaml" $ \fp h -> do + BS.hPut h yaml + hClose h + result <- decodeFileRelative fp + case result of + Left err -> assertFailure ("Failed to parse: " <> show err) >> error "unreachable" + Right wac -> return wac + +casePortEnvVarsList :: IO () +casePortEnvVarsList = do + wac <- parseWebAppConfig $ BS.unlines + [ "exec: /tmp/myapp" + , "host: example.com" + , "port-env-vars:" + , " - YESOD_PORT" + , " - RAILS_PORT" + ] + waconfigPortEnvVars wac @?= Set.fromList ["YESOD_PORT", "RAILS_PORT"] + +casePortEnvVarsDefault :: IO () +casePortEnvVarsDefault = do + wac <- parseWebAppConfig $ BS.unlines + [ "exec: /tmp/myapp" + , "host: example.com" + ] + waconfigPortEnvVars wac @?= Set.empty + +casePortEnvVarsEmpty :: IO () +casePortEnvVarsEmpty = do + wac <- parseWebAppConfig $ BS.unlines + [ "exec: /tmp/myapp" + , "host: example.com" + , "port-env-vars: []" + ] + waconfigPortEnvVars wac @?= Set.empty diff --git a/test/Keter/RewriteSpec.hs b/test/Keter/RewriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keter/RewriteSpec.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Keter.RewriteSpec (tests) where + +import Data.Aeson (eitherDecodeStrict) +import Data.ByteString.Char8 qualified as BS +import Test.Tasty +import Test.Tasty.HUnit +import Keter.Rewrite + +tests :: TestTree +tests = testGroup "Keter.Rewrite" + [ testGroup "ReverseProxyConfig parsing" + [ testCase "preserve-host defaults to False when omitted" casePreserveHostDefault + , testCase "preserve-host parses True" casePreserveHostTrue + , testCase "preserve-host parses False explicitly" casePreserveHostFalse + ] + , testGroup "filterHeaders" + [ testCase "strips Host header when preserveHost is False" caseFilterHeadersStripsHost + , testCase "preserves Host header when preserveHost is True" caseFilterHeadersPreservesHost + , testCase "always strips Transfer-Encoding" caseFilterHeadersStripsTransferEncoding + , testCase "always strips Content-Length" caseFilterHeadersStripsContentLength + , testCase "preserves other headers" caseFilterHeadersPreservesOthers + ] + ] + +-- | Helper to parse ReverseProxyConfig from JSON/YAML bytes +parseReverseProxyConfig :: BS.ByteString -> Either String ReverseProxyConfig +parseReverseProxyConfig = eitherDecodeStrict + +-- Config parsing tests + +casePreserveHostDefault :: IO () +casePreserveHostDefault = do + let json = BS.unlines + [ "{" + , " \"reversed-host\": \"localhost\"," + , " \"reversed-port\": 3000," + , " \"reversed-ssl\": false," + , " \"reversing-host\": \"example.com\"" + , "}" + ] + case parseReverseProxyConfig json of + Left err -> assertFailure ("Failed to parse: " <> err) + Right cfg -> reversePreserveHost cfg @?= False + +casePreserveHostTrue :: IO () +casePreserveHostTrue = do + let json = BS.unlines + [ "{" + , " \"reversed-host\": \"localhost\"," + , " \"reversed-port\": 3000," + , " \"reversed-ssl\": false," + , " \"reversing-host\": \"example.com\"," + , " \"preserve-host\": true" + , "}" + ] + case parseReverseProxyConfig json of + Left err -> assertFailure ("Failed to parse: " <> err) + Right cfg -> reversePreserveHost cfg @?= True + +casePreserveHostFalse :: IO () +casePreserveHostFalse = do + let json = BS.unlines + [ "{" + , " \"reversed-host\": \"localhost\"," + , " \"reversed-port\": 3000," + , " \"reversed-ssl\": false," + , " \"reversing-host\": \"example.com\"," + , " \"preserve-host\": false" + , "}" + ] + case parseReverseProxyConfig json of + Left err -> assertFailure ("Failed to parse: " <> err) + Right cfg -> reversePreserveHost cfg @?= False + +-- filterHeaders tests + +caseFilterHeadersStripsHost :: IO () +caseFilterHeadersStripsHost = do + let headers = [("Host", "example.com"), ("Accept", "text/html")] + result = filterHeaders False headers + result @?= [("Accept", "text/html")] + +caseFilterHeadersPreservesHost :: IO () +caseFilterHeadersPreservesHost = do + let headers = [("Host", "example.com"), ("Accept", "text/html")] + result = filterHeaders True headers + result @?= [("Host", "example.com"), ("Accept", "text/html")] + +caseFilterHeadersStripsTransferEncoding :: IO () +caseFilterHeadersStripsTransferEncoding = do + let headers = [("Transfer-Encoding", "chunked"), ("Accept", "text/html")] + -- Should be stripped regardless of preserveHost + filterHeaders False headers @?= [("Accept", "text/html")] + filterHeaders True headers @?= [("Accept", "text/html")] + +caseFilterHeadersStripsContentLength :: IO () +caseFilterHeadersStripsContentLength = do + let headers = [("Content-Length", "123"), ("Accept", "text/html")] + -- Should be stripped regardless of preserveHost + filterHeaders False headers @?= [("Accept", "text/html")] + filterHeaders True headers @?= [("Accept", "text/html")] + +caseFilterHeadersPreservesOthers :: IO () +caseFilterHeadersPreservesOthers = do + let headers = [("Accept", "text/html"), ("User-Agent", "test"), ("X-Custom", "value")] + result = filterHeaders False headers + result @?= headers diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -23,7 +23,9 @@ import Network.Wreq qualified as Wreq import Test.Tasty import Test.Tasty.HUnit +import qualified Keter.Config.V10Spec as V10 import qualified Keter.Proxy.MiddlewareSpec as ProxyMW +import qualified Keter.RewriteSpec as Rewrite main :: IO () main = defaultMain keterTests @@ -36,6 +38,8 @@ , testCase "Wildcard Domains" caseWildcards , testCase "Head then post doesn't crash" headThenPostNoCrash , ProxyMW.tests + , V10.tests + , Rewrite.tests ] caseSubdomainIntegrity :: IO ()