module Gargoyle.PostgreSQL where
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Search as BS
import Data.Function
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import System.Directory
import System.Exit
import System.IO
import System.Posix.Signals
import System.Process
import System.Process.Internals
import Gargoyle
defaultPostgres :: Gargoyle ProcessHandle ByteString
defaultPostgres = mkPostgresGargoyle "initdb" "postgres" shutdownPostgresFast
mkPostgresGargoyle :: FilePath
-> FilePath
-> (ProcessHandle -> IO ())
-> Gargoyle ProcessHandle ByteString
mkPostgresGargoyle initdbPath postgresPath shutdownFun = Gargoyle
{ _gargoyle_exec = "gargoyle-postgres-monitor"
, _gargoyle_init = initLocalPostgres initdbPath
, _gargoyle_start = startLocalPostgres postgresPath
, _gargoyle_stop = shutdownFun
, _gargoyle_getInfo = getLocalPostgresConnectionString
}
initLocalPostgres :: FilePath
-> FilePath
-> IO ()
initLocalPostgres binPath dbDir = do
(_, _, _, initdb) <- runInteractiveProcess binPath
[ "-D", dbDir
, "-U", "postgres"
, "--no-locale"
, "-E", "UTF8"
] Nothing Nothing
ExitSuccess <- waitForProcess initdb
return ()
getLocalPostgresConnectionString :: FilePath -> IO ByteString
getLocalPostgresConnectionString dbDir = do
absoluteDbDir <- makeAbsolute dbDir
return $ mconcat $
[ "postgresql://postgres@"
, (LBS.toStrict $ BS.replace "/" ("%2F" :: LBS.ByteString) $ T.encodeUtf8 $ T.pack absoluteDbDir)
, "/postgres"
]
startLocalPostgres :: FilePath
-> FilePath
-> IO ProcessHandle
startLocalPostgres binPath dbDir = do
absoluteDbDir <- makeAbsolute dbDir
(_, _, err, postgres) <- runInteractiveProcess binPath
[ "-h", ""
, "-D", absoluteDbDir
, "-k", absoluteDbDir
] Nothing Nothing
fix $ \loop -> do
l <- hGetLine err
let (tag, rest) = span (/= ':') l
when (tag /= "LOG") $ fail $ "startLocalPostgres: Unexpected output from postgres: " <> show l
when (rest /= ": database system is ready to accept connections") loop
return postgres
shutdownPostgresSmart :: ProcessHandle
-> IO ()
shutdownPostgresSmart postgres = do
terminateProcess postgres
_ <- waitForProcess postgres
return ()
shutdownPostgresFast :: ProcessHandle
-> IO ()
shutdownPostgresFast postgres = do
withProcessHandle postgres $ \p -> do
case p of
ClosedHandle _ -> return ()
OpenHandle h -> signalProcess sigINT h
_ <- waitForProcess postgres
return ()
psqlLocal :: Gargoyle pid ByteString
-> FilePath
-> FilePath
-> Maybe String
-> IO ()
psqlLocal g psqlPath dbPath minput = withGargoyle g dbPath $ \dbUri -> do
void $ installHandler keyboardSignal Ignore Nothing
let psqlProc = (proc psqlPath [ T.unpack $ T.decodeUtf8 dbUri ])
{ std_in = case minput of
Nothing -> Inherit
Just _ -> CreatePipe
, std_out = Inherit
, std_err = Inherit
}
(mStdin, _, _, psql) <- createProcess psqlProc
case minput of
Nothing -> return ()
Just input -> hPutStrLn (fromJust mStdin) (input ++ "\n\\q")
ExitSuccess <- waitForProcess psql
return ()