keter 2.0 → 2.0.1
raw patch · 5 files changed
+126/−55 lines, 5 filesdep +lensdep +wreqdep ~http-clientdep ~http-conduitdep ~http-reverse-proxy
Dependencies added: lens, wreq
Dependency ranges changed: http-client, http-conduit, http-reverse-proxy, stm, wai
Files
- ChangeLog.md +5/−0
- keter.cabal +10/−2
- src/Keter/HostManager.hs +3/−5
- src/Keter/Proxy.hs +49/−40
- test/Spec.hs +59/−8
ChangeLog.md view
@@ -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 view
@@ -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
src/Keter/HostManager.hs view
@@ -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
src/Keter/Proxy.hs view
@@ -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 = "<!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 @@ "<!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
test/Spec.hs view
@@ -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+ }