From 35d8fa478670c417ab8b9fe0e6f06c69ff1dad4c Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Fri, 13 May 2022 12:36:12 -0400 Subject: [PATCH 1/2] Force usage of http-reverse-proxy above 0.6.0.1 This prevents a DoS attack by using a head followed by a post. There is a test to confirm this on keter as well. This includes several internal changes as well, such as Getting rid of HMState alias, and remove perform action & adjustbound from withclient where block chop up the withclient function to make it easier to understand, alsom makes the flow of bound values more explicit in type signatures. --- ChangeLog.md | 5 +++ keter.cabal | 12 +++++- nix/pkgs.nix | 8 +++- shell.nix | 1 + src/Keter/HostManager.hs | 8 ++-- src/Keter/Proxy.hs | 89 ++++++++++++++++++++++------------------ test/Spec.hs | 67 ++++++++++++++++++++++++++---- 7 files changed, 134 insertions(+), 56 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index ab5433f..9fa675b 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 2.0.1 + ++ Force usage of http-reverse-proxy versions above 0.6.0.1. + This prevents a DoS attack on a head request followed by a post. + ## 2.0 + Improve missing sudo error messages in postgres plugin. diff --git a/keter.cabal b/keter.cabal index fa7f562..199b2cc 100644 --- a/keter.cabal +++ b/keter.cabal @@ -1,6 +1,6 @@ Cabal-version: >=1.10 Name: keter -Version: 2.0 +Version: 2.0.1 Synopsis: Web application deployment manager, focusing on Haskell web frameworks Description: Deployment system for web applications, originally intended for hosting Yesod @@ -52,7 +52,7 @@ Library , unix-compat >= 0.3 && < 0.6 , conduit >= 1.1 , conduit-extra >= 1.1 - , http-reverse-proxy >= 0.4.2 && < 0.7 + , http-reverse-proxy >= 0.6.0.1 && < 0.7 , unix >= 2.5 , wai-app-static >= 3.1 && < 3.2 , wai >= 3.2.2 @@ -131,6 +131,14 @@ test-suite test , tasty-hunit , keter , HUnit + , wreq + , lens + , stm + , http-conduit + , wai + , warp + , http-types + , http-client ghc-options: -Wall -threaded source-repository head diff --git a/nix/pkgs.nix b/nix/pkgs.nix index a4435ed..0d42f26 100644 --- a/nix/pkgs.nix +++ b/nix/pkgs.nix @@ -6,7 +6,13 @@ import ./pin.nix { haskell = pkgs.lib.recursiveUpdate pkgs.haskell { packageOverrides = hpNew: hpOld: { keter = hpNew.callPackage ../default.nix {}; - }; + + http-reverse-proxy = hpNew.callHackageDirect { + pkg = "http-reverse-proxy"; + ver = "0.6.0.1"; + sha256 = "09z9swznhzxb97ns8hnyjssm91ngsi4bvlqy6bmphqhj9c1m345x"; + } {}; + }; }; }; }; diff --git a/shell.nix b/shell.nix index 0368cc9..703dc5e 100644 --- a/shell.nix +++ b/shell.nix @@ -11,5 +11,6 @@ pkgs.haskellPackages.shellFor { }; buildInputs = [ pkgs.cabal-install + pkgs.haskellPackages.hasktags ]; } diff --git a/src/Keter/HostManager.hs b/src/Keter/HostManager.hs index 9e72b3f..0d7db73 100644 --- a/src/Keter/HostManager.hs +++ b/src/Keter/HostManager.hs @@ -34,12 +34,10 @@ import System.FilePath (FilePath) import Data.Set (Set) import Data.Map (Map) -type HMState = LabelMap HostValue - data HostValue = HVActive !AppId !ProxyAction !TLS.Credentials | HVReserved !AppId -newtype HostManager = HostManager (IORef HMState) +newtype HostManager = HostManager (IORef (LabelMap HostValue)) type Reservations = Set.Set Host @@ -125,7 +123,7 @@ activateApp log (HostManager mstate) app actions = do atomicModifyIORef mstate $ \state0 -> (activateHelper app state0 actions, ()) -activateHelper :: AppId -> HMState -> Map Host (ProxyAction, TLS.Credentials) -> HMState +activateHelper :: AppId -> LabelMap HostValue -> Map Host (ProxyAction, TLS.Credentials) -> LabelMap HostValue activateHelper app = Map.foldrWithKey activate where @@ -149,7 +147,7 @@ deactivateApp log (HostManager mstate) app hosts = do atomicModifyIORef mstate $ \state0 -> (deactivateHelper app state0 hosts, ()) -deactivateHelper :: AppId -> HMState -> Set Host -> HMState +deactivateHelper :: AppId -> LabelMap HostValue -> Set Host -> LabelMap HostValue deactivateHelper app = Set.foldr deactivate where diff --git a/src/Keter/Proxy.hs b/src/Keter/Proxy.hs index 432abc5..294dc75 100644 --- a/src/Keter/Proxy.hs +++ b/src/Keter/Proxy.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE CPP #-} -- | A light-weight, minimalistic reverse HTTP proxy. module Keter.Proxy @@ -81,7 +82,8 @@ data ProxySettings = MkProxySettings { -- | Mapping from virtual hostname to port number. psHostLookup :: ByteString -> IO (Maybe (ProxyAction, TLS.Credentials)) , psManager :: !Manager - , psConfig :: !KeterConfig + , psIpFromHeader :: Bool + , psConnectionTimeBound :: Int , psUnkownHost :: ByteString -> ByteString , psMissingHost :: ByteString , psProxyException :: ByteString @@ -89,7 +91,7 @@ data ProxySettings = MkProxySettings } makeSettings :: (LogMessage -> IO ()) -> KeterConfig -> HostMan.HostManager -> IO ProxySettings -makeSettings log psConfig@KeterConfig {..} hostman = do +makeSettings log KeterConfig {..} hostman = do psManager <- HTTP.newManager HTTP.tlsManagerSettings psMissingHost <- case kconfigMissingHostResponse of Nothing -> pure defaultMissingHostBody @@ -105,6 +107,11 @@ makeSettings log psConfig@KeterConfig {..} hostman = do psLogException a b = log $ ProxyException a b psHostLookup = HostMan.lookupAction hostman . CI.mk + -- | calculate the number of microseconds since the + -- configuration option is in milliseconds + psConnectionTimeBound = kconfigConnectionTimeBound * 1000 + psIpFromHeader = kconfigIpFromHeader + taggedReadFile :: String -> FilePath -> IO ByteString taggedReadFile tag file = do isExist <- Dir.doesFileExist file @@ -158,30 +165,10 @@ withClient isSecure MkProxySettings {..} = } psManager where useHeader :: Bool - useHeader = kconfigIpFromHeader psConfig + useHeader = psIpFromHeader - -- calculate the number of microseconds since the - -- configuration option is in milliseconds bound :: Int - bound = kconfigConnectionTimeBound psConfig * 1000 - protocol - | isSecure = "https" - | otherwise = "http" - - -- FIXME This is a workaround for - -- https://github.com/snoyberg/keter/issues/29. After some research, it - -- seems like Warp is behaving properly here. I'm still not certain why the - -- http call (from http-conduit) inside waiProxyToSettings could ever block - -- infinitely without the server it's connecting to going down, so that - -- requires more research. Meanwhile, this prevents the file descriptor - -- leak from occurring. - - addjustGlobalBound :: Maybe Int -> LocalWaiProxySettings - addjustGlobalBound to = go `setLpsTimeBound` defaultLocalWaiProxySettings - where - go = case to <|> Just bound of - Just x | x > 0 -> Just x - _ -> Nothing + bound = psConnectionTimeBound getDest :: Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse) getDest req = @@ -204,14 +191,14 @@ withClient isSecure MkProxySettings {..} = then return Nothing else psHostLookup host' case mport of - Nothing -> do + Nothing -> do -- we don't know the host that was asked for return (defaultLocalWaiProxySettings, WPRResponse $ unknownHostResponse host (psUnkownHost host)) Just ((action, requiresSecure), _) | requiresSecure && not isSecure -> performHttpsRedirect host req - | otherwise -> performAction req action + | otherwise -> performAction psManager isSecure bound req action performHttpsRedirect host = - return . (addjustGlobalBound Nothing,) . WPRResponse . redirectApp config + return . (addjustGlobalBound bound Nothing,) . WPRResponse . redirectApp config where host' = CI.mk $ decodeUtf8With lenientDecode host config = RedirectConfig @@ -222,23 +209,43 @@ withClient isSecure MkProxySettings {..} = , redirconfigSsl = SSLTrue } - performAction req (PAPort port tbound) = - return (addjustGlobalBound tbound, WPRModifiedRequest req' $ ProxyDest "127.0.0.1" port) +-- FIXME This is a workaround for +-- https://github.com/snoyberg/keter/issues/29. After some research, it +-- seems like Warp is behaving properly here. I'm still not certain why the +-- http call (from http-conduit) inside waiProxyToSettings could ever block +-- infinitely without the server it's connecting to going down, so that +-- requires more research. Meanwhile, this prevents the file descriptor +-- leak from occurring. +addjustGlobalBound :: Int -> Maybe Int -> LocalWaiProxySettings +addjustGlobalBound bound to = go `setLpsTimeBound` defaultLocalWaiProxySettings + where + go = case to <|> Just bound of + Just x | x > 0 -> Just x + _ -> Nothing + + +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 + : Wai.requestHeaders req } - performAction _ (PAStatic StaticFilesConfig {..}) = - return (addjustGlobalBound sfconfigTimeout, WPRApplication $ processMiddleware sfconfigMiddleware $ staticApp (defaultFileServerSettings sfconfigRoot) - { ssListing = - if sfconfigListings - then Just defaultListing - else Nothing - }) - performAction req (PARedirect config) = return (addjustGlobalBound Nothing, WPRResponse $ redirectApp config req) - performAction _ (PAReverseProxy config rpconfigMiddleware tbound) = - return (addjustGlobalBound tbound, WPRApplication + 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 ) @@ -295,6 +302,7 @@ defaultProxyException = "\nWelcome to Keter</t defaultMissingHostBody :: ByteString defaultMissingHostBody = "<!DOCTYPE html>\n<html><head><title>Welcome to Keter

