tmp-postgres 1.0.0.2 → 1.0.1.0
raw patch · 6 files changed
+495/−406 lines, 6 filesdep −hspec-discoverdep −network
Dependencies removed: hspec-discover, network
Files
- src/Database/Postgres/Temp.hs +2/−1
- src/Database/Postgres/Temp/Internal.hs +18/−0
- src/Database/Postgres/Temp/Internal/Partial.hs +66/−6
- test/Database/Postgres/Temp/InternalSpec.hs +0/−394
- test/Spec.hs +407/−1
- tmp-postgres.cabal +2/−4
src/Database/Postgres/Temp.hs view
@@ -83,7 +83,8 @@ -- ** Database plans. This is used to call @initdb@, @postgres@ and @createdb@ , PartialPlan (..) , Plan (..)- -- ** Top level configuration+ -- ** Custom Config builder helpers+ , optionsToDefaultConfig ) where import Database.Postgres.Temp.Internal import Database.Postgres.Temp.Internal.Core
src/Database/Postgres/Temp/Internal.hs view
@@ -176,3 +176,21 @@ withRestart :: DB -> (DB -> IO a) -> IO (Either StartError a) withRestart db f = bracket (restart db) (either mempty stop) $ either (pure . Left) (fmap Right . f)++-- | Attempt to create a config from a 'Client.Options'. This is useful if+-- want to create a database owned by a specific user you will also log in as+-- among other use cases. It is possible some 'Client.Options' are not+-- supported so don't hesitate to open an issue on github if you find one.+-- This function works around a difficulty with appending options to+-- the 'createdb' plan by mappending to 'defaultConfig' and+-- optionally replacing the database name.+optionsToDefaultConfig :: Client.Options -> Config+optionsToDefaultConfig opts@Client.Options {..} =+ let thePartialPlan = configPlan defaultConfig+ noDbDefault = defaultConfig+ { configPlan = thePartialPlan+ { partialPlanCreateDb = mempty+ }+ }+ generateConfig = optionsToConfig opts+ in noDbDefault <> generateConfig
src/Database/Postgres/Temp/Internal/Partial.hs view
@@ -109,7 +109,8 @@ -- | Turn a 'PartialProcessConfig' into a 'ProcessConfig'. Fails if -- any values are missing.-completeProcessConfig :: PartialProcessConfig -> Either [String] ProcessConfig+completeProcessConfig+ :: PartialProcessConfig -> Either [String] ProcessConfig completeProcessConfig PartialProcessConfig {..} = validationToEither $ do let processConfigEnvVars = getLastoid partialProcessConfigEnvVars processConfigCmdLine = getLastoid partialProcessConfigCmdLine@@ -364,17 +365,20 @@ } --- | Create all the temporary resources from a 'Config'. This also combines the 'PartialPlan' from--- 'toPlan' with the @extraConfig@ passed in.+-- | 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+ 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 {..}@@ -384,3 +388,59 @@ shutdownResources Resources {..} = do shutdownSocketConfig resourcesSocket shutdownDirectoryType resourcesDataDir+-------------------------------------------------------------------------------+-- Config Generation+-------------------------------------------------------------------------------+-- | Attempt to create a config from a 'Client.Options'. This is useful if+-- want to create a database owned by a specific user you will also log in as+-- among other use cases. It is possible some 'Client.Options' are not+-- supported so don't hesitate to open an issue on github if you find one.+optionsToConfig :: Client.Options -> Config+optionsToConfig opts@Client.Options {..}+ = ( mempty+ { configPlan = optionsToPlan opts+ , configPort = maybe (Last Nothing) (pure . pure) $ getLast port+ , configSocket = hostToSocketClass $ getLast host+ }+ )+ <> ( mempty+ { configPlan = mempty+ { partialPlanPostgres = mempty+ { partialPostgresPlanClientConfig = opts+ }+ }+ }+ )++optionsToPlan :: Client.Options -> PartialPlan+optionsToPlan Client.Options {..}+ = dbnameToPlan (getLast dbname)+ <> userToPlan (getLast user)++userToPlan :: Maybe String -> PartialPlan+userToPlan = \case+ Nothing -> mempty+ Just user -> mempty+ { partialPlanCreateDb = Mappend $ Just $ mempty+ { partialProcessConfigCmdLine = Mappend ["--username=" <> user]+ }+ , partialPlanInitDb = Mappend $ Just $ mempty+ { partialProcessConfigCmdLine = Mappend ["--username=" <> user]+ }+ }++dbnameToPlan :: Maybe String -> PartialPlan+dbnameToPlan = \case+ Nothing -> mempty+ Just dbName -> mempty+ { partialPlanCreateDb = Mappend $ Just $ mempty+ { partialProcessConfigCmdLine = Mappend [dbName]+ }+ }++hostToSocketClass :: Maybe String -> PartialSocketClass+hostToSocketClass = \case+ Nothing -> mempty+ Just hostOrSocketPath -> case hostOrSocketPath of+ '/' : _ -> PUnixSocket $ PPermanent hostOrSocketPath+ _ -> PIpSocket $ pure hostOrSocketPath
− test/Database/Postgres/Temp/InternalSpec.hs
@@ -1,394 +0,0 @@-module Database.Postgres.Temp.InternalSpec where-import Test.Hspec-import Database.Postgres.Temp.Internal.Core-import Database.Postgres.Temp.Internal.Partial-import Database.Postgres.Temp.Internal-import Control.Exception-import System.IO.Error-import System.Process-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 Client-import Data.String-import System.Timeout(timeout)-import Control.Monad (void, (<=<))-import Data.Function (fix)-import Control.Concurrent-import Data.Monoid---- check coverage--- Test using an existing domain socket---- Cleanup--newtype Runner = Runner { unRunner :: forall a. (DB -> IO a) -> IO a }--withRunner :: (DB -> IO ()) -> Runner -> IO ()-withRunner g (Runner f) = f g--updateCreateDb :: Config -> Lastoid (Maybe PartialProcessConfig) -> Config-updateCreateDb options partialProcessConfig =- let originalPlan = configPlan options- newPlan = originalPlan- { partialPlanCreateDb = partialProcessConfig- }- in options- { configPlan = newPlan- }--defaultConfigShouldMatchDefaultPlan :: SpecWith Runner-defaultConfigShouldMatchDefaultPlan =- it "default options should match default plan" $ withRunner $ \DB{..} -> do- let Resources {..} = dbResources- Plan {..} = resourcesPlan- PostgresPlan {..} = planPostgres- Client.dbname postgresPlanClientConfig `shouldBe` pure "test"- let Temporary tmpDataDir = resourcesDataDir- tmpDataDir `shouldStartWith` "/tmp/tmp-postgres-data"- let Just port = getLast $ Client.port postgresPlanClientConfig- port `shouldSatisfy` (>32768)- let UnixSocket (Temporary unixSocket) = resourcesSocket- unixSocket `shouldStartWith` "/tmp/tmp-postgres-socket"- postgresPlanClientConfig `shouldBe`- (mempty- { Client.port = Client.port postgresPlanClientConfig- , Client.host = Client.host postgresPlanClientConfig- , Client.dbname = Client.dbname 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- Client.user actualOptions `shouldBe` pure expectedUser- Client.dbname actualOptions `shouldBe` pure expectedDbName- Client.password actualOptions `shouldBe` pure 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 = do- theStandardProcessConfig <- runIO standardProcessConfig-- let defaultIpPlan = defaultConfig- { configSocket = PIpSocket $ Last Nothing- }-- specificHostIpPlan = defaultConfig- { configSocket = PIpSocket $ pure "localhost"- }-- 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-- throwsIfInitDbIsNotOnThePath $ startAction defaultConfig- throwsIfCreateDbIsNotOnThePath $ startAction defaultConfig- invalidConfigFailsQuickly $ void . startAction- customConfigWork $ \plan f -> either throwIO pure =<<- withPlan plan f-- let someStandardTests dbName= do- withAnyPlan- withInitDbEmptyInitially- createDbCreatesTheDb dbName-- 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-- 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-- 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-- 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"-- before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith defaultIpPlan) stop f) $- someStandardTests "test"-- 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-- let Just port = getLast $ Client.port $ postgresProcessClientConfig dbPostgresProcess- Just host = getLast $ Client.host $ postgresProcessClientConfig dbPostgresProcess- backupCommand = "pg_basebackup -D " ++ baseBackupFile ++ " --format=tar -p"- ++ show port ++ " -h" ++ host- putStrLn backupCommand- system backupCommand `shouldReturn` ExitSuccess-- 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"-- PG.query_ conn "SELECT id FROM foo ORDER BY id ASC"- `shouldReturn` [PG.Only (1 :: Int), PG.Only 2]-- 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'"-- 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 ()-- PG.query_ conn "SELECT id FROM foo ORDER BY id ASC"- `shouldReturn` [PG.Only (1 :: Int)]
test/Spec.hs view
@@ -1,1 +1,407 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+import Test.Hspec+import Database.Postgres.Temp.Internal.Core+import Database.Postgres.Temp.Internal.Partial+import Database.Postgres.Temp.Internal+import Control.Exception+import System.IO.Error+import System.Process+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 Client+import Data.String+import System.Timeout(timeout)+import Control.Monad (void, (<=<))+import Data.Function (fix)+import Control.Concurrent+import Data.Monoid+import Network.Socket.Free (getFreePort)++main :: IO ()+main = hspec spec++-- check coverage+-- Test using an existing domain socket++-- Cleanup++newtype Runner = Runner (forall a. (DB -> IO a) -> IO a)++withRunner :: (DB -> IO ()) -> Runner -> IO ()+withRunner g (Runner f) = f g++updateCreateDb :: Config -> Lastoid (Maybe PartialProcessConfig) -> Config+updateCreateDb options partialProcessConfig =+ let originalPlan = configPlan options+ newPlan = originalPlan+ { partialPlanCreateDb = partialProcessConfig+ }+ in options+ { configPlan = newPlan+ }++defaultConfigShouldMatchDefaultPlan :: SpecWith Runner+defaultConfigShouldMatchDefaultPlan =+ it "default options should match default plan" $ withRunner $ \DB{..} -> do+ let Resources {..} = dbResources+ Plan {..} = resourcesPlan+ PostgresPlan {..} = planPostgres+ Client.dbname postgresPlanClientConfig `shouldBe` pure "test"+ let Temporary tmpDataDir = resourcesDataDir+ tmpDataDir `shouldStartWith` "/tmp/tmp-postgres-data"+ let Just port = getLast $ Client.port postgresPlanClientConfig+ port `shouldSatisfy` (>32768)+ let UnixSocket (Temporary unixSocket) = resourcesSocket+ unixSocket `shouldStartWith` "/tmp/tmp-postgres-socket"+ postgresPlanClientConfig `shouldBe`+ (mempty+ { Client.port = Client.port postgresPlanClientConfig+ , Client.host = Client.host postgresPlanClientConfig+ , Client.dbname = Client.dbname 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+ Client.user actualOptions `shouldBe` pure expectedUser+ Client.dbname actualOptions `shouldBe` pure expectedDbName+ Client.password actualOptions `shouldBe` pure 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 = do+ theStandardProcessConfig <- runIO standardProcessConfig++ let defaultIpPlan = defaultConfig+ { configSocket = PIpSocket $ Last Nothing+ }++ specificHostIpPlan = defaultConfig+ { configSocket = PIpSocket $ pure "localhost"+ }++ 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++ throwsIfInitDbIsNotOnThePath $ startAction defaultConfig+ throwsIfCreateDbIsNotOnThePath $ startAction defaultConfig+ invalidConfigFailsQuickly $ void . startAction+ customConfigWork $ \plan f -> either throwIO pure =<<+ withPlan plan f++ let someStandardTests dbName= do+ withAnyPlan+ withInitDbEmptyInitially+ createDbCreatesTheDb dbName++ 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++ 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++ 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++ 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"++ before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith defaultIpPlan) stop f) $+ someStandardTests "test"++ before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith specificHostIpPlan) stop f) $+ someStandardTests "test"++ thePort <- runIO getFreePort+ let planFromCustomUserDbConnection = optionsToDefaultConfig mempty+ { Client.dbname = pure "fancy"+ , Client.user = pure "some_user"+ , Client.port = pure thePort+ }++ before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith planFromCustomUserDbConnection) stop f) $+ someStandardTests "fancy"++ 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++ let Just port = getLast $ Client.port $ postgresProcessClientConfig dbPostgresProcess+ Just host = getLast $ Client.host $ postgresProcessClientConfig dbPostgresProcess+ backupCommand = "pg_basebackup -D " ++ baseBackupFile ++ " --format=tar -p"+ ++ show port ++ " -h" ++ host+ putStrLn backupCommand+ system backupCommand `shouldReturn` ExitSuccess++ 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"++ PG.query_ conn "SELECT id FROM foo ORDER BY id ASC"+ `shouldReturn` [PG.Only (1 :: Int), PG.Only 2]++ 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'"++ 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 ()++ PG.query_ conn "SELECT id FROM foo ORDER BY id ASC"+ `shouldReturn` [PG.Only (1 :: Int)]
tmp-postgres.cabal view
@@ -1,5 +1,5 @@ name: tmp-postgres-version: 1.0.0.2+version: 1.0.1.0 synopsis: Start and stop a temporary postgres description: @tmp-postgres@ provides functions creating a temporary @postgres@ instance.@@ -56,7 +56,6 @@ , process >= 1.2.0.0 , unix , directory- , network , bytestring , postgresql-simple , postgres-options >= 0.2.0.0@@ -73,12 +72,10 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs- other-modules: Database.Postgres.Temp.InternalSpec build-depends: base , postgresql-libpq , tmp-postgres , hspec- , hspec-discover , temporary , directory , process@@ -90,6 +87,7 @@ , either , transformers , postgres-options+ , port-utils ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 default-extensions: LambdaCase