keter 1.4.0.1 → 1.4.1
raw patch · 5 files changed
+72/−51 lines, 5 filesdep ~http-reverse-proxy
Dependency ranges changed: http-reverse-proxy
Files
- ChangeLog.md +4/−0
- Keter/App.hs +6/−7
- Keter/Proxy.hs +35/−27
- Keter/Types/V10.hs +25/−15
- keter.cabal +2/−2
ChangeLog.md view
@@ -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)
Keter/App.hs view
@@ -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
Keter/Proxy.hs view
@@ -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 =
Keter/Types/V10.hs view
@@ -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
keter.cabal view
@@ -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: <http://www.stackage.org/package/keter>. 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