diff --git a/ChangeLog.md b/ChangeLog.md --- 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 --- 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 @@ , 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 @@ , 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/src/Keter/HostManager.hs b/src/Keter/HostManager.hs --- a/src/Keter/HostManager.hs +++ b/src/Keter/HostManager.hs @@ -34,12 +34,10 @@ 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 @@ 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 @@ 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 --- 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 @@ { -- | 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 @@ } 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 @@ 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 @@ } 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 @@ 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 @@ , 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 @@ defaultMissingHostBody :: ByteString defaultMissingHostBody = "\nWelcome 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 @@ "\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 --- 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 @@ 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 @@ 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 + }