PostgreSQL

Keter/App.hs

@@ -27,11 +27,13 @@ import Control.Exception (try, SomeException, onException)
 import System.IO (hClose)
 import System.Directory (removeDirectoryRecursive)
 import Control.Monad (when)
+import Data.Text (unpack)
 
 data Config = Config
     { configExec :: FilePath
     , configArgs :: [String]
     , configHost :: String
+    , configPostgres :: Bool
     }
 
 instance FromJSON Config where
@@ -39,6 +41,7 @@ instance FromJSON Config where
         <$> o .: "exec"
         <*> o .:? "args" .!= []
         <*> o .: "host"
+        <*> o .:? "postgres" .!= False
     parseJSON _ = fail "Wanted an object"
 
 data Command = Reload | Terminate
@@ -70,11 +73,12 @@ unpackBundle tf bundle appname = tryM $ do
 
 start :: TempFolder
       -> Nginx
+      -> Postgres
       -> Appname
       -> FilePath -- ^ app bundle
       -> IO () -- ^ action to perform to remove this App from list of actives
       -> IO (App, IO ())
-start tf nginx appname bundle removeFromList = do
+start tf nginx postgres appname bundle removeFromList = do
     chan <- C.newChan
     return (App $ C.writeChan chan, rest chan)
   where
@@ -82,12 +86,25 @@ start tf nginx appname bundle removeFromList = do
 
     runApp port dir config = do
         setFileMode (dir F.</> "config" F.</> configExec config) ownerExecuteMode
+        otherEnv <-
+            if configPostgres config
+                then do
+                    dbi <- getInfo postgres appname
+                    return
+                        [ ("PGHOST", "localhost")
+                        , ("PGPORT", "5432")
+                        , ("PGUSER", unpack $ dbiUser dbi)
+                        , ("PGPASS", unpack $ dbiPass dbi)
+                        , ("PGDATABASE", unpack $ dbiName dbi)
+                        ]
+                else return []
         run
             ("config" F.</> configExec config)
             dir
             (configArgs config)
-            [ ("PORT", show port)
-            ]
+            $ ("PORT", show port)
+            : ("APPROOT", "http://" ++ configHost config)
+            : otherEnv
 
     rest chan = void $ forkIO $ do
         mres <- unpackBundle tf bundle appname

Keter/Main.hs

@@ -5,6 +5,7 @@ module Keter.Main
 import qualified Keter.Nginx as Nginx
 import qualified Keter.TempFolder as TempFolder
 import qualified Keter.App as App
+import qualified Keter.Postgres as Postgres
 
 import Data.Default (def)
 import System.FilePath ((</>), takeBaseName)
@@ -22,6 +23,7 @@ keter :: FilePath -- ^ root directory, with incoming, temp, and etc folders
 keter dir = do
     nginx <- Nginx.start def
     tf <- TempFolder.setup $ dir </> "temp"
+    postgres <- Postgres.load def $ dir </> "etc" </> "postgres.yaml"
 
     mappMap <- M.newMVar Map.empty
     let removeApp appname = M.modifyMVar_ mappMap $ return . Map.delete appname
@@ -33,7 +35,7 @@ keter dir = do
                         App.reload app
                         return (appMap, return ())
                     Nothing -> do
-                        (app, rest) <- App.start tf nginx appname bundle $ removeApp appname
+                        (app, rest) <- App.start tf nginx postgres appname bundle $ removeApp appname
                         let appMap' = Map.insert appname app appMap
                         return (appMap', rest)
             rest

Keter/Postgres.hs

@@ -27,7 +27,8 @@ import Control.Monad.Trans.Class (lift)
 import Control.Applicative ((<$>), (<*>))
 import qualified System.Random as R
 import Data.Monoid (Monoid, mappend)
-import System.Directory (renameFile)
+import System.Directory (renameFile, createDirectoryIfMissing)
+import System.FilePath (takeDirectory)
 import Data.Text.Lazy.Builder (toLazyText, fromText)
 import qualified Data.Text.Lazy as TL
 import System.Process (readProcess)
@@ -102,6 +103,7 @@ data Command = GetConfig Appname (DBInfo -> IO ())
 -- automatically be saved to this file.
 load :: Settings -> FilePath -> IO Postgres
 load Settings{..} fp = do
+    createDirectoryIfMissing True $ takeDirectory fp
     e <- doesFileExist fp
     mdb <-
         if e

Keter/Process.hs

@@ -23,6 +23,9 @@ run exec dir args env = do
                 case status of
                     NoRestart -> return (NoRestart, return ())
                     _ -> do
+                        -- FIXME put in some kind of rate limiting: if we last
+                        -- tried to restart within five second, wait an extra
+                        -- five seconds
                         (_, _, _, ph) <- SP.createProcess cp
                         putStrLn "Process created"
                         return (Running ph, SP.waitForProcess ph >> loop)