module Database.Postgres.Temp.Internal where
import System.IO.Temp
import System.Process
import System.Process.Internals
import Control.Concurrent
import System.IO
import System.Exit
import System.Directory
import Network.Socket
import Control.Exception
import Data.Typeable
import System.Posix.Signals
openFreePort :: IO Int
openFreePort = bracket (socket AF_INET Stream defaultProtocol) close $ \s -> do
localhost <- inet_addr "127.0.0.1"
bind s (SockAddrInet aNY_PORT localhost)
listen s 1
fmap fromIntegral $ socketPort s
waitForDB :: FilePath -> Int -> IO ()
waitForDB mainDir port
= handle (\(_ :: IOException) -> threadDelay 10000 >> waitForDB mainDir port)
$ do bracket
(socket AF_UNIX Stream 0)
close
$ \sock -> connect sock
$ SockAddrUnix
$ mainDir ++ "/.s.PGSQL." ++ show port
data DB = DB
{ mainDir :: FilePath
, connectionString :: String
, pid :: ProcessHandle
}
start :: [(String, String)]
-> IO (Either StartError DB)
start options = startWithHandles options stdout stderr
fourth :: (a, b, c, d) -> d
fourth (_, _, _, x) = x
procWith :: Handle -> Handle -> String -> [String] -> CreateProcess
procWith stdOut stdErr cmd args =
(proc cmd args)
{ std_err = UseHandle stdErr
, std_out = UseHandle stdOut
}
config :: FilePath -> String
config mainDir = unlines
[ "listen_addresses = ''"
, "shared_buffers = 12MB"
, "fsync = off"
, "synchronous_commit = off"
, "full_page_writes = off"
, "log_min_duration_statement = 0"
, "log_connections = on"
, "log_disconnections = on"
, "unix_socket_directories = '" ++ mainDir ++ "'"
, "client_min_messages = ERROR"
]
data StartError
= InitDBFailed ExitCode
| CreateDBFailed ExitCode
deriving (Show, Eq, Typeable)
instance Exception StartError
throwIfError :: (ExitCode -> StartError) -> ExitCode -> IO ()
throwIfError f e = case e of
ExitSuccess -> return ()
_ -> throwIO $ f e
pidString :: ProcessHandle -> IO String
pidString phandle = withProcessHandle phandle (\case
OpenHandle p -> return $ show p
ClosedHandle _ -> return ""
)
runProcessWith :: Handle -> Handle -> String -> String -> [String] -> IO ExitCode
runProcessWith stdOut stdErr name cmd args
= createProcess_ name (procWith stdOut stdErr cmd args)
>>= waitForProcess . fourth
startWithHandles :: [(String, String)]
-> Handle
-> Handle
-> IO (Either StartError DB)
startWithHandles options stdOut stdErr = do
mainDir <- createTempDirectory "/tmp" "tmp-postgres"
startWithHandlesAndDir options mainDir stdOut stdErr
startWithHandlesAndDir :: [(String, String)]
-> FilePath
-> Handle
-> Handle
-> IO (Either StartError DB)
startWithHandlesAndDir = startWithLogger $ \_ -> return ()
data Event
= InitDB
| WriteConfig
| FreePort
| StartPostgres
| WaitForDB
| CreateDB
| Finished
deriving (Show, Eq, Enum, Bounded, Ord)
rmDirIgnoreErrors :: FilePath -> IO ()
rmDirIgnoreErrors mainDir =
removeDirectoryRecursive mainDir `catch` (\(_ :: IOException) -> return ())
startWithLogger :: (Event -> IO ())
-> [(String, String)]
-> FilePath
-> Handle
-> Handle
-> IO (Either StartError DB)
startWithLogger logger options mainDir stdOut stdErr = try $ flip onException (rmDirIgnoreErrors mainDir) $ do
let dataDir = mainDir ++ "/data"
logger InitDB
initDBExitCode <- runProcessWith stdOut stdErr "initdb"
"initdb" ["-E", "UNICODE", "-A", "trust", "-D", dataDir]
throwIfError InitDBFailed initDBExitCode
logger WriteConfig
writeFile (dataDir ++ "/postgresql.conf") $ config mainDir
logger FreePort
port <- openFreePort
let connectionString = "postgresql:///test?host=" ++ mainDir ++ "&port=" ++ show port
logger StartPostgres
let extraOptions = map (\(key, value) -> "--" ++ key ++ "=" ++ value) options
bracketOnError ( fmap (DB mainDir connectionString . fourth)
$ createProcess_ "postgres"
( procWith stdOut stdErr
"postgres"
$ ["-D", dataDir, "-p", show port] ++ extraOptions
)
)
stop
$ \result -> do
logger WaitForDB
waitForDB mainDir port
logger CreateDB
throwIfError CreateDBFailed =<<
runProcessWith stdOut stdErr "createDB"
"createdb" ["-h", mainDir, "-p", show port, "test"]
logger Finished
return result
startAndLogToTmp :: [(String, String)]
-> IO (Either StartError DB)
startAndLogToTmp options = do
mainDir <- createTempDirectory "/tmp" "tmp-postgres"
stdOutFile <- openFile (mainDir ++ "/" ++ "output.txt") WriteMode
stdErrFile <- openFile (mainDir ++ "/" ++ "error.txt") WriteMode
startWithHandlesAndDir options mainDir stdOutFile stdErrFile
stop :: DB -> IO ExitCode
stop DB {..} = do
withProcessHandle pid (\case
OpenHandle p -> signalProcess sigINT p
ClosedHandle _ -> return ()
)
result <- waitForProcess pid
removeDirectoryRecursive mainDir
return result