diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.1 + +* Add configurable timeouts [#93](https://github.com/snoyberg/keter/pull/93) + ## 1.4.0.1 * Avoid infinite loop traversing incoming directory [#96](https://github.com/snoyberg/keter/issues/96) diff --git a/Keter/App.hs b/Keter/App.hs --- a/Keter/App.hs +++ b/Keter/App.hs @@ -18,7 +18,7 @@ import Control.Concurrent.STM import Control.Exception (IOException, bracketOnError, throwIO, try) -import Control.Monad (void, when) +import Control.Monad (void, when, unless) import qualified Data.CaseInsensitive as CI import Data.Conduit.LogFile (RotatingLog) import qualified Data.Conduit.LogFile as LogFile @@ -47,8 +47,7 @@ import System.Environment (getEnvironment) import System.IO (hClose) import System.Posix.Files (fileAccess) -import System.Posix.Types (EpochTime) -import System.Posix.Types (GroupID, UserID) +import System.Posix.Types (EpochTime, GroupID, UserID) import System.Timeout (timeout) data App = App @@ -145,7 +144,7 @@ stanzas (wac { waconfigPort = port } : wacs) backs - (Map.unions $ actions : map (\host -> Map.singleton host (PAPort port, rs)) hosts)) + (Map.unions $ actions : map (\host -> Map.singleton host (PAPort port (waconfigTimeout wac), rs)) hosts)) where hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac) loop (Stanza (StanzaStaticFiles sfc) rs:stanzas) wacs backs actions0 = @@ -162,10 +161,10 @@ $ actions0 : map (\host -> Map.singleton host (PARedirect red, rs)) (Set.toList (redirconfigHosts red)) - loop (Stanza (StanzaReverseProxy rev) rs:stanzas) wacs backs actions0 = + loop (Stanza (StanzaReverseProxy rev mid to) rs:stanzas) wacs backs actions0 = loop stanzas wacs backs actions where - actions = Map.insert (CI.mk $ reversingHost rev) (PAReverseProxy rev, rs) actions0 + actions = Map.insert (CI.mk $ reversingHost rev) (PAReverseProxy rev mid to, rs) actions0 loop (Stanza (StanzaBackground back) _:stanzas) wacs backs actions = loop stanzas wacs (back:backs) actions @@ -279,7 +278,7 @@ -- Ordering chosen specifically to precedence rules: app specific, -- plugins, global, and then auto-set Keter variables. [ waconfigEnvironment - , Map.filterWithKey (\k _ -> Set.member k waconfigForwardEnv) $ Map.fromList $ map (\x -> (pack (fst x), pack (snd x))) systemEnv + , Map.filterWithKey (\k _ -> Set.member k waconfigForwardEnv) $ Map.fromList $ map (pack *** pack) systemEnv , Map.fromList otherEnv , kconfigEnvironment ascKeterConfig , Map.singleton "PORT" $ pack $ show waconfigPort diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -- | A light-weight, minimalistic reverse HTTP proxy. module Keter.Proxy ( reverseProxy @@ -8,6 +9,7 @@ ) where import Blaze.ByteString.Builder (copyByteString) +import Control.Applicative ((<|>)) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -23,8 +25,11 @@ import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest), SetIpHeader (..), WaiProxyResponse (..), + LocalWaiProxySettings, + setLpsTimeBound, waiProxyToSettings, - wpsSetIpHeader) + wpsSetIpHeader, + wpsGetDest) import qualified Network.HTTP.ReverseProxy.Rewrite as Rewrite import Network.HTTP.Types (mkStatus, status200, status301, status302, @@ -65,17 +70,17 @@ -> Manager -> HostLookup -> Wai.Application -withClient isSecure useHeader bound manager portLookup req0 sendResponse = - if bound > 0 - then timeBound (bound * 1000) task - else task - where - task = waiProxyToSettings getDest def +withClient isSecure useHeader bound manager hostLookup = + waiProxyToSettings + (error "First argument to waiProxyToSettings forced, even thought wpsGetDest provided") + def { wpsSetIpHeader = if useHeader then SIHFromHeader else SIHFromSocket - } manager req0 sendResponse + , wpsGetDest = Just getDest + } manager + where protocol | isSecure = "https" | otherwise = "http" @@ -87,39 +92,41 @@ -- infinitely without the server it's connecting to going down, so that -- requires more research. Meanwhile, this prevents the file descriptor -- leak from occurring. - timeBound us f = do - mres <- timeout us f - case mres of - Just res -> return res - Nothing -> sendResponse $ Wai.responseLBS status500 [] "timeBound" - getDest :: Wai.Request -> IO WaiProxyResponse + addjustGlobalBound :: Maybe Int -> LocalWaiProxySettings + addjustGlobalBound to = go `setLpsTimeBound` def + where + go = case to <|> Just bound of + Just x | x > 0 -> Just x + _ -> Nothing + + getDest :: Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse) getDest req = case Wai.requestHeaderHost req of - Nothing -> return $ WPRResponse missingHostResponse + Nothing -> return (def, WPRResponse missingHostResponse) Just host -> processHost req host - processHost :: Wai.Request -> S.ByteString -> IO WaiProxyResponse + processHost :: Wai.Request -> S.ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse) processHost req host = do -- Perform two levels of lookup. First: look up the entire host. If -- that fails, try stripping off any port number and try again. mport <- liftIO $ do - mport1 <- portLookup host + mport1 <- hostLookup host case mport1 of Just _ -> return mport1 Nothing -> do let host' = S.takeWhile (/= 58) host if host' == host then return Nothing - else portLookup host' + else hostLookup host' case mport of - Nothing -> return $ WPRResponse $ unknownHostResponse host + Nothing -> return (def, WPRResponse $ unknownHostResponse host) Just (action, requiresSecure) | requiresSecure && not isSecure -> performHttpsRedirect host req | otherwise -> performAction req action performHttpsRedirect host = - return . WPRResponse . redirectApp config + return . (addjustGlobalBound Nothing,) . WPRResponse . redirectApp config where host' = CI.mk $ decodeUtf8With lenientDecode host config = RedirectConfig @@ -129,22 +136,23 @@ $ RDPrefix True host' Nothing } - performAction req (PAPort port) = - return $ WPRModifiedRequest req' $ ProxyDest "127.0.0.1" port + performAction req (PAPort port tbound) = + return (addjustGlobalBound tbound, WPRModifiedRequest req' $ ProxyDest "127.0.0.1" port) where req' = req { Wai.requestHeaders = ("X-Forwarded-Proto", protocol) : Wai.requestHeaders req } - performAction _ (PAStatic StaticFilesConfig {..}) = do - return $ WPRApplication $ processMiddleware sfconfigMiddleware $ staticApp (defaultFileServerSettings sfconfigRoot) + 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 $ WPRResponse $ redirectApp config req - performAction _ (PAReverseProxy config) = return $ WPRApplication $ Rewrite.simpleReverseProxy manager config + }) + performAction req (PARedirect config) = return (addjustGlobalBound Nothing, WPRResponse $ redirectApp config req) + performAction _ (PAReverseProxy config rpconfigMiddleware tbound) = + return (addjustGlobalBound tbound, WPRApplication $ processMiddleware rpconfigMiddleware $ Rewrite.simpleReverseProxy manager config) redirectApp :: RedirectConfig -> Wai.Request -> Wai.Response redirectApp RedirectConfig {..} req = diff --git a/Keter/Types/V10.hs b/Keter/Types/V10.hs --- a/Keter/Types/V10.hs +++ b/Keter/Types/V10.hs @@ -53,7 +53,7 @@ } instance ParseYamlFile BundleConfig where - parseYamlFile basedir = withObject "BundleConfig" $ \o -> do + parseYamlFile basedir = withObject "BundleConfig" $ \o -> case HashMap.lookup "stanzas" o of Nothing -> (toCurrent :: V04.BundleConfig -> BundleConfig) <$> parseYamlFile basedir (Object o) Just _ -> current o @@ -111,7 +111,7 @@ , kconfigPortPool = portman , kconfigListeners = NonEmptyVector (LPInsecure host port) (getSSL ssl) , kconfigSetuid = setuid - , kconfigBuiltinStanzas = V.fromList $ map (flip Stanza False . StanzaReverseProxy) $ Set.toList rproxy + , kconfigBuiltinStanzas = V.fromList $ map (flip Stanza False . (\rp -> StanzaReverseProxy rp [] Nothing)) $ Set.toList rproxy , kconfigIpFromHeader = ipFromHeader , kconfigExternalHttpPort = 80 , kconfigExternalHttpsPort = 443 @@ -169,7 +169,7 @@ = StanzaStaticFiles !StaticFilesConfig | StanzaRedirect !RedirectConfig | StanzaWebApp !(WebAppConfig port) - | StanzaReverseProxy !ReverseProxyConfig + | StanzaReverseProxy !ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int) | StanzaBackground !BackgroundConfig -- FIXME console app deriving Show @@ -182,10 +182,10 @@ -- -- 2. Not all stanzas have an associated proxy action. data ProxyActionRaw - = PAPort Port + = PAPort Port !(Maybe Int) | PAStatic StaticFilesConfig | PARedirect RedirectConfig - | PAReverseProxy ReverseProxyConfig + | PAReverseProxy ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int) deriving Show type ProxyAction = (ProxyActionRaw, RequiresSecure) @@ -195,11 +195,13 @@ typ <- o .: "type" needsHttps <- o .:? "requires-secure" .!= False raw <- case typ of - "static-files" -> fmap StanzaStaticFiles $ parseYamlFile basedir $ Object o - "redirect" -> fmap StanzaRedirect $ parseYamlFile basedir $ Object o - "webapp" -> fmap StanzaWebApp $ parseYamlFile basedir $ Object o - "reverse-proxy" -> fmap StanzaReverseProxy $ parseJSON $ Object o - "background" -> fmap StanzaBackground $ parseYamlFile basedir $ Object o + "static-files" -> fmap StanzaStaticFiles $ parseYamlFile basedir $ Object o + "redirect" -> fmap StanzaRedirect $ parseYamlFile basedir $ Object o + "webapp" -> fmap StanzaWebApp $ parseYamlFile basedir $ Object o + "reverse-proxy" -> StanzaReverseProxy <$> parseJSON (Object o) + <*> o .:? "middleware" .!= [] + <*> o .:? "connection-time-bound" + "background" -> fmap StanzaBackground $ parseYamlFile basedir $ Object o _ -> fail $ "Unknown stanza type: " ++ typ return $ Stanza raw needsHttps @@ -216,7 +218,7 @@ toJSON (StanzaStaticFiles x) = addStanzaType "static-files" x toJSON (StanzaRedirect x) = addStanzaType "redirect" x toJSON (StanzaWebApp x) = addStanzaType "webapp" x - toJSON (StanzaReverseProxy x) = addStanzaType "reverse-proxy" x + toJSON (StanzaReverseProxy x _ _) = addStanzaType "reverse-proxy" x toJSON (StanzaBackground x) = addStanzaType "background" x addStanzaType :: ToJSON a => Value -> a -> Value @@ -231,16 +233,18 @@ , sfconfigListings :: !Bool -- FIXME basic auth , sfconfigMiddleware :: ![ MiddlewareConfig ] + , sfconfigTimeout :: !(Maybe Int) } deriving Show instance ToCurrent StaticFilesConfig where type Previous StaticFilesConfig = V04.StaticHost toCurrent (V04.StaticHost host root) = StaticFilesConfig - { sfconfigRoot = root - , sfconfigHosts = Set.singleton $ CI.mk host - , sfconfigListings = True + { sfconfigRoot = root + , sfconfigHosts = Set.singleton $ CI.mk host + , sfconfigListings = True , sfconfigMiddleware = [] + , sfconfigTimeout = Nothing } instance ParseYamlFile StaticFilesConfig where @@ -249,6 +253,7 @@ <*> (Set.map CI.mk <$> ((o .: "hosts" <|> (Set.singleton <$> (o .: "host"))))) <*> o .:? "directory-listing" .!= False <*> o .:? "middleware" .!= [] + <*> o .:? "connection-time-bound" instance ToJSON StaticFilesConfig where toJSON StaticFilesConfig {..} = object @@ -256,6 +261,7 @@ , "hosts" .= Set.map CI.original sfconfigHosts , "directory-listing" .= sfconfigListings , "middleware" .= sfconfigMiddleware + , "connection-time-bound" .= sfconfigTimeout ] data RedirectConfig = RedirectConfig @@ -343,6 +349,7 @@ , waconfigSsl :: !Bool , waconfigPort :: !port , waconfigForwardEnv :: !(Set Text) + , waconfigTimeout :: !(Maybe Int) } deriving Show @@ -357,6 +364,7 @@ , waconfigSsl = ssl , waconfigPort = () , waconfigForwardEnv = Set.empty + , waconfigTimeout = Nothing } instance ParseYamlFile (WebAppConfig ()) where @@ -379,6 +387,7 @@ <*> o .:? "ssl" .!= False <*> return () <*> o .:? "forward-env" .!= Set.empty + <*> o .:? "connection-time-bound" instance ToJSON (WebAppConfig ()) where toJSON WebAppConfig {..} = object @@ -388,6 +397,7 @@ , "hosts" .= map CI.original (waconfigApprootHost : Set.toList waconfigHosts) , "ssl" .= waconfigSsl , "forward-env" .= waconfigForwardEnv + , "connection-time-bound" .= waconfigTimeout ] data AppInput = AIBundle !FilePath !EpochTime @@ -407,7 +417,7 @@ instance FromJSON RestartCount where parseJSON (String "unlimited") = return UnlimitedRestarts - parseJSON v = fmap LimitedRestarts $ parseJSON v + parseJSON v = LimitedRestarts <$> parseJSON v instance ParseYamlFile BackgroundConfig where parseYamlFile basedir = withObject "BackgroundConfig" $ \o -> BackgroundConfig diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -1,5 +1,5 @@ Name: keter -Version: 1.4.0.1 +Version: 1.4.1 Synopsis: Web application deployment manager, focusing on Haskell web frameworks Description: Hackage documentation generation is not reliable. For up to date documentation, please see: . Homepage: http://www.yesodweb.com/ @@ -37,7 +37,7 @@ , fsnotify >= 0.0.11 , conduit >= 1.1 , conduit-extra >= 1.1 - , http-reverse-proxy >= 0.4 && < 0.5 + , http-reverse-proxy >= 0.4.2 && < 0.5 , unix >= 2.5 , wai-app-static >= 3.1 && < 3.2 , wai >= 3.0 && < 3.1