module Database.PostgreSQL.Devel (
createLocalDB, configLocalDB, startLocalDB
, initLocalDB, stopLocalDB, setLocalDB
, withTempDB
, resetConnection
) where
import Control.Exception
import Control.Monad
#if __GLASGOW_HASKELL__ < 710
import Data.Functor
#endif
import Data.List
import Database.PostgreSQL.Simple
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error
import System.Posix.Env
import System.Posix.Temp
import System.Process
isNonEmptyDir :: FilePath -> IO Bool
isNonEmptyDir dir =
catchJust (\e -> if isDoesNotExistError e then Just () else Nothing)
((> 2) . length <$> getDirectoryContents dir)
(const $ return False)
addDirectives :: [(String, String)] -> [String] -> [String]
addDirectives directives [] = map snd directives
addDirectives directives (cl:cls)
| Just l <- lookup directive directives =
(if comment then [l, cl] else [l]) ++
addDirectives (directives \\ [(directive,l)]) cls
| otherwise = cl : addDirectives directives cls
where (comment, directive)
| '#':clr <- cl, [(d,_)] <- lex clr = (True, d)
| [(d,_)] <- lex cl = (False, d)
| otherwise = (False, "")
configLocalDB :: FilePath -> [(String, String)] -> IO ()
configLocalDB dir directives = do
let confpath = dir </> "postgresql.conf"
oldconf <- lines <$> readFile confpath
let conf = unlines $ addDirectives directives oldconf
length conf `seq` writeFile confpath conf
singleQuote :: String -> String
singleQuote ('\'':t) = "''" ++ singleQuote t
singleQuote (h:t) = h : singleQuote t
singleQuote [] = ""
pgDirectives :: FilePath -> [(String, String)]
pgDirectives dir = [
("unix_socket_directories"
, "unix_socket_directories = '" ++ singleQuote dir ++ "'")
, ("logging_collector", "logging_collector = yes")
, ("listen_addresses", "listen_addresses = ''")]
pgDirectives92 :: FilePath -> [(String, String)]
pgDirectives92 dir = map depluralize $ pgDirectives dir
where depluralize ("unix_socket_directories", _) =
("unix_socket_directory"
, "unix_socket_directory = '" ++ singleQuote dir ++ "'")
depluralize kv = kv
createLocalDB :: FilePath -> IO ()
createLocalDB dir = do
(exit, _, err) <- readProcessWithExitCode "pg_ctl"
["-D", dir, "-o", "--no-locale", "init"] ""
when (exit /= ExitSuccess) $ fail err
dir' <- canonicalizePath dir
writeFile (dir </> "README_BEFORE_DELETING") $
"## IMPORTANT: Run the following command before deleting this " ++
"directory ##\n\n" ++
"pg_ctl -D " ++ showCommandForUser dir' [] ++ " stop -m immediate\n\n"
version <- readFile (dir </> "PG_VERSION")
case reads version of
[(v, _)] | v < (9.3 :: Double) -> configLocalDB dir $ pgDirectives92 dir'
_ -> configLocalDB dir $ pgDirectives dir'
systemNoStdout :: String -> [String] -> IO ExitCode
systemNoStdout prog args =
bracket (openFile "/dev/null" ReadWriteMode) hClose $ \devnull -> do
let cp = (proc prog args) { std_in = UseHandle devnull
, std_out = UseHandle devnull }
(_,_,_,pid) <- createProcess cp
waitForProcess pid
startLocalDB :: FilePath -> IO ConnectInfo
startLocalDB dir0 = do
dir <- canonicalizePath dir0
(e0, _, _) <- readProcessWithExitCode "pg_ctl" ["status", "-D", dir] ""
when (e0 /= ExitSuccess) $ do
e1 <- systemNoStdout "pg_ctl" [ "start", "-w", "-D", dir ]
when (e1 /= ExitSuccess) $ fail "could not start postgres"
return defaultConnectInfo { connectHost = dir
, connectUser = ""
, connectDatabase = "postgres"
}
initLocalDB :: FilePath -> IO ConnectInfo
initLocalDB dir = do
exists <- isNonEmptyDir dir
unless exists $ createLocalDB dir
startLocalDB dir
stopLocalDB :: FilePath -> IO ()
stopLocalDB dir0 = do
dir <- if not (null dir0) then return dir0 else do
mpgd <- getEnv "PGDATA"
case mpgd of Just pgd -> return pgd
_ -> fail "stopLocalDB: must specify database"
e <- systemNoStdout "pg_ctl" ["stop", "-D", dir, "-m", "fast"]
when (e /= ExitSuccess) $ fail "could not stop postgres"
setLocalDB :: FilePath -> IO String
setLocalDB dir0 = do
dir1 <- canonicalizePath dir0
setEnv "PGHOST" dir1 True
setEnv "PGDATA" dir1 True
setEnv "PGDATABASE" "postgres" True
let dir = showCommandForUser dir1 []
msh <- getEnv "SHELL"
return $ case msh of Just sh | isSuffixOf "csh" sh ->
"setenv PGDATA " ++ dir ++ "; setenv PGHOST " ++ dir
_ -> "export PGDATA=" ++ dir ++ " PGHOST=" ++ dir
withTempDB :: (ConnectInfo -> IO a) -> IO a
withTempDB f = bracket createdir removeDirectoryRecursive $ \d ->
flip finally (stopLocalDB d) $ do
createLocalDB d
configLocalDB d [("fsync", "fsync = off")
, ("synchronous_commit", "synchronous_commit = off")
, ("full_page_writes", "full_page_writes = off")]
initLocalDB d >>= f
where createdir = do
tmp <- getTemporaryDirectory
mkdtemp $ tmp </> "db."
resetConnection :: Connection -> IO ()
resetConnection c = (void $ execute_ c "DISCARD ALL") `catch` \SqlError{} ->
void $ execute_ c "ROLLBACK" >> execute_ c "DISCARD ALL"