tmp-postgres 0.3.0.1 → 1.0.0.0
raw patch · 7 files changed
+1292/−570 lines, 7 filesdep +eitherdep +generic-monoiddep +postgresql-simple-opts
Dependencies added: either, generic-monoid, postgresql-simple-opts, transformers
Files
- README.md +28/−7
- src/Database/Postgres/Temp.hs +97/−33
- src/Database/Postgres/Temp/Internal.hs +154/−388
- src/Database/Postgres/Temp/Internal/Core.hs +235/−0
- src/Database/Postgres/Temp/Internal/Partial.hs +388/−0
- test/Database/Postgres/Temp/InternalSpec.hs +344/−129
- tmp-postgres.cabal +46/−13
README.md view
@@ -1,16 +1,37 @@ [](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
src/Database/Postgres/Temp.hs view
@@ -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. -}
src/Database/Postgres/Temp/Internal.hs view
@@ -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)
+ src/Database/Postgres/Temp/Internal/Core.hs view
@@ -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
+ src/Database/Postgres/Temp/Internal/Partial.hs view
@@ -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
test/Database/Postgres/Temp/InternalSpec.hs view
@@ -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)]
tmp-postgres.cabal view
@@ -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