diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,16 +1,37 @@ [![Travis CI Status](https://travis-ci.org/jfischoff/tmp-postgres.svg?branch=master)](http://travis-ci.org/jfischoff/tmp-postgres) # tmp-postgres -`tmp-postgres` is a library for creating a temporary `postgres` instance on a random port for testing. +`tmp-postgres` provides functions creating a temporary @postgres@ instance. +By default it will create a temporary directory for the data, +a random port for listening and a temporary directory for a UNIX +domain socket. +Here is an example using the expection safe 'with' function: + ```haskell -result <- start [] -case result of - Left err -> print err - Right tempDB -> do - -- Do stuff - stop tempDB + with $ \db -> bracket (connectPostgreSQL (toConnectionString db)) close $ \conn -> + execute_ conn "CREATE TABLE foo (id int)" ``` + +To extend or override the defaults use `withPlan` (or `startWith`). + +`tmp-postgres` ultimately calls `initdb`, `postgres` and `createdb`. +All of the command line, environment variables and configuration files +that are generated by default for the respective executables can be +extended or overrided. + +All `tmp-postgres` by default is most useful for creating tests by +configuring "tmp-postgres" differently it can be used for other purposes. + +* By disabling `initdb` and `createdb` one could run a temporary +postgres on a base backup to test a migration. +* By using the `stopPostgres` and `withRestart` functions one can test +backup strategies. + +The level of custom configuration is extensive but with great power comes +ability to screw everything up. `tmp-postgres` doesn't validate any custom +configuration and one can easily create a `Config` that would not allow +postgres to start. # Installation diff --git a/src/Database/Postgres/Temp.hs b/src/Database/Postgres/Temp.hs --- a/src/Database/Postgres/Temp.hs +++ b/src/Database/Postgres/Temp.hs @@ -1,65 +1,101 @@ {-| -This module provides functions greating a temporary postgres instance on a random port for testing. +This module provides functions creating a temporary @postgres@ instance. +By default it will create a temporary directory for the data, +a random port for listening and a temporary directory for a UNIX +domain socket. +Here is an example using the expection safe 'with' function: + @ - result <- 'start' [] - case result of - Left err -> print err - Right tempDB -> do - -- Do stuff - 'stop' tempDB + 'with' $ \\db -> 'Control.Exception.bracket' ('PG.connectPostgreSQL' ('toConnectionString' db)) 'PG.close' $ \\conn -> + 'PG.execute_' conn "CREATE TABLE foo (id int)" @ -The are few different methods for starting @postgres@ which provide different -methods of dealing with @stdout@ and @stderr@. +To extend or override the defaults use `withPlan` (or `startWith`). -The start methods use a config based on the one used by [pg_tmp](http://ephemeralpg.org/), but can be overriden -by in different values to the first argument of the start functions. +@tmp-postgres@ ultimately calls @initdb@, @postgres@ and @createdb@. +All of the command line, environment variables and configuration files +that are generated by default for the respective executables can be +extended or overrided. +All @tmp-postgres@ by default is most useful for creating tests by +configuring "tmp-postgres" differently it can be used for other purposes. + +* By disabling @initdb@ and @createdb@ one could run a temporary +postgres on a base backup to test a migration. +* By using the 'stopPostgres' and 'withRestart' functions one can test +backup strategies. + +The level of custom configuration is extensive but with great power comes +ability to screw everything up. `tmp-postgres` doesn't validate any custom +configuration and one can easily create a `Config` that would not allow +postgres to start. + WARNING!! Ubuntu's PostgreSQL installation does not put @initdb@ on the @PATH@. We need to add it manually. The necessary binaries are in the @\/usr\/lib\/postgresql\/VERSION\/bin\/@ directory, and should be added to the @PATH@ > echo "export PATH=$PATH:/usr/lib/postgresql/VERSION/bin/" >> /home/ubuntu/.bashrc - - -} + module Database.Postgres.Temp - ( -- * Types + ( + -- * Main resource handle DB (..) - , StartError (..) - -- * Starting @postgres@ + -- * Exception safe interface -- $options + , with + , withPlan + -- * Separate start and stop interface. , start - , startLocalhost - , startAndLogToTmp - , startWithHandles - , Options(..) - , defaultOptions - , InitDbOptions(..) - , defaultInitDbOptions - -- * Stopping @postgres@ + , startWith , stop + , defaultConfig -- * Starting and Stopping postgres without removing the temporary directory - , startPostgres + , restart , stopPostgres + , withRestart -- * Reloading the config , reloadConfig + -- * DB manipulation + , toConnectionString + -- * Errors + , StartError (..) + -- * Configuration Types + , Config (..) + -- ** General extend or override monoid + , Lastoid (..) + -- ** Directory configuration + , DirectoryType (..) + , PartialDirectoryType (..) + -- ** Listening socket configuration , SocketClass (..) + , PartialSocketClass (..) + -- ** Process configuration + , PartialProcessConfig (..) + , ProcessConfig (..) + -- ** @postgres@ process configuration + , PartialPostgresPlan (..) + , PostgresPlan (..) + -- *** @postgres@ process handle. Includes the client options for connecting + , PostgresProcess (..) + -- ** Database plans. This is used to call @initdb@, @postgres@ and @createdb@ + , PartialPlan (..) + , Plan (..) + -- ** Top level configuration ) where import Database.Postgres.Temp.Internal +import Database.Postgres.Temp.Internal.Core +import Database.Postgres.Temp.Internal.Partial + {- $options -'startWithHandles' is the most general way to start postgres. It allows the user to -pass in it's own handles for @stdout@ and @stderr@. 'start' and 'startAndLogToTmp' -both call 'startWithHandles' passing in different handles. 'start' uses the current -process's @stdout@ and @stderr@ and 'startAndLogToTmp' logs to files in the 'mainDir'. @postgres@ is started with a default config with the following options: @ - listen_addresses = '' + shared_buffers = 12MB fsync = off synchronous_commit = off @@ -67,14 +103,42 @@ log_min_duration_statement = 0 log_connections = on log_disconnections = on - unix_socket_directories = {mainDir} + unix_socket_directories = {DATA_DIRECTORY} client_min_messages = ERROR @ - Any of the options can be overriden by passing in a different value when starting +Additionally if an IP address is provide the following line is added: @ - Right db <- 'start' [("log_min_duration_statement", "1000")] + listen_addresses = \'IP_ADDRESS\' @ + If a UNIX domain socket is specified the following is added: + + @ + listen_addresses = '' + unix_socket_directories = {DATA_DIRECTORY} + @ + +To add to \"postgresql.conf\" file create a custom 'Config' like the following: + + @ + let custom = defaultConfig <> mempty { configPlan = mempty + { partialPlanConfig = Mappend + [ "wal_level=replica" + , "archive_mode=on" + , "max_wal_senders=2" + , "fsync=on" + , "synchronous_commit=on" + ] + } + } + @ + + In general you'll want to 'mappend' a config to the 'defaultConfig'. + The 'defaultConfig' setups a database and connection options for + the created database. However if you want to extend the behavior + of @createdb@ you will probably have to create a 'Config' from + scratch to ensure the final parameter to @createdb@ is the + database name. -} diff --git a/src/Database/Postgres/Temp/Internal.hs b/src/Database/Postgres/Temp/Internal.hs --- a/src/Database/Postgres/Temp/Internal.hs +++ b/src/Database/Postgres/Temp/Internal.hs @@ -1,125 +1,46 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, ScopedTypeVariables, DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - +{-| +This module provides the high level functions that are re-exported +by @Database.Postgres.Temp@. Additionally it includes some +identifiers that are used for testing but are not exported. +-} module Database.Postgres.Temp.Internal where - -import Control.Concurrent (MVar, newMVar, threadDelay, withMVar) -import Control.Concurrent.Async (race_) -import Control.Exception (Exception, IOException, bracket, bracketOnError, catch, onException, throwIO, try) -import Control.Monad (forever, void) -import qualified Data.ByteString.Char8 as BSC -import Data.Foldable (for_) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.Maybe (catMaybes) -import Data.Typeable (Typeable) -import qualified Database.PostgreSQL.Simple as PG -import qualified Database.PostgreSQL.Simple.Options as Options -import GHC.Generics (Generic) -import qualified Network.Socket as N -import Network.Socket.Free (openFreePort) -import System.Directory (removeDirectoryRecursive) +import Database.Postgres.Temp.Internal.Core +import Database.Postgres.Temp.Internal.Partial +import Control.Exception +import Control.Monad (void) +import qualified Database.PostgreSQL.Simple.Options as PostgresClient +import qualified Database.PostgreSQL.Simple.PartialOptions as Client import System.Exit (ExitCode(..)) -import System.IO (Handle, IOMode(WriteMode), openFile, stderr, stdout) -import System.IO.Temp (createTempDirectory) -import System.Posix.Signals (sigHUP, sigINT, signalProcess) -import System.Process (getPid, getProcessExitCode, proc, waitForProcess) -import System.Process.Internals - ( CreateProcess - , ProcessHandle - , ProcessHandle__(..) - , StdStream(UseHandle) - , createProcess_ - , std_err - , std_out - , withProcessHandle - ) - -getFreePort :: IO Int -getFreePort = do - (port, socket) <- openFreePort - N.close socket - pure port - -waitForDB :: Options.Options -> IO () -waitForDB options = do - eresult <- try $ bracket (PG.connectPostgreSQL (Options.toConnectionString options)) PG.close $ \_ -> return () - case eresult of - Left (_ :: IOError) -> threadDelay 10000 >> waitForDB options - Right _ -> return () - --- A helper for dealing with locks -withLock :: MVar a -> IO b -> IO b -withLock m f = withMVar m (const f) +import Data.ByteString (ByteString) +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Class +import qualified Database.PostgreSQL.Simple as PG +-- | Handle for holding temporary resources, the @postgres@ process handle +-- and postgres connection information. The 'DB' also includes the +-- final 'Plan' that was used to start @initdb@, @createdb@ and +-- @postgres@. data DB = DB - { mainDir :: FilePath - -- ^ Temporary directory where the unix socket, logs and data directory live. - , options :: Options.Options - -- ^ PostgreSQL connection string. - , extraOptions :: [(String, String)] - -- ^ Additionally options passed to the postgres command line - , stdErr :: Handle - -- ^ The 'Handle' used to standard error - , stdOut :: Handle - -- ^ The 'Handle' used to standard output - , pidLock :: MVar () - -- ^ A lock used internally to makes sure access to 'pid' is serialized - , port :: Int - -- ^ The port postgres is listening on - , socketClass :: SocketClass - -- ^ The 'SocketClass' used for starting postgres - , pid :: IORef (Maybe ProcessHandle) - -- ^ The process handle for the @postgres@ process. + { dbResources :: Resources + -- ^ Temporary resources and the final 'Plan'. + , dbPostgresProcess :: PostgresProcess + -- ^ @postgres@ process handle and the connection options. } -connectionString :: DB -> String -connectionString = BSC.unpack . Options.toConnectionString . options - -data SocketClass = Localhost | Unix - deriving (Show, Eq, Read, Ord, Enum, Bounded, Generic, Typeable) - --- ^ -data Options = Options { - tmpDbName :: String - -- ^ The database name to use. Defaults to 'test' - , tmpInitDbOptions :: InitDbOptions - -- ^ Options to pass to initdb - , tmpCmdLineOptions :: [(String, String)] - -- ^ Extra options which override the defaults -} - -defaultOptions :: Options -defaultOptions = Options { - tmpDbName = "test" - , tmpInitDbOptions = defaultInitDbOptions - , tmpCmdLineOptions = [] -} - --- | start postgres and use the current processes stdout and stderr -start :: Options - -- ^ Extra options which override the defaults - -> IO (Either StartError DB) -start options = startWithHandles Unix options stdout stderr - --- | start postgres and use the current processes stdout and stderr --- but use TCP on localhost instead of a unix socket. -startLocalhost :: Options - -> IO (Either StartError DB) -startLocalhost options = startWithHandles Localhost 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 :: Maybe FilePath -> String -config mMainDir = unlines $ +-- | Convert a 'DB' to a connection string. Alternatively one can access the +-- 'PostgresClient.Options' using +-- @postgresProcessClientConfig . dbPostgresProcess@ +toConnectionString :: DB -> ByteString +toConnectionString + = PostgresClient.toConnectionString + . postgresProcessClientConfig + . dbPostgresProcess +------------------------------------------------------------------------------- +-- Life Cycle Management +------------------------------------------------------------------------------- +-- | Default postgres options +defaultPostgresConfig :: [String] +defaultPostgresConfig = [ "shared_buffers = 12MB" , "fsync = off" , "synchronous_commit = off" @@ -128,286 +49,131 @@ , "log_connections = on" , "log_disconnections = on" , "client_min_messages = ERROR" - ] ++ maybe ["listen_addresses = '127.0.0.1'"] (\x -> ["unix_socket_directories = '" ++ x ++ "'", "listen_addresses = ''"]) mMainDir - -data StartError - = InitDBFailed ExitCode - | CreateDBFailed [String] ExitCode - | StartPostgresFailed [String] ExitCode - | StartPostgresDisappeared [String] - 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 - OpenExtHandle {} -> return "" -- TODO log windows is not supported - 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 - --- | Start postgres and pass in handles for stdout and stderr -startWithHandles :: SocketClass - -> Options - -- ^ Extra options which override the defaults - -> Handle - -- ^ @stdout@ - -> Handle - -- ^ @stderr@ - -> IO (Either StartError DB) -startWithHandles socketClass options stdOut stdErr = do - mainDir <- createTempDirectory "/tmp" "tmp-postgres" - startWithHandlesAndDir socketClass options mainDir stdOut stdErr - -startWithHandlesAndDir :: SocketClass - -> Options - -> FilePath - -> Handle - -> Handle - -> IO (Either StartError DB) -startWithHandlesAndDir = startWithLogger $ \_ -> return () - --- | This error is thrown is 'startPostgres' is called twice without calling --- 'stopPostgres' first. -data AnotherPostgresProcessActive = AnotherPostgresProcessActive - deriving (Show, Eq, Typeable) - -instance Exception AnotherPostgresProcessActive - --- A helper that attempts to blocks until a connection can be made, throws --- 'StartPostgresFailed' if the postgres process fails or throws --- 'StartPostgresDisappeared' if the 'pid' somehow becomes 'Nothing'. -waitOnPostgres :: DB -> IO () -waitOnPostgres DB {..} = do - let postgresOptions = makePostgresOptions extraOptions (mainDir ++ "/data") port - checkForCrash = readIORef pid >>= \case - Nothing -> throwIO $ StartPostgresDisappeared postgresOptions - Just thePid -> do - mExitCode <- getProcessExitCode thePid - for_ mExitCode (throwIO . StartPostgresFailed postgresOptions) - waitForDB options `race_` - forever (checkForCrash >> threadDelay 100000) - --- | Send the SIGHUP signal to the postgres process to start a config reload -reloadConfig :: DB -> IO () -reloadConfig DB {..} = do - mHandle <- readIORef pid - for_ mHandle $ \theHandle -> do - mPid <- getPid theHandle - for_ mPid $ signalProcess sigHUP - --- | This throws 'AnotherPostgresProcessActive' if the postgres --- has not been stopped using 'stopPostgres'. --- This function attempts to the 'pidLock' before running. --- If postgres process fails this throws 'StartPostgresFailed'. --- If the postgres process becomes 'Nothing' while starting --- this function throws 'StartPostgresDisappeared'. -startPostgres :: DB -> IO () -startPostgres db@DB {..} = withLock pidLock $ - readIORef pid >>= \case - Just _ -> throwIO AnotherPostgresProcessActive - Nothing -> do - let postgresOptions = makePostgresOptions extraOptions (mainDir ++ "/data") port - bracketOnError - (runPostgres stdErr stdOut postgresOptions) - (const $ stopPostgres db) - $ \thePid -> do - writeIORef pid $ Just thePid - waitOnPostgres db - --- | Stop the postgres process. This function attempts to the 'pidLock' before running. --- 'stopPostgres' will terminate all connections before shutting down postgres. --- 'stopPostgres' is useful for testing backup strategies. -stopPostgres :: DB -> IO (Maybe ExitCode) -stopPostgres db@DB {..} = withLock pidLock $ readIORef pid >>= \case - Nothing -> pure Nothing - Just pHandle -> do - withProcessHandle pHandle (\case - OpenHandle p -> do - -- try to terminate the connects first. If we can't terminate still - -- keep shutting down - terminateConnections db - - signalProcess sigINT p - OpenExtHandle {} -> pure () -- TODO log windows is not supported - ClosedHandle _ -> return () - ) - - exitCode <- waitForProcess pHandle - writeIORef pid Nothing - pure $ Just exitCode - -makePostgresOptions :: [(String, String)] - -> FilePath - -> Int - -> [String] -makePostgresOptions options dataDir port = - let extraOptions = map (\(key, value) -> "--" ++ key ++ "=" ++ value) options - in ["-D", dataDir, "-p", show port] ++ extraOptions - -runPostgres :: Handle - -> Handle - -> [String] - -> IO ProcessHandle -runPostgres theStdOut theStdErr postgresOptions = - fmap fourth $ createProcess_ "postgres" $ - procWith theStdOut theStdErr "postgres" postgresOptions - -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 ()) - -> SocketClass - -> Options - -> FilePath - -> Handle - -> Handle - -> IO (Either StartError DB) -startWithLogger logger socketClass (Options {..}) mainDir stdOut stdErr = - try $ flip onException (rmDirIgnoreErrors mainDir) $ do - - let dataDir = mainDir ++ "/data" - - logger InitDB - initDBExitCode <- runProcessWith stdOut stdErr "initdb" - "initdb" $ initDbToCommandLingArgs tmpInitDbOptions { initDbPgData = Just dataDir } - throwIfError InitDBFailed initDBExitCode - - logger WriteConfig - writeFile (dataDir ++ "/postgresql.conf") $ config $ if socketClass == Unix then Just mainDir else Nothing + ] - logger FreePort - port <- getFreePort - -- slight race here, the port might not be free anymore! - let user = initDbUser tmpInitDbOptions - host = case socketClass of - Localhost -> "127.0.0.1" - Unix -> mainDir - let mkOptions dbName = (Options.defaultOptions dbName) { - Options.oHost = Just host - , Options.oPort = Just port - , Options.oUser = user +-- | The default configuration. This will create a database called \"test\" +-- and create a temporary directory for the data and a temporary directory +-- for a unix socket on a random port. +-- If you would like to customize this behavior you can start with the +-- 'defaultConfig' and overwrite fields or combine the 'Config' with another +-- config using '<>' ('mappend'). +-- If you would like complete control over the behavior of @initdb@, +-- @postgres@ and @createdb@ you can call the internal function 'initPlan' +-- directly although this should not be necessary. +defaultConfig :: Config +defaultConfig = mempty + { configPlan = mempty + { partialPlanLogger = pure mempty + , partialPlanConfig = Mappend defaultPostgresConfig + , partialPlanCreateDb = Mappend $ pure mempty + { partialProcessConfigCmdLine = Mappend ["test"] + } + , partialPlanInitDb = Mappend $ pure mempty + { partialProcessConfigCmdLine = Mappend ["--no-sync"] + } + , partialPlanPostgres = mempty + { partialPostgresPlanClientConfig = mempty + { Client.dbname = pure "test" + } + } } - - logger StartPostgres - pidLock <- newMVar () - - let postgresOptions = makePostgresOptions tmpCmdLineOptions dataDir port - createDBResult = do - thePid <- runPostgres stdOut stdErr postgresOptions - pid <- newIORef $ Just thePid - pure $ DB mainDir (mkOptions tmpDbName) tmpCmdLineOptions stdErr stdOut pidLock port socketClass pid - - bracketOnError createDBResult stop $ \result -> do - let checkForCrash = readIORef (pid result) >>= \case - Nothing -> throwIO $ StartPostgresDisappeared postgresOptions - Just thePid -> do - mExitCode <- getProcessExitCode thePid - for_ mExitCode (throwIO . StartPostgresFailed postgresOptions) - - logger WaitForDB - waitForDB (mkOptions "template1") `race_` - forever (checkForCrash >> threadDelay 100000) - - logger CreateDB - let createDBHostArgs = case socketClass of - Unix -> ["-h", mainDir] - Localhost -> ["-h", "127.0.0.1"] - - createDBUserArg = maybe [] (\u->["--username="++u]) user - createDBArgs = createDBHostArgs ++ ["-p", show port, tmpDbName] ++ createDBUserArg - throwIfError (CreateDBFailed createDBArgs) =<< - runProcessWith stdOut stdErr "createDB" "createdb" createDBArgs - - logger Finished - return result + } --- | Start postgres and log it's all stdout to {'mainDir'}\/output.txt and {'mainDir'}\/error.txt -startAndLogToTmp :: Options - -- ^ Extra options which override the defaults - -> IO (Either StartError DB) -startAndLogToTmp options = do - mainDir <- createTempDirectory "/tmp" "tmp-postgres" +-- | 'standardConfig' makes a default config with 'standardProcessConfig'. +-- It is used by default but can be overriden by the extra config. +standardConfig :: IO Config +standardConfig = do + theStandardProcessConfig <- standardProcessConfig + pure mempty + { configPlan = mempty + { partialPlanCreateDb = Mappend $ pure theStandardProcessConfig + , partialPlanInitDb = Mappend $ pure theStandardProcessConfig + , partialPlanPostgres = mempty + { partialPostgresPlanProcessConfig = theStandardProcessConfig + } + } + } - stdOutFile <- openFile (mainDir ++ "/" ++ "output.txt") WriteMode - stdErrFile <- openFile (mainDir ++ "/" ++ "error.txt") WriteMode +-- | Create temporary resources and use them to make a 'Config'. +-- The generated 'Config' is combined with the passed in @extraConfiguration@ +-- to create a 'Plan' that is used to create a database. +-- The output 'DB' includes references to the temporary resources for +-- cleanup and the final plan that was used to generate the database and +-- processes +startWith :: Config + -- ^ @extraConfiguration@ that is 'mappend'ed to the generated `Config`. + -- The extra config is 'mappend'ed second, e.g. + -- @generatedConfig <> extraConfiguration@ + -> IO (Either StartError DB) +startWith extra = try $ evalContT $ do + theStandards <- lift standardConfig + let finalExtra = theStandards <> extra + dbResources@Resources {..} <- + ContT $ bracketOnError (initConfig finalExtra) shutdownResources + dbPostgresProcess <- + ContT $ bracketOnError (initPlan resourcesPlan) stopPostgresProcess + pure DB {..} - startWithHandlesAndDir Unix options mainDir stdOutFile stdErrFile +-- | Default start behavior. Equivalent to calling 'startWith' with the +-- 'defaultConfig' +start :: IO (Either StartError DB) +start = startWith defaultConfig --- | Force all connections to the database to close. Can be useful in some testing situations. --- Called during shutdown as well. -terminateConnections :: DB -> IO () -terminateConnections db@DB {..} = do - e <- try $ bracket (PG.connectPostgreSQL $ BSC.pack $ connectionString db) - PG.close - $ \conn -> do - let q = "select pg_terminate_backend(pid) from pg_stat_activity where datname=?;" - void $ PG.execute conn q [Options.oDbname options] - case e of - Left (_ :: IOError) -> pure () -- expected - Right _ -> pure () -- Surprising ... but I do not know yet if this is a failure of termination or not. +-- | Stop the @postgres@ process and cleanup any temporary directories that +-- might have been created. +stop :: DB -> IO () +stop DB {..} = do + void $ stopPostgresProcess dbPostgresProcess + shutdownResources dbResources --- | Stop postgres and clean up the temporary database folder. -stop :: DB -> IO (Maybe ExitCode) -stop db@DB {..} = do - result <- stopPostgres db - removeDirectoryRecursive mainDir - return result +-- | Only stop the @postgres@ process but leave any temporary resources. +-- Useful for testing backup strategies when used in conjunction with +-- 'restart' or 'withRestart'. +stopPostgres :: DB -> IO ExitCode +stopPostgres = stopPostgresProcess . dbPostgresProcess -data InitDbOptions = InitDbOptions - { initDbUser :: Maybe String - , initDbEncoding :: Maybe String - , initDbAuth :: Maybe String - , initDbPgData :: Maybe String - , initDbNoSync :: Bool - , initDbDebug :: Bool - , initDbExtraOptions :: [String] - } deriving (Show, Eq, Read, Ord, Generic, Typeable) +-- | Restart the @postgres@ using the 'Plan' from the 'DB' +-- (e.g. @resourcesPlan . dbResources@) +restart :: DB -> IO (Either StartError DB) +restart db@DB{..} = try $ do + void $ stopPostgres db + let plan = resourcesPlan dbResources + bracketOnError (startPostgresProcess (planLogger plan) $ planPostgres plan) + stopPostgresProcess $ \result -> + pure $ db { dbPostgresProcess = result } -defaultInitDbOptions :: InitDbOptions -defaultInitDbOptions = InitDbOptions { - initDbUser = Nothing - , initDbEncoding = Just "UNICODE" - , initDbAuth = Just "trust" - , initDbPgData = Nothing - , initDbNoSync = True - , initDbDebug = False - , initDbExtraOptions = [] -} +-- | Reload the configuration file without shutting down. Calls +-- @pg_reload_conf()@. +reloadConfig :: DB -> IO () +reloadConfig db = + bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> do + (void :: IO [PG.Only Bool] -> IO ()) $ + PG.query_ conn "SELECT pg_reload_conf()" +------------------------------------------------------------------------------- +-- Exception safe interface +------------------------------------------------------------------------------- +-- | Exception safe default database create. Takes an @action@ continuation +-- which is given a 'DB' it can use to connect +-- to (see 'toConnectionString' or 'postgresProcessClientConfig'). +-- All of the database resources are automatically cleaned up on +-- completion even in the face of exceptions. +withPlan :: Config + -- ^ @extraConfiguration@. Combined with the generated 'Config'. See + -- 'startWith' for more info + -> (DB -> IO a) + -- ^ @action@ continuation + -> IO (Either StartError a) +withPlan plan f = bracket (startWith plan) (either mempty stop) $ + either (pure . Left) (fmap Right . f) -initDbToCommandLingArgs :: InitDbOptions -> [String] -initDbToCommandLingArgs InitDbOptions {..} = strArgs <> boolArgs <> initDbExtraOptions - where - strArgs = fmap (\(a,b) -> "--" <> a <> "=" <> b) . catMaybes $ strength <$> - [ ("username", initDbUser) - , ("encoding", initDbEncoding) - , ("auth", initDbAuth) - , ("pgdata", initDbPgData) - ] - boolArgs = fmap fst . filter snd $ - [ ("--nosync", initDbNoSync) - , ("--debug", initDbDebug) ] +-- | Default expectation safe interface. Equivalent to 'withPlan' the +-- 'defaultConfig' +with :: (DB -> IO a) + -- ^ @action@ continuation. + -> IO (Either StartError a) +with = withPlan defaultConfig - strength :: Functor f => (a, f b) -> f (a, b) - strength (a, fb) = (a,) <$> fb +-- | Exception safe version of 'restart' +withRestart :: DB -> (DB -> IO a) -> IO (Either StartError a) +withRestart db f = bracket (restart db) (either mempty stop) $ + either (pure . Left) (fmap Right . f) diff --git a/src/Database/Postgres/Temp/Internal/Core.hs b/src/Database/Postgres/Temp/Internal/Core.hs new file mode 100644 --- /dev/null +++ b/src/Database/Postgres/Temp/Internal/Core.hs @@ -0,0 +1,235 @@ +{-| +This module provides the low level functionality for running @initdb@, @postgres@ and @createdb@ to make a database. + +See 'initPlan' for more details. +-} +module Database.Postgres.Temp.Internal.Core where +import qualified Database.PostgreSQL.Simple.Options as PostgresClient +import qualified Database.PostgreSQL.Simple as PG +import System.Process.Internals +import System.Exit (ExitCode(..)) +import Data.String +import System.Posix.Signals (sigINT, signalProcess) +import Control.Exception +import System.Process (getProcessExitCode, waitForProcess) +import Data.Foldable (for_) +import Control.Concurrent.Async (race_) +import Control.Monad (forever, (>=>)) +import Control.Concurrent (threadDelay) +import Data.Typeable +import System.IO +import System.Process + +-- | Internal events for debugging +data Event + = StartPostgres + | WaitForDB + deriving (Show, Eq, Ord) + +-- | A list of failures that can occur when starting. This is not +-- and exhaustive list but covers the errors that the system +-- catches for the user. +data StartError + = StartPostgresFailed ExitCode + -- ^ @postgres@ failed before a connection succeeded. Most likely this + -- is due to invalid configuration + | InitDbFailed ExitCode + -- ^ @initdb@ failed. This can be from invalid configuration or using a + -- non-empty data directory + | CreateDbFailed ExitCode + -- ^ @createdb@ failed. This can be from invalid configuration or + -- the database might already exist. + | CompletePlanFailed [String] + -- ^ The 'Database.Postgres.Temp.Partial.PartialPlan' was missing info and a complete 'Plan' could + -- not be created. + deriving (Show, Eq, Ord, Typeable) + +instance Exception StartError + +-- | A way to log internal 'Event's +type Logger = Event -> IO () + +-- TODO. Add a Retrying Event +-- | @postgres@ is not ready until we are able to successfully connect. +-- 'waitForDB' attempts to connect over and over again and returns +-- after the first successful connection. +waitForDB :: PostgresClient.Options -> IO () +waitForDB options = do + let theConnectionString = PostgresClient.toConnectionString options + startAction = PG.connectPostgreSQL theConnectionString + try (bracket startAction PG.close mempty) >>= \case + Left (_ :: IOError) -> threadDelay 10000 >> waitForDB options + Right () -> return () + +-- | 'ProcessConfig' contains the configuration necessary for starting a +-- process. It is essentially a stripped down 'System.Process.CreateProcess'. +data ProcessConfig = ProcessConfig + { processConfigEnvVars :: [(String, String)] + -- ^ Environment variables + , processConfigCmdLine :: [String] + -- ^ Command line arguements + , processConfigStdIn :: Handle + -- ^ The 'Handle' for standard input + , processConfigStdOut :: Handle + -- ^ The 'Handle' for standard output + , processConfigStdErr :: Handle + -- ^ The 'Handle' for standard error + } + +-- | Start a process interactively and return the 'ProcessHandle' +startProcess + :: String + -- ^ Process name + -> ProcessConfig + -- ^ Process config + -> IO ProcessHandle +startProcess name ProcessConfig {..} = (\(_, _, _, x) -> x) <$> + createProcess_ name (proc name processConfigCmdLine) + { std_err = UseHandle processConfigStdErr + , std_out = UseHandle processConfigStdOut + , std_in = UseHandle processConfigStdIn + , env = Just processConfigEnvVars + } + +-- | Start a process and block until it finishes return the 'ExitCode'. +executeProcess + :: String + -- ^ Process name + -> ProcessConfig + -- ^ Process config + -> IO ExitCode +executeProcess name = startProcess name >=> waitForProcess +------------------------------------------------------------------------------- +-- PostgresProcess Life cycle management +------------------------------------------------------------------------------- +-- | PostgresPlan is used be 'startPostgresProcess' to start the @postgres@ +-- and then attempt to connect to it. +data PostgresPlan = PostgresPlan + { postgresPlanProcessConfig :: ProcessConfig + -- ^ The process config for @postgres@ + , postgresPlanClientConfig :: PostgresClient.Options + -- ^ Connection options. Used to verify that @postgres@ is ready. + } + +-- | The output of calling 'startPostgresProcess'. +data PostgresProcess = PostgresProcess + { postgresProcessClientConfig :: PostgresClient.Options + -- ^ Connection options + , postgresProcessHandle :: ProcessHandle + -- ^ @postgres@ process handle + } + +-- | Force all connections to the database to close. Can be useful in some +-- testing situations. +-- Called during shutdown as well. +terminateConnections :: PostgresClient.Options-> IO () +terminateConnections options = do + let theConnectionString = PostgresClient.toConnectionString options + terminationQuery = fromString $ unlines + [ "SELECT pg_terminate_backend(pid)" + , "FROM pg_stat_activity" + , "WHERE datname=?;" + ] + e <- try $ bracket (PG.connectPostgreSQL theConnectionString) PG.close $ + \conn -> PG.execute conn terminationQuery + [PostgresClient.oDbname options] + case e of + Left (_ :: IOError) -> pure () + Right _ -> pure () + +-- | Stop the @postgres@ process after attempting to terminate all the +-- connections. +stopPostgresProcess :: PostgresProcess -> IO ExitCode +stopPostgresProcess PostgresProcess{..} = do + withProcessHandle postgresProcessHandle $ \case + OpenHandle p -> do + -- try to terminate the connects first. If we can't terminate still + -- keep shutting down + terminateConnections postgresProcessClientConfig + + signalProcess sigINT p + OpenExtHandle {} -> pure () -- TODO log windows is not supported + ClosedHandle _ -> return () + + exitCode <- waitForProcess postgresProcessHandle + pure exitCode + +-- | Start the @postgres@ process and block until a successful connection +-- occurs. A separate thread we continously check to see if the @postgres@ +-- process has +startPostgresProcess :: Logger -> PostgresPlan -> IO PostgresProcess +startPostgresProcess logger PostgresPlan {..} = do + logger StartPostgres + + let startAction = PostgresProcess postgresPlanClientConfig + <$> startProcess "postgres" postgresPlanProcessConfig + + -- Start postgres and stop if an exception occurs + bracketOnError startAction stopPostgresProcess $ + \result@PostgresProcess {..} -> do + -- A helper to check if the process has died + let checkForCrash = do + mExitCode <- getProcessExitCode postgresProcessHandle + for_ mExitCode (throwIO . StartPostgresFailed) + + logger WaitForDB + -- We assume that 'template1' exist and make connection + -- options to test if postgres is ready. + let options = postgresPlanClientConfig + { PostgresClient.oDbname = "template1" + } + + -- Block until a connection succeeds or postgres crashes + waitForDB options + `race_` forever (checkForCrash >> threadDelay 100000) + + -- Postgres is now ready so return + return result +------------------------------------------------------------------------------- +-- Plan +------------------------------------------------------------------------------- +-- | 'Plan' is the low level configuration necessary for creating a database +-- starting @postgres@ and creating a database. There is no validation done +-- on the 'Plan'. It is recommend that one use the higher level functions +-- such as 'Database.Postgres.Temp.start' which will generate plans that +-- are valid. 'Plan's are used internally but are exposed if the higher +-- level plan generation is not sufficent. +data Plan = Plan + { planLogger :: Logger + , planInitDb :: Maybe ProcessConfig + , planCreateDb :: Maybe ProcessConfig + , planPostgres :: PostgresPlan + , planConfig :: String + , planDataDirectory :: FilePath + } + +-- | A simple helper to throw 'ExitCode's when they are 'ExitFailure'. +throwIfNotSuccess :: Exception e => (ExitCode -> e) -> ExitCode -> IO () +throwIfNotSuccess f = \case + ExitSuccess -> pure () + e -> throwIO $ f e + +-- | 'initPlan' optionally calls @initdb@, optionally calls @createdb@ and +-- unconditionally calls @postgres@. +-- Additionally it writes a \"postgresql.conf\" and does not return until +-- the @postgres@ process is ready. See 'startPostgresProcess' for more +-- details. +initPlan :: Plan -> IO PostgresProcess +initPlan Plan {..} = do + for_ planInitDb $ executeProcess "initdb" >=> + throwIfNotSuccess InitDbFailed + + -- We must provide a config file before we can start postgres. + writeFile (planDataDirectory <> "/postgresql.conf") planConfig + + let startAction = startPostgresProcess planLogger planPostgres + + bracketOnError startAction stopPostgresProcess $ \result -> do + for_ planCreateDb $ executeProcess "createdb" >=> + throwIfNotSuccess CreateDbFailed + + pure result + +-- | Stop the @postgres@ process. See 'stopPostgresProcess' for more details. +shutdownPlan :: PostgresProcess -> IO ExitCode +shutdownPlan = stopPostgresProcess diff --git a/src/Database/Postgres/Temp/Internal/Partial.hs b/src/Database/Postgres/Temp/Internal/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Database/Postgres/Temp/Internal/Partial.hs @@ -0,0 +1,388 @@ +{-| This module provides types and functions for combining partial + configs into a complete configs to ultimately make a 'Plan'. + + This module has three classes of types. Types like 'Lastoid' that + are generic and could live in a module like "base". + + Types like 'PartialProcessConfig' that could be used by any + library that needs to combine process options. + + Finally it has types and functions for creating 'Plan's that + use temporary resources. This is used to create the default + behavior of 'Database.Postgres.Temp.startWith' and related + functions. +|-} +module Database.Postgres.Temp.Internal.Partial where +import Database.Postgres.Temp.Internal.Core +import qualified Database.PostgreSQL.Simple.PartialOptions as Client +import GHC.Generics (Generic) +import Data.Monoid.Generic +import Data.Monoid +import Data.Typeable +import System.IO +import System.Environment +import Data.Maybe +import Control.Exception +import System.IO.Temp (createTempDirectory) +import Network.Socket.Free (getFreePort) +import Control.Monad (join) +import System.Directory +import Data.Either.Validation +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Class +import System.IO.Error + +{- | +'Lastoid' is helper for overriding configuration values. +It's 'Semigroup' instance let's one either combine the +@a@ of two 'Lastoid's using '<>' via the 'Mappend' constructor +or one can wholly replace the value with the last value using the 'Replace' +constructor. +Roughly + + @ + x <> Replace y = Replace y + Replace x <> Mappend y = Replace (x <> y) + Mappend x <> Mappend y = Mappend (x <> y) + @ + +-} +data Lastoid a = Replace a | Mappend a + deriving (Show, Eq, Functor) + +instance Semigroup a => Semigroup (Lastoid a) where + x <> y = case (x, y) of + (_ , r@Replace {}) -> r + (Replace a, Mappend b ) -> Replace $ a <> b + (Mappend a, Mappend b ) -> Mappend $ a <> b + +instance Monoid a => Monoid (Lastoid a) where + mempty = Mappend mempty + +-- | Get the value of a 'Lastoid' regardless if it is a 'Replace' or +-- a 'Mappend'. +getLastoid :: Lastoid a -> a +getLastoid = \case + Replace a -> a + Mappend a -> a + +-- | The monoidial version of 'ProcessConfig'. Used to combine overrides with +-- defaults when creating a 'ProcessConfig'. +data PartialProcessConfig = PartialProcessConfig + { partialProcessConfigEnvVars :: Lastoid [(String, String)] + -- ^ A monoid for combine environment variables or replacing them + , partialProcessConfigCmdLine :: Lastoid [String] + -- ^ A monoid for combine command line arguments or replacing them + , partialProcessConfigStdIn :: Last Handle + -- ^ A monoid for configuring the standard input 'Handle' + , partialProcessConfigStdOut :: Last Handle + -- ^ A monoid for configuring the standard output 'Handle' + , partialProcessConfigStdErr :: Last Handle + -- ^ A monoid for configuring the standard error 'Handle' + } + deriving stock (Generic) + deriving Semigroup via GenericSemigroup PartialProcessConfig + deriving Monoid via GenericMonoid PartialProcessConfig + +-- | The 'standardProcessConfig' sets the handles to 'stdin', 'stdout' and +-- 'stderr' and inherits the environment variables from the calling +-- process. +standardProcessConfig :: IO PartialProcessConfig +standardProcessConfig = do + env <- getEnvironment + pure mempty + { partialProcessConfigEnvVars = Replace env + , partialProcessConfigStdIn = pure stdin + , partialProcessConfigStdOut = pure stdout + , partialProcessConfigStdErr = pure stderr + } + +-- | A helper to add more info to all the error messages. +addErrorContext :: String -> Either [String] a -> Either [String] a +addErrorContext cxt = either (Left . map (cxt <>)) Right + +-- | A helper for creating an error if a 'Last' is not defined. +getOption :: String -> Last a -> Validation [String] a +getOption optionName = \case + Last (Just x) -> pure x + Last Nothing -> Failure ["Missing " ++ optionName ++ " option"] + +-- | Turn a 'PartialProcessConfig' into a 'ProcessConfig'. Fails if +-- any values are missing. +completeProcessConfig :: PartialProcessConfig -> Either [String] ProcessConfig +completeProcessConfig PartialProcessConfig {..} = validationToEither $ do + let processConfigEnvVars = getLastoid partialProcessConfigEnvVars + processConfigCmdLine = getLastoid partialProcessConfigCmdLine + processConfigStdIn <- + getOption "partialProcessConfigStdIn" partialProcessConfigStdIn + processConfigStdOut <- + getOption "partialProcessConfigStdOut" partialProcessConfigStdOut + processConfigStdErr <- + getOption "partialProcessConfigStdErr" partialProcessConfigStdErr + + pure ProcessConfig {..} + +-- | A type to track whether a file is temporary and needs to be cleaned up. +data DirectoryType = Permanent FilePath | Temporary FilePath + deriving(Show, Eq, Ord) + +-- | Get the file path of a 'DirectoryType', regardless if it is a +-- 'Permanent' or 'Temporary' type. +toFilePath :: DirectoryType -> FilePath +toFilePath = \case + Permanent x -> x + Temporary x -> x + +-- | The monoidial version of 'DirectoryType'. Used to combine overrides with +-- defaults when creating a 'DirectoryType'. The monoid instance treats +-- 'PTemporary' as 'mempty' and takes the last 'PPermanent' value. +data PartialDirectoryType + = PPermanent FilePath + -- ^ A permanent file that should not be generated. + | PTemporary + -- ^ A temporary file that needs to generated. + deriving(Show, Eq, Ord) + +instance Semigroup PartialDirectoryType where + x <> y = case (x, y) of + (a, PTemporary ) -> a + (_, a@PPermanent {}) -> a + +instance Monoid PartialDirectoryType where + mempty = PTemporary + +-- | Either create a'Temporary' directory or do nothing to a 'Permanent' +-- one. +initDirectoryType :: String -> PartialDirectoryType -> IO DirectoryType +initDirectoryType pattern = \case + PTemporary -> Temporary <$> createTempDirectory "/tmp" pattern + PPermanent x -> pure $ Permanent x + +-- | Either create a temporary directory or do nothing +rmDirIgnoreErrors :: FilePath -> IO () +rmDirIgnoreErrors mainDir = do + let ignoreDirIsMissing e + | isDoesNotExistError e = return () + | otherwise = throwIO e + removeDirectoryRecursive mainDir `catch` ignoreDirIsMissing + +-- | Either remove a 'Temporary' directory or do nothing to a 'Permanent' +-- one. +shutdownDirectoryType :: DirectoryType -> IO () +shutdownDirectoryType = \case + Permanent _ -> pure () + Temporary filePath -> rmDirIgnoreErrors filePath + +-- | A type for configuring the listening address of the @postgres@ process. +-- @postgres@ can listen on several types of sockets simulatanously but we +-- don't support that behavior. One can either listen on a IP based socket +-- or a UNIX domain socket. +data SocketClass + = IpSocket String + -- ^ IP socket type. The 'String' is either an IP address or + -- a host that will resolve to an IP address. + | UnixSocket DirectoryType + -- ^ UNIX domain socket + deriving (Show, Eq, Ord, Generic, Typeable) + +-- | Create the extra config lines for listening based on the 'SocketClass' +socketClassToConfig :: SocketClass -> [String] +socketClassToConfig = \case + IpSocket ip -> ["listen_addresses = '" <> ip <> "'"] + UnixSocket dir -> + [ "listen_addresses = ''" + , "unix_socket_directories = '" <> toFilePath dir <> "'" + ] + +-- | Many processes require a \"host\" flag. We can generate one from the +-- 'SocketClass'. +socketClassToHostFlag :: SocketClass -> [String] +socketClassToHostFlag x = ["-h", socketClassToHost x] + +-- | Get the IP address, host name or UNIX domain socket directory +-- as a 'String' +socketClassToHost :: SocketClass -> String +socketClassToHost = \case + IpSocket ip -> ip + UnixSocket dir -> toFilePath dir + +-- | The monoidial version of 'SocketClass'. Used to combine overrides with +-- defaults when creating a 'SocketClass'. The monoid instance treats +-- 'PUnixSocket mempty' as 'mempty' and combines the +data PartialSocketClass + = PIpSocket (Last String) + -- ^ The monoid for combining IP address configuration + | PUnixSocket PartialDirectoryType + -- ^ The monoid for combining UNIX socket configuration + deriving stock (Show, Eq, Ord, Generic, Typeable) + +instance Semigroup PartialSocketClass where + x <> y = case (x, y) of + (PIpSocket a, PIpSocket b) -> PIpSocket $ a <> b + (a@(PIpSocket _), PUnixSocket _) -> a + (PUnixSocket _, a@(PIpSocket _)) -> a + (PUnixSocket a, PUnixSocket b) -> PUnixSocket $ a <> b + +instance Monoid PartialSocketClass where + mempty = PUnixSocket mempty + +-- | Turn a 'PartialSocketClass' to a 'SocketClass'. If the 'PIpSocket' is +-- 'Nothing' default to \"127.0.0.1\". If the is a 'PUnixSocket' +-- optionally create a temporary directory if configured to do so. +initPartialSocketClass :: PartialSocketClass -> IO SocketClass +initPartialSocketClass theClass = case theClass of + PIpSocket mIp -> pure $ IpSocket $ fromMaybe "127.0.0.1" $ + getLast mIp + PUnixSocket mFilePath -> + UnixSocket <$> initDirectoryType "tmp-postgres-socket" mFilePath + +-- | Cleanup the UNIX socket temporary directory if one was created. +shutdownSocketConfig :: SocketClass -> IO () +shutdownSocketConfig = \case + IpSocket {} -> pure () + UnixSocket dir -> shutdownDirectoryType dir + +-- | PartialPostgresPlan +data PartialPostgresPlan = PartialPostgresPlan + { partialPostgresPlanProcessConfig :: PartialProcessConfig + -- ^ Monoid for the @postgres@ ProcessConfig. + , partialPostgresPlanClientConfig :: Client.PartialOptions + -- ^ Monoid for the @postgres@ client connection options. + } + deriving stock (Generic) + deriving Semigroup via GenericSemigroup PartialPostgresPlan + deriving Monoid via GenericMonoid PartialPostgresPlan + +-- | Turn a 'PartialPostgresPlan' into a 'PostgresPlan'. Fails if any +-- values are missing. +completePostgresPlan :: PartialPostgresPlan -> Either [String] PostgresPlan +completePostgresPlan PartialPostgresPlan {..} = validationToEither $ do + postgresPlanClientConfig <- + eitherToValidation $ addErrorContext "partialPostgresPlanClientConfig: " $ + Client.completeOptions partialPostgresPlanClientConfig + postgresPlanProcessConfig <- + eitherToValidation $ addErrorContext "partialPostgresPlanProcessConfig: " $ + completeProcessConfig partialPostgresPlanProcessConfig + + pure PostgresPlan {..} +------------------------------------------------------------------------------- +-- PartialPlan +------------------------------------------------------------------------------- +-- | The monoidial version of 'Plan'. Used to combine overrides with defaults +-- when creating a plan. +data PartialPlan = PartialPlan + { partialPlanLogger :: Last Logger + , partialPlanInitDb :: Lastoid (Maybe PartialProcessConfig) + , partialPlanCreateDb :: Lastoid (Maybe PartialProcessConfig) + , partialPlanPostgres :: PartialPostgresPlan + , partialPlanConfig :: Lastoid [String] + , partialPlanDataDirectory :: Last String + } + deriving stock (Generic) + deriving Semigroup via GenericSemigroup PartialPlan + deriving Monoid via GenericMonoid PartialPlan + +-- | Turn a 'PartialPlan' into a 'Plan'. Fails if any values are missing. +completePlan :: PartialPlan -> Either [String] Plan +completePlan PartialPlan {..} = validationToEither $ do + planLogger <- getOption "partialPlanLogger" partialPlanLogger + planInitDb <- eitherToValidation $ addErrorContext "partialPlanInitDb: " $ + traverse completeProcessConfig $ getLastoid partialPlanInitDb + planCreateDb <- eitherToValidation $ addErrorContext "partialPlanCreateDb: " $ + traverse completeProcessConfig $ getLastoid partialPlanCreateDb + planPostgres <- eitherToValidation $ addErrorContext "partialPlanPostgres: " $ + completePostgresPlan partialPlanPostgres + let planConfig = unlines $ getLastoid partialPlanConfig + planDataDirectory <- getOption "partialPlanDataDirectory" + partialPlanDataDirectory + + pure Plan {..} + +-- | 'Resources' holds a description of the temporary folders (if there are any) +-- and includes the final 'Plan' that can be used with 'initPlan'. +-- See 'initConfig' for an example of how to create a 'Resources'. +data Resources = Resources + { resourcesPlan :: Plan + -- ^ Final 'Plan'. See 'initPlan' for information on 'Plan's + , resourcesSocket :: SocketClass + -- ^ The 'SocketClass'. Used to track if a temporary directory was made + -- as the socket location. + , resourcesDataDir :: DirectoryType + -- ^ The data directory. Used to track if a temporary directory was used. + } + +-- | The high level options for overriding default behavior. +data Config = Config + { configPlan :: PartialPlan + -- ^ Extend or replace any of the configuration used to create a final + -- 'Plan' + , configSocket :: PartialSocketClass + -- ^ Override the default 'SocketClass' by setting this. + , configDataDir :: PartialDirectoryType + -- ^ Override the default temporary data directory by passing in + -- 'Permanent DIRECTORY' + , configPort :: Last (Maybe Int) + -- ^ A monoid for using an existing port (via 'Just PORT_NUMBER') or + -- requesting a free port (via a 'Nothing') + } + deriving stock (Generic) + deriving Semigroup via GenericSemigroup Config + deriving Monoid via GenericMonoid Config + +-- | Create a 'PartialPlan' that sets the command line options of all processes +-- (@initdb@, @postgres@ and @createdb@) using a +toPlan + :: Int + -- ^ port + -> SocketClass + -- ^ Whether to listen on a IP address or UNIX domain socket + -> FilePath + -- ^ The @postgres@ data directory + -> PartialPlan +toPlan port socketClass dataDirectory = mempty + { partialPlanConfig = Mappend $ socketClassToConfig socketClass + , partialPlanDataDirectory = pure dataDirectory + , partialPlanPostgres = mempty + { partialPostgresPlanProcessConfig = mempty + { partialProcessConfigCmdLine = Mappend + [ "-p", show port + , "-D", dataDirectory + ] + } + , partialPostgresPlanClientConfig = mempty + { Client.host = pure $ socketClassToHost socketClass + , Client.port = pure port + } + } + , partialPlanCreateDb = Mappend $ Just $ mempty + { partialProcessConfigCmdLine = Mappend $ + socketClassToHostFlag socketClass <> + ["-p", show port] + } + , partialPlanInitDb = Mappend $ Just $ mempty + { partialProcessConfigCmdLine = Mappend $ + ["--pgdata=" <> dataDirectory] + } + } + + +-- | Create all the temporary resources from a 'Config'. This also combines the 'PartialPlan' from +-- 'toPlan' with the @extraConfig@ passed in. +initConfig + :: Config + -- ^ @extraConfig@ to 'mappend' after the default config + -> IO Resources +initConfig Config {..} = evalContT $ do + port <- lift $ maybe getFreePort pure $ join $ getLast configPort + resourcesSocket <- ContT $ bracketOnError (initPartialSocketClass configSocket) shutdownSocketConfig + resourcesDataDir <- ContT $ bracketOnError (initDirectoryType "tmp-postgres-data" configDataDir) shutdownDirectoryType + let hostAndDirPartial = toPlan port resourcesSocket $ toFilePath resourcesDataDir + resourcesPlan <- lift $ either (throwIO . CompletePlanFailed) pure $ + completePlan $ hostAndDirPartial <> configPlan + pure Resources {..} + +-- | Free the temporary resources created by 'initConfig' +shutdownResources :: Resources -> IO () +shutdownResources Resources {..} = do + shutdownSocketConfig resourcesSocket + shutdownDirectoryType resourcesDataDir diff --git a/test/Database/Postgres/Temp/InternalSpec.hs b/test/Database/Postgres/Temp/InternalSpec.hs --- a/test/Database/Postgres/Temp/InternalSpec.hs +++ b/test/Database/Postgres/Temp/InternalSpec.hs @@ -1,178 +1,393 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, QuasiQuotes, ScopedTypeVariables, LambdaCase #-} module Database.Postgres.Temp.InternalSpec where import Test.Hspec -import System.IO.Temp +import Database.Postgres.Temp.Internal.Core +import Database.Postgres.Temp.Internal.Partial import Database.Postgres.Temp.Internal -import Data.Typeable import Control.Exception -import System.IO -import System.Directory -import Control.Monad +import System.IO.Error import System.Process -import Database.PostgreSQL.Simple -import qualified Data.ByteString.Char8 as BSC import System.Exit +import qualified Database.PostgreSQL.Simple as PG +import System.Environment +import System.Posix.Files +import System.IO.Temp +import System.Directory +import qualified Database.PostgreSQL.Simple.Options as PostgresClient +import qualified Database.PostgreSQL.Simple.PartialOptions as Client +import Data.String import System.Timeout(timeout) -import Data.Either +import Control.Monad (void, (<=<)) import Data.Function (fix) import Control.Concurrent +import Data.Monoid -mkDevNull :: IO Handle -mkDevNull = openFile "/dev/null" WriteMode +-- check coverage +-- Test using an existing domain socket -data Except = Except - deriving (Show, Eq, Typeable) +-- Cleanup -instance Exception Except +newtype Runner = Runner { unRunner :: forall a. (DB -> IO a) -> IO a } -countPostgresProcesses :: IO Int -countPostgresProcesses = do - (exitCode, xs, _) <- readProcessWithExitCode "pgrep" ["postgres"] [] +withRunner :: (DB -> IO ()) -> Runner -> IO () +withRunner g (Runner f) = f g - unless (exitCode == ExitSuccess || exitCode == ExitFailure 1) $ throwIO exitCode +updateCreateDb :: Config -> Lastoid (Maybe PartialProcessConfig) -> Config +updateCreateDb options partialProcessConfig = + let originalPlan = configPlan options + newPlan = originalPlan + { partialPlanCreateDb = partialProcessConfig + } + in options + { configPlan = newPlan + } - pure $ length $ lines xs +defaultConfigShouldMatchDefaultPlan :: SpecWith Runner +defaultConfigShouldMatchDefaultPlan = + it "default options should match default plan" $ withRunner $ \DB{..} -> do + let Resources {..} = dbResources + Plan {..} = resourcesPlan + PostgresPlan {..} = planPostgres + PostgresClient.oDbname postgresPlanClientConfig `shouldBe` "test" + let Temporary tmpDataDir = resourcesDataDir + tmpDataDir `shouldStartWith` "/tmp/tmp-postgres-data" + let Just port = PostgresClient.oPort postgresPlanClientConfig + port `shouldSatisfy` (>32768) + let UnixSocket (Temporary unixSocket) = resourcesSocket + unixSocket `shouldStartWith` "/tmp/tmp-postgres-socket" + postgresPlanClientConfig `shouldBe` + ((PostgresClient.defaultOptions (PostgresClient.oDbname postgresPlanClientConfig)) + { PostgresClient.oPort = PostgresClient.oPort postgresPlanClientConfig + , PostgresClient.oHost = PostgresClient.oHost postgresPlanClientConfig + }) +customConfigWork :: (Config -> (DB -> IO ()) -> IO ()) -> Spec +customConfigWork action = do + let expectedDbName = "thedb" + expectedPassword = "password" + expectedUser = "user-name" + expectedDuration = "100ms" + extraConfig = "log_min_duration_statement='" <> expectedDuration <> "'" + + it "returns the right client options for the plan" $ do + initialCreateDbConfig <- standardProcessConfig + let customPlan = mempty + { configPlan = mempty + { partialPlanPostgres = mempty + { partialPostgresPlanClientConfig = mempty + { Client.user = pure expectedUser + , Client.password = pure expectedPassword + , Client.dbname = pure expectedDbName + } + } + , partialPlanInitDb = Mappend $ pure $ mempty + { partialProcessConfigCmdLine = Mappend + ["--user", "user-name" + ] + , partialProcessConfigEnvVars = Mappend + [ ("PGPASSWORD", "password") + ] + } + , partialPlanConfig = Mappend [extraConfig] + } + } + -- hmm maybe I should provide lenses + let combinedResources = defaultConfig <> customPlan + finalCombinedResources = updateCreateDb combinedResources $ Mappend $ pure $ initialCreateDbConfig + { partialProcessConfigCmdLine = Mappend + ["--user", "user-name" + , expectedDbName + ] + , partialProcessConfigEnvVars = Mappend + [ ("PGPASSWORD", "password") + ] + } + + action finalCombinedResources $ \db@DB {..} -> do + bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> do + [PG.Only actualDuration] <- PG.query_ conn "SHOW log_min_duration_statement" + actualDuration `shouldBe` expectedDuration + + let Resources {..} = dbResources + Plan {..} = resourcesPlan + actualOptions = postgresPlanClientConfig planPostgres + actualPostgresConfig = planConfig + PostgresClient.oUser actualOptions `shouldBe` Just expectedUser + PostgresClient.oDbname actualOptions `shouldBe` expectedDbName + PostgresClient.oPassword actualOptions `shouldBe` Just expectedPassword + lines actualPostgresConfig `shouldContain` defaultPostgresConfig <> [extraConfig] + +invalidConfigFailsQuickly :: (Config -> IO ()) -> Spec +invalidConfigFailsQuickly action = it "quickly fails with an invalid option" $ do + let customPlan = mempty + { configPlan = mempty + { partialPlanConfig = Mappend + [ "log_directory = /this/does/not/exist" + , "logging_collector = true" + ] + } + } + timeout 5000000 (action $ defaultConfig <> customPlan) `shouldThrow` + (== StartPostgresFailed (ExitFailure 1)) + + +throwsIfCreateDbIsNotOnThePath :: IO a -> Spec +throwsIfCreateDbIsNotOnThePath action = it "throws if createdb is not on the path" $ + withSystemTempDirectory "createdb-not-on-path-test" $ \dir -> do + Just initDbPath <- findExecutable "initdb" + Just postgresPath <- findExecutable "postgres" + + -- create symlinks + createSymbolicLink initDbPath $ dir <> "/initdb" + createSymbolicLink postgresPath $ dir <> "/postgres" + + path <- getEnv "PATH" + + bracket (setEnv "PATH" dir) (const $ setEnv "PATH" path) $ \_ -> + action `shouldThrow` isDoesNotExistError + +throwsIfInitDbIsNotOnThePath :: IO a -> Spec +throwsIfInitDbIsNotOnThePath action = it "throws if initdb is not on the path" $ do + path <- getEnv "PATH" + + bracket (setEnv "PATH" "/foo") (const $ setEnv "PATH" path) $ \_ -> + action `shouldThrow` isDoesNotExistError + +withAnyPlan :: SpecWith Runner +withAnyPlan = do + it "start/stop the postgres process is running and then it is not" $ withRunner $ \db@DB{..} -> do + getProcessExitCode (postgresProcessHandle dbPostgresProcess) `shouldReturn` Nothing + + stop db + + getProcessExitCode (postgresProcessHandle dbPostgresProcess) `shouldReturn` Just ExitSuccess + + it "Can connect to the db after it starts" $ withRunner $ \db -> do + one <- fmap (PG.fromOnly . head) $ + bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close $ + \conn -> PG.query_ conn "SELECT 1" + + one `shouldBe` (1 :: Int) + + it "cleans up temp files" $ \(Runner runner) -> do + initialFiles <- listDirectory "/tmp" + runner $ const $ pure () + listDirectory "/tmp" `shouldReturn` initialFiles + +-- This assumes that the directory is initially empty +withInitDbEmptyInitially :: SpecWith Runner +withInitDbEmptyInitially = describe "with active initDb non-empty folder initially" $ + it "the data directory has been initialize" $ withRunner $ \DB {..} -> do + initialFiles <- listDirectory $ toFilePath $ resourcesDataDir $ dbResources + initialFiles `shouldContain` ["PG_VERSION"] + +createDbCreatesTheDb :: String -> SpecWith Runner +createDbCreatesTheDb dbName = describe "createdb " $ + it "creates the db if it didn't exit" $ withRunner $ \db -> do + result <- bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close $ + \conn -> fmap (PG.fromOnly . head) $ PG.query_ conn $ fromString $ + "SELECT EXISTS (SELECT datname FROM pg_catalog.pg_database WHERE datname = '" <> dbName <> "')" + result `shouldBe` True + +createDbThrowsIfTheDbExists :: SpecWith Runner +createDbThrowsIfTheDbExists = describe "createdb" $ + it "throws if the db is not there" $ \(Runner runner) -> + runner (const $ pure ()) `shouldThrow` (== CreateDbFailed (ExitFailure 1)) + spec :: Spec -spec = describe "Database.Postgres.Temp.Internal" $ do - before (createTempDirectory "/tmp" "tmp-postgres") $ after rmDirIgnoreErrors $ describe "startWithLogger/stop" $ do - forM_ [minBound .. maxBound] $ \event -> - it ("deletes the temp dir and postgres on exception in " ++ show event) $ \mainFilePath -> do - -- This is not the best method ... but it works - beforePostgresCount <- countPostgresProcesses - theStdOut <- mkDevNull - theStdErr <- mkDevNull - shouldThrow - (startWithLogger (\currentEvent -> when (currentEvent == event) $ throwIO Except) Unix defaultOptions mainFilePath theStdOut theStdErr) - (\Except -> True) - doesDirectoryExist mainFilePath `shouldReturn` False - countPostgresProcesses `shouldReturn` beforePostgresCount +spec = do + theStandardProcessConfig <- runIO standardProcessConfig - it "creates a useful connection string and stop still cleans up" $ \mainFilePath -> do - beforePostgresCount <- countPostgresProcesses - theStdOut <- mkDevNull - theStdErr <- mkDevNull - result <- startWithLogger (\_ -> return ()) Unix defaultOptions mainFilePath theStdOut theStdErr - db <- case result of - Right x -> return x - Left err -> error $ show err - conn <- connectPostgreSQL $ BSC.pack $ connectionString db - _ <- execute_ conn "create table users (id int)" + let defaultIpPlan = defaultConfig + { configSocket = PIpSocket $ Last Nothing + } - stop db `shouldReturn` Just ExitSuccess - doesDirectoryExist mainFilePath `shouldReturn` False - countPostgresProcesses `shouldReturn` beforePostgresCount + specificHostIpPlan = defaultConfig + { configSocket = PIpSocket $ pure "localhost" + } - it "can override settings" $ \mainFilePath -> do - let expectedDuration = "100ms" - theStdOut <- mkDevNull - theStdErr <- mkDevNull - bracket (startWithLogger (const $ pure ()) Unix - defaultOptions { tmpCmdLineOptions = [("log_min_duration_statement", expectedDuration)] } - mainFilePath theStdOut theStdErr - ) - (either (\_ -> return ()) (void . stop)) $ \result -> do - db <- case result of - Right x -> return x - Left err -> error $ show err - conn <- connectPostgreSQL $ BSC.pack $ connectionString db - [Only actualDuration] <- query_ conn "SHOW log_min_duration_statement" - actualDuration `shouldBe` expectedDuration + describe "start" $ do + let startAction = bracket (either throwIO pure =<< start) stop (const $ pure ()) + throwsIfInitDbIsNotOnThePath startAction + throwsIfCreateDbIsNotOnThePath startAction + describe "startWith" $ do + let startAction plan = bracket (either throwIO pure =<< startWith plan) stop pure + throwsIfInitDbIsNotOnThePath $ startAction defaultConfig + throwsIfCreateDbIsNotOnThePath $ startAction defaultConfig + invalidConfigFailsQuickly $ void . startAction + customConfigWork $ \plan f -> + bracket (either throwIO pure =<< startWith plan) stop f + describe "with" $ do + let startAction = either throwIO pure =<< with (const $ pure ()) + throwsIfInitDbIsNotOnThePath startAction + throwsIfCreateDbIsNotOnThePath startAction + describe "withPlan" $ do + let startAction plan = either throwIO pure =<< + withPlan plan pure - it "dies promptly when a bad setting is passed" $ \mainFilePath -> do - theStdOut <- mkDevNull - theStdErr <- mkDevNull - r <- timeout 5000000 $ startWithLogger (const $ pure ()) Unix - defaultOptions { tmpCmdLineOptions = [ ("log_directory", "/this/does/not/exist") - , ("logging_collector", "true") - ] } mainFilePath theStdOut theStdErr - case r of - Nothing -> - -- bad test, shouldSatisfy is difficult because it wants Show on DB. - -- anyway, point of this is to fail if we timed out. - 1 `shouldBe` (2 :: Int) - Just (Right x) -> - -- this would be very surprising but if it somehow manages to do something useful despite - -- bad config ... ok i guess? regardless, should clean up. - void $ stop x - Just (Left _) -> do - -- if it fails here that's fine & expected. - pure () + throwsIfInitDbIsNotOnThePath $ startAction defaultConfig + throwsIfCreateDbIsNotOnThePath $ startAction defaultConfig + invalidConfigFailsQuickly $ void . startAction + customConfigWork $ \plan f -> either throwIO pure =<< + withPlan plan f - it "terminateConnections" $ \mainFilePath -> do - theStdOut <- mkDevNull - theStdErr <- mkDevNull - bracket (fromRight (error "failed to start db") <$> startWithLogger (\_ -> return ()) Unix defaultOptions mainFilePath theStdOut theStdErr) stop $ \db -> do - bracket (connectPostgreSQL $ BSC.pack $ connectionString db) close $ \_ -> - bracket (connectPostgreSQL $ BSC.pack $ connectionString db) close $ \conn2 -> do - query_ conn2 "SELECT COUNT(*) FROM pg_stat_activity where backend_type='client backend'" `shouldReturn` [Only (2 :: Int)] + let someStandardTests dbName= do + withAnyPlan + withInitDbEmptyInitially + createDbCreatesTheDb dbName - terminateConnections db + describe "restart" $ do + let startAction f = + bracket (either throwIO pure + =<< restart + =<< either throwIO pure + =<< start) stop f + before (pure $ Runner startAction) $ do + someStandardTests "test" + defaultConfigShouldMatchDefaultPlan - bracket (connectPostgreSQL $ BSC.pack $ connectionString db) close $ \conn3 -> - query_ conn3 "SELECT COUNT(*) FROM pg_stat_activity where backend_type='client backend'" `shouldReturn` [Only (1 :: Int)] + describe "withRestart" $ do + let startAction f = bracket (either throwIO pure =<< start) stop $ \db -> + either throwIO pure =<< withRestart db f + before (pure $ Runner startAction) $ do + someStandardTests "test" + defaultConfigShouldMatchDefaultPlan - -- The point of stopPostgres and startPostgres is to test recovery so - -- let's make sure that works - it "stopPostgres/startPostgres works" $ \mainFilePath -> do - let extraOpts = defaultOptions { tmpCmdLineOptions = - [ ("wal_level", "replica") - , ("archive_mode", "on") - , ("max_wal_senders", "2") - , ("fsync", "on") - , ("synchronous_commit", "on") - ] + describe "start/stop" $ do + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< start) stop f) $ do + someStandardTests "test" + defaultConfigShouldMatchDefaultPlan + it "stopPostgres cannot be connected to" $ withRunner $ \db -> do + stopPostgres db `shouldReturn` ExitSuccess + PG.connectPostgreSQL (toConnectionString db) `shouldThrow` + (\(_ :: IOError) -> True) + + it "reloadConfig works" $ withRunner $ \db@DB{..} -> do + let dataDir = toFilePath (resourcesDataDir dbResources) + expectedDuration = "100ms" + extraConfig = "log_min_duration_statement='" <> expectedDuration <> "'" + appendFile (dataDir ++ "/postgresql.conf") $ extraConfig + + reloadConfig db + + bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> do + [PG.Only actualDuration] <- PG.query_ conn "SHOW log_min_duration_statement" + actualDuration `shouldBe` expectedDuration + + let invalidCreateDbPlan = updateCreateDb defaultConfig $ + Mappend $ pure $ theStandardProcessConfig + { partialProcessConfigCmdLine = Mappend ["template1"] } + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith invalidCreateDbPlan) stop f) $ + createDbThrowsIfTheDbExists - theStdOut <- mkDevNull - theStdErr <- mkDevNull + let noCreateTemplate1 = mempty + { configPlan = mempty + { partialPlanCreateDb = Replace Nothing + , partialPlanPostgres = mempty + { partialPostgresPlanClientConfig = mempty + { Client.dbname = pure "template1" + } + } + } + } + noCreateDbPlan = defaultConfig <> noCreateTemplate1 + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith noCreateDbPlan) stop f) $ + someStandardTests "template1" - bracket (fromRight (error "failed to start db") <$> startWithLogger (\_ -> return ()) Unix extraOpts mainFilePath theStdOut theStdErr) stop $ \db -> do - bracket (connectPostgreSQL $ BSC.pack $ connectionString db) close $ \conn -> do - let dataDir = mainFilePath ++ "/data" - walArchiveDir = mainFilePath ++ "/archive" - baseBackupFile = mainFilePath ++ "/backup" + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith defaultIpPlan) stop f) $ + someStandardTests "test" - appendFile (dataDir ++ "/pg_hba.conf") $ "local replication all trust" - let archiveLine = "archive_command = " ++ - "'test ! -f " ++ walArchiveDir ++ "/%f && cp %p " ++ walArchiveDir ++ "/%f'\n" + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith specificHostIpPlan) stop f) $ + someStandardTests "test" + before (createTempDirectory "/tmp" "tmp-postgres-test") $ after rmDirIgnoreErrors $ do + it "fails on non-empty data directory" $ \dirPath -> do + writeFile (dirPath <> "/PG_VERSION") "1 million" + let nonEmptyFolderPlan = defaultConfig + { configDataDir = PPermanent dirPath + } + startAction = bracket (either throwIO pure =<< startWith nonEmptyFolderPlan) stop $ const $ pure () + + startAction `shouldThrow` (== InitDbFailed (ExitFailure 1)) + + it "works if on non-empty if initdb is disabled" $ \dirPath -> do + throwIfNotSuccess id =<< system ("initdb " <> dirPath) + let nonEmptyFolderPlan = defaultConfig + { configDataDir = PPermanent dirPath + , configPlan = (configPlan defaultConfig) + { partialPlanInitDb = Replace Nothing + } + } + bracket (either throwIO pure =<< startWith nonEmptyFolderPlan) stop $ \db -> do + one <- fmap (PG.fromOnly . head) $ + bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close $ + \conn -> PG.query_ conn "SELECT 1" + + one `shouldBe` (1 :: Int) + + let justBackupResources = mempty + { configPlan = mempty + { partialPlanConfig = Mappend + [ "wal_level=replica" + , "archive_mode=on" + , "max_wal_senders=2" + , "fsync=on" + , "synchronous_commit=on" + ] + } + } + backupResources = defaultConfig <> justBackupResources + before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith backupResources) stop f) $ + it "can support backup and restore" $ withRunner $ \db@DB {..} -> do + let dataDir = toFilePath (resourcesDataDir dbResources) + appendFile (dataDir ++ "/pg_hba.conf") $ "local replication all trust" + withTempDirectory "/tmp" "tmp-postgres-backup" $ \tempDir -> do + let walArchiveDir = tempDir ++ "/archive" + baseBackupFile = tempDir ++ "/backup" + archiveLine = "archive_command = " ++ + "'test ! -f " ++ walArchiveDir ++ "/%f && cp %p " ++ walArchiveDir ++ "/%f'\n" appendFile (dataDir ++ "/postgresql.conf") $ archiveLine createDirectory walArchiveDir reloadConfig db - res <- system ("pg_basebackup -D " ++ baseBackupFile ++ " --format=tar -p" ++ show (port db) ++ " -h" ++ mainFilePath) - res `shouldBe` ExitSuccess - - _ <- execute_ conn "CREATE TABLE foo(id int PRIMARY KEY);" - _ <- execute_ conn "BEGIN ISOLATION LEVEL READ COMMITTED READ WRITE; INSERT INTO foo (id) VALUES (1); COMMIT" - _ :: [Only String] <- query_ conn "SELECT pg_walfile_name(pg_switch_wal())" - _ :: [Only String] <- query_ conn "SELECT pg_walfile_name(pg_create_restore_point('pitr'))" - _ <- execute_ conn "BEGIN ISOLATION LEVEL READ COMMITTED READ WRITE; INSERT INTO foo (id) VALUES (2); COMMIT" + let Just port = PostgresClient.oPort $ postgresProcessClientConfig dbPostgresProcess + Just host = PostgresClient.oHost $ postgresProcessClientConfig dbPostgresProcess + backupCommand = "pg_basebackup -D " ++ baseBackupFile ++ " --format=tar -p" + ++ show port ++ " -h" ++ host + putStrLn backupCommand + system backupCommand `shouldReturn` ExitSuccess - query_ conn "SELECT id FROM foo ORDER BY id ASC" - `shouldReturn` [Only (1 :: Int), Only 2] + bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close $ \conn -> do + _ <- PG.execute_ conn "CREATE TABLE foo(id int PRIMARY KEY);" + _ <- PG.execute_ conn "BEGIN ISOLATION LEVEL READ COMMITTED READ WRITE; INSERT INTO foo (id) VALUES (1); COMMIT" + _ :: [PG.Only String] <- PG.query_ conn "SELECT pg_walfile_name(pg_switch_wal())" + _ :: [PG.Only String] <- PG.query_ conn "SELECT pg_walfile_name(pg_create_restore_point('pitr'))" + _ <- PG.execute_ conn "BEGIN ISOLATION LEVEL READ COMMITTED READ WRITE; INSERT INTO foo (id) VALUES (2); COMMIT" - close conn + PG.query_ conn "SELECT id FROM foo ORDER BY id ASC" + `shouldReturn` [PG.Only (1 :: Int), PG.Only 2] - stopPostgres db `shouldReturn` Just ExitSuccess + stopPostgres db `shouldReturn` ExitSuccess removeDirectoryRecursive dataDir createDirectory dataDir + let untarCommand = "tar -C" ++ dataDir ++ " -xf " ++ baseBackupFile ++ "/base.tar" system untarCommand `shouldReturn` ExitSuccess + system ("chmod -R 700 " ++ dataDir) `shouldReturn` ExitSuccess + writeFile (dataDir ++ "/recovery.conf") $ "recovery_target_name='pitr'\nrecovery_target_action='promote'\nrecovery_target_inclusive=true\nrestore_command='" ++ "cp " ++ walArchiveDir ++ "/%f %p'" - startPostgres db - bracket (connectPostgreSQL $ BSC.pack $ connectionString db) close $ \conn1 -> do - fix $ \next -> do - fmap (fromOnly . head) (query_ conn1 "SELECT pg_is_in_recovery()") >>= \case - True -> threadDelay 100000 >> next - False -> pure () + either throwIO pure <=< withRestart db $ \newDb -> do + bracket (PG.connectPostgreSQL $ toConnectionString newDb) PG.close $ \conn -> do + fix $ \next -> do + fmap (PG.fromOnly . head) (PG.query_ conn "SELECT pg_is_in_recovery()") >>= \case + True -> threadDelay 100000 >> next + False -> pure () - query_ conn1 "SELECT id FROM foo ORDER BY id ASC" - `shouldReturn` [Only (1 :: Int)] + PG.query_ conn "SELECT id FROM foo ORDER BY id ASC" + `shouldReturn` [PG.Only (1 :: Int)] diff --git a/tmp-postgres.cabal b/tmp-postgres.cabal --- a/tmp-postgres.cabal +++ b/tmp-postgres.cabal @@ -1,21 +1,17 @@ name: tmp-postgres -version: 0.3.0.1 -synopsis: Start and stop a temporary postgres for testing +version: 1.0.0.0 +synopsis: Start and stop a temporary postgres description: - This module provides functions creating a temporary postgres instance on a random port for testing. + @tmp-postgres@ provides functions creating a temporary @postgres@ instance. . - > result <- start [] - > case result of - > Left err -> print err - > Right tempDB -> do - > -- Do stuff - > stop tempDB + By default it will create a temporary directory for the data, + a random port for listening and a temporary directory for a UNIX + domain socket. . - The are few different methods for starting @postgres@ which provide different - methods of dealing with @stdout@ and @stderr@. + Here is an example using the expection safe 'with' function: . - The start methods use a config based on the one used by pg_tmp (http://ephemeralpg.org/), but can be overriden - by different values to the first argument of the start functions. + > with $ \db -> bracket (connectPostgreSQL (toConnectionString db)) close $ \conn -> + > execute_ conn "CREATE TABLE foo (id int)" . MacOS and Linux are support. Windows is not. . @@ -36,11 +32,25 @@ build-type: Simple extra-source-files: README.md cabal-version: >=1.10 +tested-with: GHC ==8.6.5 library hs-source-dirs: src exposed-modules: Database.Postgres.Temp , Database.Postgres.Temp.Internal + , Database.Postgres.Temp.Internal.Core + , Database.Postgres.Temp.Internal.Partial + default-extensions: LambdaCase + , DerivingStrategies + , DerivingVia + , ScopedTypeVariables + , RecordWildCards + , DeriveGeneric + , OverloadedStrings + , RecordWildCards + , ApplicativeDo + , DeriveFunctor + , ViewPatterns build-depends: base >= 4.6 && < 5 , temporary , process >= 1.2.0.0 @@ -52,9 +62,14 @@ , postgres-options , port-utils , async + , generic-monoid + , postgresql-simple-opts + , either + , transformers ghc-options: -Wall default-language: Haskell2010 + test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test @@ -71,8 +86,26 @@ , postgresql-simple , bytestring , mtl + , unix + , temporary + , either + , transformers + , postgresql-simple-opts + , postgres-options ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 + default-extensions: LambdaCase + , DerivingStrategies + , DerivingVia + , ScopedTypeVariables + , RecordWildCards + , DeriveGeneric + , OverloadedStrings + , RecordWildCards + , DeriveDataTypeable + , QuasiQuotes + , RankNTypes + source-repository head type: git