Added Postgres module

.gitignore

@@ -3,3 +3,4 @@ nginx.conf
 dist/
 process.txt
 process2.txt
+postgres.yaml

Keter/Postgres.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Keter.Postgres
+    ( -- * Types
+      Appname
+    , DBInfo (..)
+    , Postgres
+      -- * Functions
+    , load
+    , getInfo
+    ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Yaml
+import qualified Data.Map as Map
+import System.Directory (doesFileExist)
+import Control.Concurrent (forkIO)
+import qualified Control.Concurrent.Chan as C
+import qualified Control.Concurrent.MVar as M
+import Control.Monad (forever, mzero, replicateM)
+import qualified Control.Monad.Trans.State as S
+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 Data.Text.Lazy.Builder (toLazyText, fromText)
+import qualified Data.Text.Lazy as TL
+import System.Process (readProcess)
+
+(<>) :: Monoid m => m -> m -> m
+(<>) = mappend
+
+-- | Name of the application. Should just be the basename of the application
+-- file.
+type Appname = Text
+
+-- | Information on an individual PostgreSQL database.
+data DBInfo = DBInfo
+    { dbiName :: Text
+    , dbiUser :: Text
+    , dbiPass :: Text
+    }
+    deriving Show
+
+randomDBI :: R.StdGen -> (DBInfo, R.StdGen)
+randomDBI =
+    S.runState (DBInfo <$> rt <*> rt <*> rt)
+  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
+        ]
+
+instance FromJSON DBInfo where
+    parseJSON (Object o) = DBInfo
+        <$> o .: "name"
+        <*> o .: "user"
+        <*> o .: "pass"
+    parseJSON _ = mzero
+
+-- | Abstract type allowing access to config information via 'getInfo'
+newtype Postgres = Postgres
+    { getInfo :: Appname -> IO DBInfo
+    -- ^ Get information on an individual app\'s database information. If no
+    -- information exists, it will create a random database, add it to the
+    -- config file, and return it.
+    }
+
+data Command = GetConfig Appname (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.
+load :: FilePath -> IO Postgres
+load fp = do
+    e <- doesFileExist fp
+    mdb <-
+        if e
+            then decodeFile fp
+            else return $ Just Map.empty
+    db0 <-
+        case mdb of
+            Nothing -> error $ "Unable to parse Postgres file: " ++ show fp
+            Just db -> return db
+    chan <- C.newChan
+    g0 <- R.newStdGen
+    _ <- forkIO $ flip S.evalStateT (db0, g0) $ forever $ do
+        GetConfig appname f <- lift $ C.readChan chan
+        (db, g) <- S.get
+        dbi <-
+            case Map.lookup appname db of
+                Just dbi -> return dbi
+                Nothing -> do
+                    let (dbi', g') = randomDBI g
+                    let dbi = dbi'
+                            { dbiName = T.append appname $ dbiName dbi'
+                            , dbiUser = T.append appname $ dbiUser dbi'
+                            }
+                    -- FIXME: create in db itself
+                    let sql = toLazyText $
+                            "CREATE USER "         <> fromText (dbiUser dbi) <>
+                            " PASSWORD '"          <> fromText (dbiPass dbi) <>
+                            "';\nCREATE DATABASE " <> fromText (dbiName dbi) <>
+                            " OWNER "              <> fromText (dbiUser dbi) <>
+                            ";"
+                    _ <- lift $ readProcess "sudo" ["-u", "postgres", "psql"] $ TL.unpack sql
+                    let db' = Map.insert appname dbi db
+                    lift $ encodeFile tmpfp db'
+                    lift $ renameFile tmpfp fp
+                    S.put (db', g')
+                    return dbi
+        lift $ f dbi
+    return $ Postgres $ \appname -> do
+        x <- M.newEmptyMVar
+        C.writeChan chan $ GetConfig appname $ M.putMVar x
+        M.takeMVar x
+  where
+    tmpfp = fp ++ ".tmp"

keter.cabal

@@ -15,13 +15,17 @@ Library
   Build-depends:       base                      >= 4             && < 5
                      , directory
                      , bytestring
+                     , text
                      , containers
                      , transformers
                      , process
+                     , random
                      , data-default
                      , blaze-builder             >= 0.3           && < 0.4
+                     , yaml                      >= 0.7           && < 0.8
   Exposed-Modules:     Keter.Nginx
                        Keter.Process
+                       Keter.Postgres
   ghc-options:         -Wall -Werror
 
 Executable keter

test/postgres.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Keter.Postgres
+
+main :: IO ()
+main = do
+    pg <- load "postgres.yaml"
+
+    getInfo pg "foo" >>= print
+    getInfo pg "bar" >>= print
+    getInfo pg "foo" >>= print
+    getInfo pg "bar" >>= print