Merge pull request #105 from bermanjosh/remote-postgres

Remote postgres

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)
     ]
+

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`

incoming/foo1_0/config/keter.yaml

@@ -67,3 +67,7 @@ stanzas:
 
 plugins:
     #postgres: true
+# Syntax for remote-DB server:    
+#    postgres: 
+#       - server: remoteServerNameOrIP
+#         port: 1234

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