Welcome to Keter

You did not provide a virtual hostname for this request.

" +-- | Error, no host found in the header missingHostResponse :: ByteString -> Wai.Response missingHostResponse missingHost = Wai.responseBuilder status502 @@ -306,6 +314,7 @@ defaultUnknownHostBody host = "\nWelcome to Keter

Welcome to Keter

The hostname you have provided, " <> escapeHtml host <> ", is not recognized.

" +-- | We found a host in the header, but we don't know about the host asked for. unknownHostResponse :: ByteString -> ByteString -> Wai.Response unknownHostResponse host body = Wai.responseBuilder status404 diff --git a/test/Spec.hs b/test/Spec.hs index 68f3ef4..7ec0e38 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,11 +2,27 @@ module Main where -import Data.List (sort) +import Network.HTTP.Client (defaultManagerSettings, managerResponseTimeout) +import Network.HTTP.Types.Status(ok200) +import qualified Network.Wai.Handler.Warp as Warp +import Keter.Config.V10 +import Control.Concurrent (forkIO) import Data.Maybe (isJust) import Keter.LabelMap as LM import Test.Tasty import Test.Tasty.HUnit +import Control.Monad +import Control.Exception (SomeException) +import Network.HTTP.Conduit (Manager) +import Control.Lens +import Network.Wreq(Options) +import Data.ByteString(ByteString) +import qualified Network.Wreq as Wreq +import Control.Monad.STM +import Control.Concurrent.STM.TQueue +import qualified Network.Wai as Wai +import qualified Network.HTTP.Conduit as HTTP +import Keter.Proxy main :: IO () main = defaultMain keterTests @@ -14,12 +30,13 @@ main = defaultMain keterTests keterTests :: TestTree keterTests = testGroup - "Pre-2.0 Tests" - [ testCase "Subdomain Integrity" caseSubdomainIntegrity, - testCase "Wildcard Domains" caseWildcards + "Tests" + [ testCase "Subdomain Integrity" caseSubdomainIntegrity + , testCase "Head then post doesn't crash" headThenPostNoCrash + , testCase "Wildcard Domains" caseWildcards ] -caseSubdomainIntegrity :: Assertion +caseSubdomainIntegrity :: IO () caseSubdomainIntegrity = do let test0 = LM.empty test1 = LM.insert "someapp.com" () test0 @@ -27,14 +44,48 @@ caseSubdomainIntegrity = do test3a = LM.delete "someapp.com" test2 test3b = LM.insert "api.someapp.com" () test0 -- case from the bug report msg = "Subdomains inserted and deleted between bundles" - print test3a - print test3b assertBool msg $ test3a == test3b -caseWildcards :: Assertion +caseWildcards :: IO () caseWildcards = do let test0 = LM.empty test1 = LM.insert "*.someapp.com" () test0 test2 = LM.lookup "a.someapp.com" test1 msg = "Wildcards domains" assertBool msg $ isJust test2 + +headThenPostNoCrash :: IO () +headThenPostNoCrash = do + manager <- HTTP.newManager HTTP.tlsManagerSettings + exceptions <- newTQueueIO + + forkIO $ do + Warp.run 6781 $ \req resp -> do + void $ Wai.strictRequestBody req + resp $ Wai.responseLBS ok200 [] "ok" + + forkIO $ do + reverseProxy (settings exceptions manager) $ LPInsecure "*" 6780 + + res <- Wreq.head_ "http://localhost:6780" + + void $ Wreq.post "http://localhost:6780" content + + found <- atomically $ flushTQueue exceptions + assertBool ("the list is not empty " <> show found) (null found) + where + content :: ByteString + content = "a" + + settings :: TQueue (Wai.Request, SomeException) -> Manager -> ProxySettings + settings expections manager = MkProxySettings { + psHostLookup = const $ pure $ Just ((PAPort 6781 Nothing, False), error "unused tls certificate") + , psManager = manager + , psUnkownHost = const "" + , psMissingHost = "" + , psProxyException = "" + , psLogException = \req exception -> + atomically $ writeTQueue expections (req, exception) + , psIpFromHeader = False + , psConnectionTimeBound = 5 * 60 * 1000 + } From 4a09f47171f79123186718346106383ad0986fba Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Mon, 16 May 2022 12:07:59 -0400 Subject: [PATCH 2/2] set extra deps for reverse proxy --- .github/workflows/stack.yaml | 5 +---- stack.yaml | 3 ++- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.github/workflows/stack.yaml b/.github/workflows/stack.yaml index a3cfcbf..7ccfae7 100644 --- a/.github/workflows/stack.yaml +++ b/.github/workflows/stack.yaml @@ -19,10 +19,7 @@ jobs: # windows-latest # TODO add windows support ] resolver: [nightly, lts-18, lts-17, lts-19] - # Bugs in GHC make it crash too often to be worth running - exclude: - - os: macos-latest # no Cocoa ?? https://github.com/snoyberg/keter/runs/4103876510?check_suite_focus=true - resolver: lts-16 + steps: - name: Clone project uses: actions/checkout@v2 diff --git a/stack.yaml b/stack.yaml index 767ecd2..3989cb9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,5 +2,6 @@ flags: keter: {} packages: - '.' -extra-deps: [] +extra-deps: + - http-reverse-proxy-0.6.0.1@sha256:0eb27277306b4950046bf9acc2c721f219d6e9eb939d950cd8cc32c4b9433800,2542 resolver: lts-18