diff --git a/Keter/Plugin/Postgres.hs b/Keter/Plugin/Postgres.hs index 8781f42..e243f57 100644 --- a/Keter/Plugin/Postgres.hs +++ b/Keter/Plugin/Postgres.hs @@ -8,7 +8,7 @@ module Keter.Plugin.Postgres , 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 qualified Data.Char as C 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 @@ instance Default Settings where "';\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,9 +98,21 @@ instance FromJSON DBInfo where <$> 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 @@ -104,24 +136,29 @@ load Settings{..} fp = do 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 @@ edbiToEnv :: Either SomeException DBInfo -> 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/README.md b/README.md old mode 100644 new mode 100755 index 7204168..c1c44ea --- a/README.md +++ b/README.md @@ -179,8 +179,26 @@ plugins: 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` diff --git a/incoming/foo1_0/config/keter.yaml b/incoming/foo1_0/config/keter.yaml index 14fe3a5..96a7b15 100644 --- a/incoming/foo1_0/config/keter.yaml +++ b/incoming/foo1_0/config/keter.yaml @@ -67,3 +67,7 @@ stanzas: plugins: #postgres: true +# Syntax for remote-DB server: +# postgres: +# - server: remoteServerNameOrIP +# port: 1234 diff --git a/keter.cabal b/keter.cabal index f09780b..d3d1516 100644 --- a/keter.cabal +++ b/keter.cabal @@ -1,5 +1,5 @@ Name: keter -Version: 1.4.1 +Version: 1.4.2 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/