diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.2.1 + +Bug fix: Change default connection time bound from 5 sec to 5 minutes [#107](https://github.com/snoyberg/keter/pull/107) + ## 1.4.1 * Add configurable timeouts [#93](https://github.com/snoyberg/keter/pull/93) 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, unless) +import Control.Monad (void, when) import qualified Data.CaseInsensitive as CI import Data.Conduit.LogFile (RotatingLog) import qualified Data.Conduit.LogFile as LogFile @@ -267,7 +267,7 @@ -> IO a launchWebApp AppStartConfig {..} aid BundleConfig {..} mdir rlog WebAppConfig {..} f = do otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins - systemEnv <- getEnvironment + forwardedEnv <- getForwardedEnv waconfigForwardEnv let httpPort = kconfigExternalHttpPort ascKeterConfig httpsPort = kconfigExternalHttpsPort ascKeterConfig (scheme, extport) = @@ -278,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 (pack *** pack) systemEnv + , forwardedEnv , Map.fromList otherEnv , kconfigEnvironment ascKeterConfig , Map.singleton "PORT" $ pack $ show waconfigPort @@ -355,7 +355,14 @@ -> IO a launchBackgroundApp AppStartConfig {..} aid BundleConfig {..} mdir rlog BackgroundConfig {..} f = do otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins - let env = Map.toList bgconfigEnvironment ++ otherEnv + forwardedEnv <- getForwardedEnv bgconfigForwardEnv + let env = Map.toList $ Map.unions + -- Order matters as in launchWebApp + [ bgconfigEnvironment + , forwardedEnv + , Map.fromList otherEnv + , kconfigEnvironment ascKeterConfig + ] exec <- canonicalizePath bgconfigExec let delay = threadDelay $ fromIntegral $ bgconfigRestartDelaySeconds * 1000 * 1000 @@ -591,6 +598,16 @@ pluginsGetEnv :: Plugins -> Appname -> Object -> IO [(Text, Text)] pluginsGetEnv ps app o = fmap concat $ mapM (\p -> pluginGetEnv p app o) ps + +-- | For the forward-env option. From a Set of desired variables, create a +-- Map pulled from the system environment. +getForwardedEnv :: Set Text -> IO (Map Text Text) +getForwardedEnv vars = filterEnv <$> getEnvironment + where + filterEnv = Map.filterWithKey (\k _ -> Set.member k vars) + . Map.fromList + . map (pack *** pack) + {- FIXME handle static stanzas let staticReverse r = do diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -193,7 +193,9 @@ manager <- HTTP.newManager HTTP.conduitManagerSettings runAndBlock kconfigListeners $ Proxy.reverseProxy kconfigIpFromHeader - kconfigConnectionTimeBound + -- calculate the number of microseconds since the + -- configuration option is in milliseconds + (kconfigConnectionTimeBound * 1000) manager (HostMan.lookupAction hostman . CI.mk) diff --git a/Keter/Plugin/Postgres.hs b/Keter/Plugin/Postgres.hs --- a/Keter/Plugin/Postgres.hs +++ b/Keter/Plugin/Postgres.hs @@ -8,7 +8,7 @@ , load ) where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>), (<*>), pure) import Control.Concurrent (forkIO) import Control.Concurrent.Chan import Control.Concurrent.MVar @@ -20,10 +20,12 @@ import Data.Default import qualified Data.HashMap.Strict as HMap import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Builder (fromText, toLazyText) +import qualified Data.Vector as V import Data.Yaml import Keter.Types import Prelude hiding (FilePath) @@ -48,29 +50,47 @@ "';\nCREATE DATABASE " <> fromText dbiName <> " OWNER " <> fromText dbiUser <> ";" - _ <- readProcess "sudo" ["-u", "postgres", "psql"] $ TL.unpack sql + (cmd, args) + | ( dbServer dbiServer == "localhost" + || dbServer dbiServer == "127.0.0.1") = + ("sudo", ["-u", "postgres", "psql"]) + | otherwise = + ("psql", + [ "-h", (T.unpack $ dbServer dbiServer) + , "-p", (show $ dbPort dbiServer) + , "-U", "postgres"]) + _ <- readProcess cmd args $ TL.unpack sql return () } -- | Information on an individual PostgreSQL database. data DBInfo = DBInfo - { dbiName :: Text - , dbiUser :: Text - , dbiPass :: Text + { dbiName :: Text + , dbiUser :: Text + , dbiPass :: Text + , dbiServer :: DBServerInfo } deriving Show -randomDBI :: R.StdGen -> (DBInfo, R.StdGen) -randomDBI = - S.runState (DBInfo <$> rt <*> rt <*> rt) +data DBServerInfo = DBServerInfo + { dbServer :: Text + , dbPort :: Int + } + deriving Show + +randomDBI :: DBServerInfo -> R.StdGen -> (DBInfo, R.StdGen) +randomDBI dbsi = + S.runState (DBInfo <$> rt <*> rt <*> rt <*> (pure dbsi)) where rt = T.pack <$> replicateM 10 (S.state $ R.randomR ('a', 'z')) instance ToJSON DBInfo where - toJSON (DBInfo n u p) = object - [ "name" .= n - , "user" .= u - , "pass" .= p + toJSON (DBInfo n u p (DBServerInfo server port)) = object + [ "name" .= n + , "user" .= u + , "pass" .= p + , "server" .= server + , "port" .= port ] instance FromJSON DBInfo where @@ -78,10 +98,22 @@ <$> o .: "name" <*> o .: "user" <*> o .: "pass" + <*> (DBServerInfo + <$> o .:? "server" .!= "localhost" + <*> o .:? "port" .!= 5432) parseJSON _ = mzero -data Command = GetConfig Appname (Either SomeException DBInfo -> IO ()) +instance FromJSON DBServerInfo where + parseJSON (Object o) = DBServerInfo + <$> o .: "server" + <*> o .: "port" + parseJSON _ = mzero + +instance Default DBServerInfo where + def = DBServerInfo "localhost" 5432 +data Command = GetConfig Appname DBServerInfo (Either SomeException DBInfo -> IO ()) + -- | Load a set of existing connections from a config file. If the file does -- not exist, it will be created. Any newly created databases will -- automatically be saved to this file. @@ -104,24 +136,29 @@ return Plugin { pluginGetEnv = \appname o -> case HMap.lookup "postgres" o of + Just (Array v) -> do + let dbServer = fromMaybe def . parseMaybe parseJSON $ V.head v + doenv chan appname dbServer Just (Bool True) -> do - x <- newEmptyMVar - writeChan chan $ GetConfig appname $ putMVar x - edbi <- takeMVar x - edbiToEnv edbi + doenv chan appname def _ -> return [] } - + where doenv chan appname dbs = do + x <- newEmptyMVar + writeChan chan $ GetConfig appname dbs $ putMVar x + edbi <- takeMVar x + edbiToEnv edbi + tmpfp = fp <.> "tmp" loop chan = do - GetConfig appname f <- lift $ readChan chan + GetConfig appname dbServer f <- lift $ readChan chan (db, g) <- S.get dbi <- case Map.lookup appname db of Just dbi -> return $ Right dbi Nothing -> do - let (dbi', g') = randomDBI g + let (dbi', g') = randomDBI dbServer g let dbi = dbi' { dbiName = sanitize appname <> dbiName dbi' , dbiUser = sanitize appname <> dbiUser dbi' @@ -152,9 +189,10 @@ -> IO [(Text, Text)] edbiToEnv (Left e) = throwIO e edbiToEnv (Right dbi) = return - [ ("PGHOST", "localhost") - , ("PGPORT", "5432") + [ ("PGHOST", dbServer $ dbiServer dbi) + , ("PGPORT", T.pack . show . dbPort $ dbiServer dbi) , ("PGUSER", dbiUser dbi) , ("PGPASS", dbiPass dbi) , ("PGDATABASE", dbiName dbi) ] + diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -34,7 +34,7 @@ import Network.HTTP.Types (mkStatus, status200, status301, status302, status303, status307, - status404, status500) + status404) import qualified Network.Wai as Wai import Network.Wai.Application.Static (defaultFileServerSettings, ssListing, staticApp) @@ -42,7 +42,6 @@ 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) -- | Mapping from virtual hostname to port number. diff --git a/Keter/Types/V04.hs b/Keter/Types/V04.hs --- a/Keter/Types/V04.hs +++ b/Keter/Types/V04.hs @@ -80,6 +80,7 @@ , kconfigReverseProxy :: Set ReverseProxyConfig , kconfigIpFromHeader :: Bool , kconfigConnectionTimeBound :: Int + -- ^ Maximum request time in milliseconds per connection. } instance Default KeterConfig where @@ -95,6 +96,8 @@ , kconfigConnectionTimeBound = fiveMinutes } + +-- | Default connection time bound in milliseconds. fiveMinutes :: Int fiveMinutes = 5 * 60 * 1000 diff --git a/Keter/Types/V10.hs b/Keter/Types/V10.hs --- a/Keter/Types/V10.hs +++ b/Keter/Types/V10.hs @@ -102,6 +102,7 @@ , kconfigEnvironment :: !(Map Text Text) -- ^ Environment variables to be passed to all apps. , kconfigConnectionTimeBound :: !Int + -- ^ Maximum request time in milliseconds per connection. } instance ToCurrent KeterConfig where @@ -409,6 +410,7 @@ , bgconfigEnvironment :: !(Map Text Text) , bgconfigRestartCount :: !RestartCount , bgconfigRestartDelaySeconds :: !Word + , bgconfigForwardEnv :: !(Set Text) } deriving Show @@ -426,6 +428,7 @@ <*> o .:? "env" .!= Map.empty <*> o .:? "restart-count" .!= UnlimitedRestarts <*> o .:? "restart-delay-seconds" .!= 5 + <*> o .:? "forward-env" .!= Set.empty instance ToJSON BackgroundConfig where toJSON BackgroundConfig {..} = object $ catMaybes @@ -436,4 +439,5 @@ UnlimitedRestarts -> Nothing LimitedRestarts count -> Just $ "restart-count" .= count , Just $ "restart-delay-seconds" .= bgconfigRestartDelaySeconds + , Just $ "forward-env" .= bgconfigForwardEnv ] diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -179,8 +179,26 @@ postgres: true ``` +* Keter can be configured to connect to a remote postgres server using the following syntax: +```yaml +plugins: + postgres: + - server: remoteServerNameOrIP + port: 1234 +``` + +Different webapps can be configured to use different servers using the above syntax. +It should be noted that keter will prioritize it's own postgres.yaml record for an app. +So if moving an existing app from a local postgres server to a remote one (or +switching remote servers), the postgres.yaml file will need to be updated manually. + +Keter will connect to the remote servers using the `postgres` account. This setup +assumes the remote server's `pg_hba.conf` file has been configured to allow connections +from the keter-server IP using the `trust` method. + (Note: The `plugins` configuration option was added in v1.0 of the -keter configuration syntax. If you are using v0.4 then use `postgres: true`.) +keter configuration syntax. If you are using v0.4 then use `postgres: true`. +The remote-postgres server syntax was added in v1.4.2.) * Modify your application to get its database connection settings from the following environment variables: * `PGHOST` @@ -258,3 +276,12 @@ or something like it, you may need to provide valid SSL certificates and keys or disable HTTPS, by uncommenting the key and certificate lines from `/opt/keter/etc/keter-config.yaml`. + + +## Contributing + +If you are interested in contributing, see +https://github.com/snoyberg/keter/blob/master/incoming/README.md for a +complete testing workflow. If you have any questions, you can open an +issue in the issue tracker, ask on the #yesod freenode irc channel, or +send an email to yesodweb@googlegroups.com. diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -1,5 +1,5 @@ Name: keter -Version: 1.4.1 +Version: 1.4.2.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/