Merge pull request #270 from SupercedeTech/add-test-for-head-post-fai…

…lure

Force usage of http-reverse-proxy above 0.6.0.1

.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

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.

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

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";
+                } {};
+                };
         };
     };
   };

shell.nix

@@ -11,5 +11,6 @@ pkgs.haskellPackages.shellFor {
  };
   buildInputs = [
         pkgs.cabal-install
+        pkgs.haskellPackages.hasktags
         ];
 }

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

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,15 +82,16 @@ 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
   , psLogException   :: Wai.Request -> SomeException -> IO ()
   }
 
 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 = "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</t
 defaultMissingHostBody :: ByteString
 defaultMissingHostBody = "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>You did not provide a virtual hostname for this request.</p></body></html>"
 
+-- | Error, no host found in the header
 missingHostResponse :: ByteString -> Wai.Response
 missingHostResponse missingHost = Wai.responseBuilder
     status502
@@ -306,6 +314,7 @@ defaultUnknownHostBody host =
   "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code>"
   <> escapeHtml host <> "</code>, is not recognized.</p></body></html>"
 
+-- | 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

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

test/Spec.hs

@@ -2,39 +2,90 @@
 
 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
 
 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
       test2 = LM.insert "api.someapp.com" () test1
       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
+      }