keter 1.3.9.2 → 1.3.10

raw patch · 6 files changed

+119/−99 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• Keter/Main.hs +10/−8
• Keter/Proxy.hs +15/−11
• Keter/Types/V04.hs +34/−31
• Keter/Types/V10.hs +55/−48
• keter.cabal +1/−1

@@ -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)

@@ -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) 

@@ -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

@@ -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]

@@ -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

@@ -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: <http://www.stackage.org/package/keter>. Homepage:            http://www.yesodweb.com/