diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.3.10 + +* Configurable time bound [#92](https://github.com/snoyberg/keter/pull/92) + ## 1.3.9.2 * Lower case PostgreSQL names [#88](https://github.com/snoyberg/keter/pull/88) diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -27,25 +27,26 @@ import Control.Applicative ((<$>)) import Control.Exception (throwIO, try) import Control.Monad (forM) +import Control.Monad (void, when) import Data.Conduit.Process.Unix (initProcessTracker) +import Data.Default (def) import qualified Data.Map as Map import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Read import Data.Time (getCurrentTime) import Data.Yaml.FilePath +import Filesystem (createTree) import qualified Filesystem as F +import Filesystem.Path.CurrentOS (hasExtension, ()) import qualified Filesystem.Path.CurrentOS as F -import Filesystem.Path.CurrentOS ((), hasExtension) -import qualified Network.HTTP.Conduit as HTTP (newManager, conduitManagerSettings) +import qualified Network.HTTP.Conduit as HTTP (conduitManagerSettings, + newManager) +import Prelude hiding (FilePath, log) import qualified System.FSNotify as FSN import System.Posix.User (getUserEntryForID, getUserEntryForName, userGroupID, userID, userName) -import Control.Monad (void, when) -import Data.Default (def) -import Prelude hiding (FilePath, log) -import Filesystem (createTree) keter :: FilePath -- ^ root directory or config file -> [FilePath -> IO Plugin] @@ -98,7 +99,7 @@ hostman <- HostMan.start portpool <- PortPool.start kconfigPortPool tf <- TempFolder.setup $ kconfigDir "temp" - plugins <- sequence $ map ($ kconfigDir) mkPlugins + plugins <- mapM ($ kconfigDir) mkPlugins muid <- case kconfigSetuid of Nothing -> return Nothing @@ -127,7 +128,7 @@ launchInitial :: KeterConfig -> AppMan.AppManager -> IO () launchInitial kc@KeterConfig {..} appMan = do createTree incoming - bundles0 <- fmap (filter isKeter) $ listDirectoryTree incoming + bundles0 <- filter isKeter <$> listDirectoryTree incoming mapM_ (AppMan.addApp appMan) bundles0 unless (V.null kconfigBuiltinStanzas) $ AppMan.perform @@ -190,6 +191,7 @@ manager <- HTTP.newManager HTTP.conduitManagerSettings runAndBlock kconfigListeners $ Proxy.reverseProxy kconfigIpFromHeader + kconfigConnectionTimeBound manager (HostMan.lookupAction hostman . CI.mk) diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -12,9 +12,9 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.CaseInsensitive as CI -import Data.Default (Default(..)) +import Data.Default (Default (..)) import Data.Monoid (mappend, mempty) -import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Vector as V import qualified Filesystem.Path.CurrentOS as F @@ -38,16 +38,16 @@ import qualified Network.Wai.Handler.WarpTLS as WarpTLS import Network.Wai.Middleware.Gzip (gzip) import Prelude hiding (FilePath, (++)) +import System.Timeout.Lifted (timeout) import WaiAppStatic.Listing (defaultListing) -import System.Timeout.Lifted (timeout) -- | Mapping from virtual hostname to port number. type HostLookup = ByteString -> IO (Maybe ProxyAction) reverseProxy :: Bool - -> Manager -> HostLookup -> ListeningPort -> IO () -reverseProxy useHeader manager hostLookup listener = - run $ gzip def $ withClient isSecure useHeader manager hostLookup + -> Int -> Manager -> HostLookup -> ListeningPort -> IO () +reverseProxy useHeader timeBound manager hostLookup listener = + run $ gzip def $ withClient isSecure useHeader timeBound manager hostLookup where warp host port = Warp.setHost host $ Warp.setPort port Warp.defaultSettings (run, isSecure) = @@ -62,22 +62,26 @@ withClient :: Bool -- ^ is secure? -> Bool -- ^ use incoming request header for IP address + -> Int -- ^ time bound for connections -> Manager -> HostLookup -> Wai.Application -withClient isSecure useHeader manager portLookup req0 sendResponse = - timeBound (5 * 60 * 1000 * 1000) (waiProxyToSettings getDest def +withClient isSecure useHeader bound manager portLookup req0 sendResponse = + if bound > 0 + then timeBound (bound * 1000) task + else task + where + task = waiProxyToSettings getDest def { wpsSetIpHeader = if useHeader then SIHFromHeader else SIHFromSocket - } manager req0 sendResponse) - where + } manager req0 sendResponse protocol | isSecure = "https" | otherwise = "http" - -- FIXME This is a temporary workaround for + -- 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 diff --git a/Keter/Types/V04.hs b/Keter/Types/V04.hs --- a/Keter/Types/V04.hs +++ b/Keter/Types/V04.hs @@ -3,28 +3,28 @@ -- compatibility in config file format. module Keter.Types.V04 where -import Prelude hiding (FilePath) -import Data.Yaml.FilePath -import Data.Aeson -import Control.Applicative -import qualified Data.Set as Set -import qualified Filesystem.Path as F -import Data.Default -import Data.String (fromString) -import Data.Conduit.Network (HostPreference) -import qualified Network.Wai.Handler.Warp as Warp -import qualified Network.Wai.Handler.WarpTLS as WarpTLS -import Filesystem.Path.CurrentOS (encodeString) -import Keter.Types.Common -import Network.HTTP.ReverseProxy.Rewrite +import Control.Applicative +import Data.Aeson +import Data.Conduit.Network (HostPreference) +import Data.Default +import qualified Data.Set as Set +import Data.String (fromString) +import Data.Yaml.FilePath +import qualified Filesystem.Path as F +import Filesystem.Path.CurrentOS (encodeString) +import Keter.Types.Common +import Network.HTTP.ReverseProxy.Rewrite +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Handler.WarpTLS as WarpTLS +import Prelude hiding (FilePath) data AppConfig = AppConfig - { configExec :: F.FilePath - , configArgs :: [Text] - , configHost :: Text - , configSsl :: Bool + { configExec :: F.FilePath + , configArgs :: [Text] + , configHost :: Text + , configSsl :: Bool , configExtraHosts :: Set Text - , configRaw :: Object + , configRaw :: Object } instance ParseYamlFile AppConfig where @@ -37,9 +37,9 @@ <*> return o data BundleConfig = BundleConfig - { bconfigApp :: Maybe AppConfig + { bconfigApp :: Maybe AppConfig , bconfigStaticHosts :: Set StaticHost - , bconfigRedirects :: Set Redirect + , bconfigRedirects :: Set Redirect } instance ParseYamlFile BundleConfig where @@ -61,7 +61,7 @@ data Redirect = Redirect { redFrom :: Text - , redTo :: Text + , redTo :: Text } deriving (Eq, Ord) @@ -72,14 +72,15 @@ parseJSON _ = fail "Wanted an object" data KeterConfig = KeterConfig - { kconfigDir :: F.FilePath - , kconfigPortMan :: PortSettings - , kconfigHost :: HostPreference - , kconfigPort :: Port - , kconfigSsl :: Maybe TLSConfig - , kconfigSetuid :: Maybe Text - , kconfigReverseProxy :: Set ReverseProxyConfig - , kconfigIpFromHeader :: Bool + { kconfigDir :: F.FilePath + , kconfigPortMan :: PortSettings + , kconfigHost :: HostPreference + , kconfigPort :: Port + , kconfigSsl :: Maybe TLSConfig + , kconfigSetuid :: Maybe Text + , kconfigReverseProxy :: Set ReverseProxyConfig + , kconfigIpFromHeader :: Bool + , kconfigConnectionTimeBound :: Int } instance Default KeterConfig where @@ -92,6 +93,7 @@ , kconfigSetuid = Nothing , kconfigReverseProxy = Set.empty , kconfigIpFromHeader = False + , kconfigConnectionTimeBound = 5000 } instance ParseYamlFile KeterConfig where @@ -104,6 +106,7 @@ <*> o .:? "setuid" <*> o .:? "reverse-proxy" .!= Set.empty <*> o .:? "ip-from-header" .!= False + <*> o .:? "connection-time-bound" .!= 5000 data TLSConfig = TLSConfig !Warp.Settings !WarpTLS.TLSSettings @@ -131,7 +134,7 @@ instance Default PortSettings where def = PortSettings - -- Top 10 Largest IANA unassigned port ranges with no unauthorized uses known + -- Top 10 Largest IANA unassigned port ranges with no unauthorized uses known { portRange = [43124..44320] ++ [28120..29166] ++ [45967..46997] diff --git a/Keter/Types/V10.hs b/Keter/Types/V10.hs --- a/Keter/Types/V10.hs +++ b/Keter/Types/V10.hs @@ -1,35 +1,38 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Keter.Types.V10 where -import Prelude hiding (FilePath) -import System.Posix.Types (EpochTime) -import Data.Aeson (Object, ToJSON (..)) -import qualified Data.CaseInsensitive as CI -import Keter.Types.Common -import qualified Keter.Types.V04 as V04 -import Keter.Types.Middleware -import Data.Yaml.FilePath -import Data.Aeson (FromJSON (..), (.:), (.:?), Value (Object, String), withObject, (.!=)) -import Control.Applicative ((<$>), (<*>), (<|>)) -import qualified Data.Set as Set -import qualified Filesystem.Path.CurrentOS as F -import Data.Default -import Data.String (fromString) -import Data.Conduit.Network (HostPreference) -import Data.Vector (Vector) -import qualified Data.Vector as V -import Network.HTTP.ReverseProxy.Rewrite (ReverseProxyConfig) -import Data.Maybe (fromMaybe, catMaybes) -import qualified Network.Wai.Handler.Warp as Warp -import qualified Network.Wai.Handler.WarpTLS as WarpTLS -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map as Map -import Data.Aeson ((.=), Value (Bool), object) -import Data.Word (Word) +import Control.Applicative ((<$>), (<*>), (<|>)) +import Data.Aeson (Object, ToJSON (..)) +import Data.Aeson (FromJSON (..), + Value (Object, String), + withObject, (.!=), (.:), + (.:?)) +import Data.Aeson (Value (Bool), object, (.=)) +import qualified Data.CaseInsensitive as CI +import Data.Conduit.Network (HostPreference) +import Data.Default +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromMaybe) +import qualified Data.Set as Set +import Data.String (fromString) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word (Word) +import Data.Yaml.FilePath +import qualified Filesystem.Path.CurrentOS as F +import Keter.Types.Common +import Keter.Types.Middleware +import qualified Keter.Types.V04 as V04 +import Network.HTTP.ReverseProxy.Rewrite (ReverseProxyConfig) +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Handler.WarpTLS as WarpTLS +import Prelude hiding (FilePath) +import System.Posix.Types (EpochTime) data BundleConfig = BundleConfig { bconfigStanzas :: !(Vector (Stanza ())) @@ -87,23 +90,24 @@ _ -> fail "Must provide both certificate and key files" data KeterConfig = KeterConfig - { kconfigDir :: F.FilePath - , kconfigPortPool :: V04.PortSettings - , kconfigListeners :: !(NonEmptyVector ListeningPort) - , kconfigSetuid :: Maybe Text - , kconfigBuiltinStanzas :: !(V.Vector (Stanza ())) - , kconfigIpFromHeader :: Bool - , kconfigExternalHttpPort :: !Int + { kconfigDir :: F.FilePath + , kconfigPortPool :: V04.PortSettings + , kconfigListeners :: !(NonEmptyVector ListeningPort) + , kconfigSetuid :: Maybe Text + , kconfigBuiltinStanzas :: !(V.Vector (Stanza ())) + , kconfigIpFromHeader :: Bool + , kconfigExternalHttpPort :: !Int -- ^ External HTTP port when generating APPROOTs. - , kconfigExternalHttpsPort :: !Int + , kconfigExternalHttpsPort :: !Int -- ^ External HTTPS port when generating APPROOTs. - , kconfigEnvironment :: !(Map Text Text) + , kconfigEnvironment :: !(Map Text Text) -- ^ Environment variables to be passed to all apps. + , kconfigConnectionTimeBound :: !Int } instance ToCurrent KeterConfig where type Previous KeterConfig = V04.KeterConfig - toCurrent (V04.KeterConfig dir portman host port ssl setuid rproxy ipFromHeader) = KeterConfig + toCurrent (V04.KeterConfig dir portman host port ssl setuid rproxy ipFromHeader connectionTimeBound) = KeterConfig { kconfigDir = dir , kconfigPortPool = portman , kconfigListeners = NonEmptyVector (LPInsecure host port) (getSSL ssl) @@ -113,6 +117,7 @@ , kconfigExternalHttpPort = 80 , kconfigExternalHttpsPort = 443 , kconfigEnvironment = Map.empty + , kconfigConnectionTimeBound = connectionTimeBound } where getSSL Nothing = V.empty @@ -134,6 +139,7 @@ , kconfigExternalHttpPort = 80 , kconfigExternalHttpsPort = 443 , kconfigEnvironment = Map.empty + , kconfigConnectionTimeBound = 5000 } instance ParseYamlFile KeterConfig where @@ -153,6 +159,7 @@ <*> o .:? "external-http-port" .!= 80 <*> o .:? "external-https-port" .!= 443 <*> o .:? "env" .!= Map.empty + <*> o .:? "connection-time-bound" .!= 5000 -- | Whether we should force redirect to HTTPS routes. type RequiresSecure = Bool @@ -220,9 +227,9 @@ v -> v data StaticFilesConfig = StaticFilesConfig - { sfconfigRoot :: !F.FilePath - , sfconfigHosts :: !(Set Host) - , sfconfigListings :: !Bool + { sfconfigRoot :: !F.FilePath + , sfconfigHosts :: !(Set Host) + , sfconfigListings :: !Bool -- FIXME basic auth , sfconfigMiddleware :: ![ MiddlewareConfig ] } @@ -253,8 +260,8 @@ ] data RedirectConfig = RedirectConfig - { redirconfigHosts :: !(Set Host) - , redirconfigStatus :: !Int + { redirconfigHosts :: !(Set Host) + , redirconfigStatus :: !Int , redirconfigActions :: !(Vector RedirectAction) } deriving Show @@ -388,10 +395,10 @@ | AIData !BundleConfig data BackgroundConfig = BackgroundConfig - { bgconfigExec :: !F.FilePath - , bgconfigArgs :: !(Vector Text) - , bgconfigEnvironment :: !(Map Text Text) - , bgconfigRestartCount :: !RestartCount + { bgconfigExec :: !F.FilePath + , bgconfigArgs :: !(Vector Text) + , bgconfigEnvironment :: !(Map Text Text) + , bgconfigRestartCount :: !RestartCount , bgconfigRestartDelaySeconds :: !Word } deriving Show diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -1,5 +1,5 @@ Name: keter -Version: 1.3.9.2 +Version: 1.3.10 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/