Postgres uses Keter.Prelude

2024-12-14 17:12:46 +03:00 · 2012-05-14 12:26:20 +03:00 · 2012-05-14 12:26:20 +03:00 · faaba90547
commit faaba90547
parent 05b5dfeec2
4 changed files with 130 additions and 61 deletions
--- a/Keter/App.hs
+++ b/Keter/App.hs
@ -88,18 +88,26 @@ start tf nginx postgres appname bundle removeFromList = do

    runApp port dir config = do
        setFileMode (F.encodeString $ F.decodeString dir F.</> "config" F.</> configExec config) ownerExecuteMode
-        otherEnv <-
-            if configPostgres config
-                then do
-                    dbi <- getInfo postgres appname
-                    return
-                        [ ("PGHOST", "localhost")
-                        , ("PGPORT", "5432")
-                        , ("PGUSER", dbiUser dbi)
-                        , ("PGPASS", dbiPass dbi)
-                        , ("PGDATABASE", dbiName dbi)
-                        ]
-                else return []
+        otherEnv <- do
+            mdbi <-
+                if configPostgres config
+                    then do
+                        edbi <- Keter.Prelude.runKIO print $ getInfo postgres appname
+                        case edbi of
+                            Left e -> do
+                                Keter.Prelude.runKIO print $ Keter.Prelude.log $ Keter.Prelude.ExceptionThrown e
+                                return Nothing
+                            Right dbi -> return $ Just dbi
+                    else return Nothing
+            return $ case mdbi of
+                Just dbi ->
+                    [ ("PGHOST", "localhost")
+                    , ("PGPORT", "5432")
+                    , ("PGUSER", dbiUser dbi)
+                    , ("PGPASS", dbiPass dbi)
+                    , ("PGDATABASE", dbiName dbi)
+                    ]
+                Nothing -> []
        runKIO $ run
            ("config" F.</> configExec config)
            (F.decodeString dir)
--- a/Keter/Main.hs
+++ b/Keter/Main.hs
@ -28,7 +28,8 @@ keter dir = do
    nginx <- Nginx.start def
    etf <- Keter.Prelude.runKIO print $ TempFolder.setup $ F.decodeString dir F.</> "temp"
    tf <- either throwIO return etf
-    postgres <- Postgres.load def $ dir </> "etc" </> "postgres.yaml"
+    epostgres <- Keter.Prelude.runKIO print $ Postgres.load def $ F.decodeString $ dir </> "etc" </> "postgres.yaml"
+    postgres <- either throwIO return epostgres

    mappMap <- M.newMVar Map.empty
    let removeApp appname = M.modifyMVar_ mappMap $ return . Map.delete appname
--- a/Keter/Postgres.hs
+++ b/Keter/Postgres.hs
@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 module Keter.Postgres
    ( -- * Types
      Appname
@ -13,32 +14,23 @@ module Keter.Postgres
    , getInfo
    ) where

-import Data.Text (Text)
+import Keter.Prelude
+import qualified Prelude as P
 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, createDirectoryIfMissing)
-import System.FilePath (takeDirectory)
-import Data.Text.Lazy.Builder (toLazyText, fromText)
+import Data.Text.Lazy.Builder (toLazyText)
 import qualified Data.Text.Lazy as TL
 import System.Process (readProcess)
 import Data.Default (Default (def))

-(<>) :: Monoid m => m -> m -> m
-(<>) = mappend
-
 data Settings = Settings
-    { setupDBInfo :: DBInfo -> IO ()
+    { setupDBInfo :: DBInfo -> P.IO ()
      -- ^ How to create the given user/database. Default: uses the @psql@
      -- command line tool and @sudo -u postgres@.
    }
@ -47,10 +39,10 @@ instance Default Settings where
    def = Settings
        { setupDBInfo = \DBInfo{..} -> do
            let sql = toLazyText $
-                    "CREATE USER "         <> fromText dbiUser <>
-                    " PASSWORD '"          <> fromText dbiPass <>
-                    "';\nCREATE DATABASE " <> fromText dbiName <>
-                    " OWNER "              <> fromText dbiUser <>
+                    "CREATE USER "         ++ fromText dbiUser ++
+                    " PASSWORD '"          ++ fromText dbiPass ++
+                    "';\nCREATE DATABASE " ++ fromText dbiName ++
+                    " OWNER "              ++ fromText dbiUser ++
                    ";"
            _ <- readProcess "sudo" ["-u", "postgres", "psql"] $ TL.unpack sql
            return ()
@ -90,53 +82,64 @@ instance FromJSON DBInfo where

 -- | Abstract type allowing access to config information via 'getInfo'
 newtype Postgres = Postgres
-    { getInfo :: Appname -> IO DBInfo
+    { getInfo :: Appname -> KIO (Either SomeException 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 ())
+data Command = GetConfig Appname (Either SomeException DBInfo -> KIO ())

 -- | 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 :: Settings -> FilePath -> IO Postgres
+load :: Settings -> FilePath -> KIO (Either SomeException Postgres)
 load Settings{..} fp = do
-    createDirectoryIfMissing True $ takeDirectory fp
-    e <- doesFileExist fp
-    mdb <-
+    mdb <- liftIO $ do
+        createTree $ directory fp
+        e <- isFile fp
        if e
-            then decodeFile fp
+            then decodeFile $ toString 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
+    case mdb of
+        Left e -> return $ Left e
+        Right Nothing -> return $ Left $ toException $ CannotParsePostgres fp
+        Right (Just db0) -> go (db0 :: Map.Map Appname DBInfo)
+  where
+    go db0 = do
+        chan <- newChan
+        g0 <- newStdGen
+        forkKIO $ flip S.evalStateT (db0, g0) $ forever $ loop chan
+        return $ Right $ Postgres $ \appname -> do
+            x <- newEmptyMVar
+            writeChan chan $ GetConfig appname $ putMVar x
+            takeMVar x
+
+    tmpfp = fp <.> "tmp"
+
+    loop chan = do
+        GetConfig appname f <- lift $ readChan chan
        (db, g) <- S.get
        dbi <-
            case Map.lookup appname db of
-                Just dbi -> return dbi
+                Just dbi -> return $ Right dbi
                Nothing -> do
                    let (dbi', g') = randomDBI g
                    let dbi = dbi'
-                            { dbiName = T.append appname $ dbiName dbi'
-                            , dbiUser = T.append appname $ dbiUser dbi'
+                            { dbiName = appname ++ dbiName dbi'
+                            , dbiUser = appname ++ dbiUser dbi'
                            }
-                    lift $ setupDBInfo dbi
-                    let db' = Map.insert appname dbi db
-                    lift $ encodeFile tmpfp db'
-                    lift $ renameFile tmpfp fp
-                    S.put (db', g')
-                    return dbi
+                    ex <- lift $ liftIO $ setupDBInfo dbi
+                    case ex of
+                        Left e -> return $ Left e
+                        Right () -> do
+                            let db' = Map.insert appname dbi db
+                            ey <- lift $ liftIO $ do
+                                encodeFile (toString tmpfp) db'
+                                rename tmpfp fp
+                            case ey of
+                                Left e -> return $ Left e
+                                Right () -> do
+                                    S.put (db', g')
+                                    return $ Right 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"
--- a/Keter/Prelude.hs
+++ b/Keter/Prelude.hs
@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 module Keter.Prelude
    ( T.Text
    , String
@ -16,6 +17,7 @@ module Keter.Prelude
    , (A.***)
    , readFileLBS
    , P.Either (..)
+    , P.either
    , E.SomeException
    , runKIO
    , void
@ -26,22 +28,39 @@ module Keter.Prelude
    , P.succ
    , show
    , Control.Monad.when
+    , fromText
+    , P.flip
+    , P.Show
+    , KeterException (..)
+    , E.toException
+    , newStdGen
      -- * Filepath
    , (F.</>)
-    , F.fromText
+    , (F.<.>)
    , F.FilePath
    , F.isDirectory
+    , F.isFile
    , F.removeTree
    , F.createTree
+    , F.directory
+    , F.rename
      -- * MVar
    , M.MVar
    , newMVar
+    , newEmptyMVar
    , modifyMVar
    , swapMVar
+    , takeMVar
+    , putMVar
      -- * IORef
    , I.IORef
    , newIORef
    , atomicModifyIORef
+      -- * Chan
+    , C.Chan
+    , newChan
+    , readChan
+    , writeChan
    ) where

 import qualified Filesystem.Path.CurrentOS as F
@ -58,6 +77,10 @@ import qualified Control.Concurrent.MVar as M
 import Control.Concurrent (forkIO)
 import qualified Data.IORef as I
 import Data.Monoid (Monoid, mappend)
+import qualified Data.Text.Lazy.Builder as B
+import Data.Typeable (Typeable)
+import qualified Control.Concurrent.Chan as C
+import qualified System.Random as R

 type String = T.Text

@ -118,12 +141,21 @@ runKIO f (KIO g) = g f
 newMVar :: a -> KIO (M.MVar a)
 newMVar = liftIO_ . M.newMVar

+newEmptyMVar :: KIO (M.MVar a)
+newEmptyMVar = liftIO_ M.newEmptyMVar
+
 modifyMVar :: M.MVar a -> (a -> KIO (a, b)) -> KIO b
 modifyMVar m f = KIO $ \x -> M.modifyMVar m (\a -> unKIO (f a) x)

 swapMVar :: M.MVar a -> a -> KIO a
 swapMVar m = liftIO_ . M.swapMVar m

+takeMVar :: M.MVar a -> KIO a
+takeMVar = liftIO_ . M.takeMVar
+
+putMVar :: M.MVar a -> a -> KIO ()
+putMVar m = liftIO_ . M.putMVar m
+
 forkKIO :: KIO () -> KIO ()
 forkKIO f = do
    x <- KIO P.return
@ -140,3 +172,28 @@ atomicModifyIORef x = liftIO_ . I.atomicModifyIORef x

 show :: P.Show a => a -> T.Text
 show = T.pack . P.show
+
+class FromText a where
+    fromText :: T.Text -> a
+instance FromText T.Text where
+    fromText = P.id
+instance FromText F.FilePath where
+    fromText = F.fromText
+instance FromText B.Builder where
+    fromText = B.fromText
+
+data KeterException = CannotParsePostgres F.FilePath
+    deriving (P.Show, Typeable)
+instance E.Exception KeterException
+
+newChan :: KIO (C.Chan a)
+newChan = liftIO_ C.newChan
+
+newStdGen :: KIO R.StdGen
+newStdGen = liftIO_ R.newStdGen
+
+readChan :: C.Chan a -> KIO a
+readChan = liftIO_ . C.readChan
+
+writeChan :: C.Chan a -> a -> KIO ()
+writeChan c = liftIO_ . C.writeChan c