diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -45,3 +45,6 @@ 1.13.1.1 #116 Don't create postgres or template1 databases in optionsToDefaultConfig + +1.13.1.2 + #124 Respect database name in withNewDbConfig diff --git a/src/Database/Postgres/Temp/Internal.hs b/src/Database/Postgres/Temp/Internal.hs --- a/src/Database/Postgres/Temp/Internal.hs +++ b/src/Database/Postgres/Temp/Internal.hs @@ -537,11 +537,12 @@ -- connection options -- is used as the template for the @generated@ 'ProcessConfig'. -> IO (Either StartError DB) -startNewDbConfig extra db = try $ do +startNewDbConfig extra@ProcessConfig{..} db = try $ do stdGen <- getStdGen let oldOptions@Client.Options {..} = toConnectionOptions db theDbName = fromMaybe "postgres" $ getLast dbname - newDbName = take 32 $ randomRs ('a', 'z') stdGen + newDbName = fromMaybe (take 32 $ randomRs ('a', 'z') stdGen) $ + Map.lookup 0 $ indexBased commandLine newOptions = oldOptions { Client.dbname = pure newDbName } @@ -563,6 +564,7 @@ } envs <- getEnvironment final <- case completeProcessConfig envs combined of + -- Failure case does not look possible Left errs -> throwIO $ CompleteProcessConfigFailed (show $ pretty combined) errs Right x -> pure x terminateConnections oldOptions diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,647 @@ +import Control.Concurrent +import Control.Exception +import Control.Monad ((<=<), void) +import Data.Function +import qualified Data.Map.Strict as Map +import Data.Monoid +import Data.Monoid.Generic +import qualified Data.Set as Set +import Data.String +import qualified Database.PostgreSQL.Simple as PG +import qualified Database.PostgreSQL.Simple.Options as Client +import Database.Postgres.Temp.Internal +import Database.Postgres.Temp.Internal.Config +import Database.Postgres.Temp.Internal.Core +import GHC.Generics (Generic) +import qualified Network.Socket as N +import Network.Socket.Free +import System.Directory +import System.Environment +import System.Exit +import System.IO.Error +import System.IO.Temp +import System.Posix.Files +import System.Process +import System.Timeout +import Test.Hspec + +withConn :: DB -> (PG.Connection -> IO a) -> IO a +withConn db = bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close + +withConfig' :: Config -> (DB -> IO a) -> IO a +withConfig' config = either throwIO pure <=< withConfig config + +withNewDbConfig' :: ProcessConfig -> DB -> (DB -> IO a) -> IO a +withNewDbConfig' config db = either throwIO pure <=< + withNewDbConfig config db + +testSuccessfulConfigNoTmp :: ConfigAndAssertion -> IO () +testSuccessfulConfigNoTmp ConfigAndAssertion {..} = do + -- ensure the count of postgres processes that are child processes before is 0 + -- for each exception location + withConfig' cConfig $ \db -> do + cAssert db + -- check for a valid connection + one <- fmap (PG.fromOnly . head) $ + withConn db $ \conn -> PG.query_ conn "SELECT 1" + + one `shouldBe` (1 :: Int) + + -- ensure the count of postgres processes that are child processes after is 0 + +testSuccessfulConfig :: ConfigAndAssertion -> IO () +testSuccessfulConfig configAssert = do + -- get the temp listing before + testSuccessfulConfigNoTmp configAssert + -- get the temp listing after + +testWithTemporaryDirectory :: ConfigAndAssertion -> (ConfigAndAssertion -> IO a) -> IO a +testWithTemporaryDirectory x f = + withTempDirectory "/tmp" "tmp-postgres-spec" $ \directoryPath -> do + f x + { cConfig = (cConfig x) { temporaryDirectory = pure directoryPath } + , cAssert = cAssert x <> (\db -> toTemporaryDirectory db `shouldBe` directoryPath) + } + +data ConfigAndAssertion = ConfigAndAssertion + { cConfig :: Config + , cAssert :: DB -> IO () + } + deriving (Generic) + deriving Semigroup via GenericSemigroup ConfigAndAssertion + deriving Monoid via GenericMonoid ConfigAndAssertion + +-- Set all the things we support + +memptyConfigAndAssertion :: ConfigAndAssertion +memptyConfigAndAssertion = memptyConfigAndAssertion' "postgres" + +memptyConfigAndAssertion' :: String -> ConfigAndAssertion +memptyConfigAndAssertion' expectedDbName = + let + cConfig = mempty + cAssert db = do + let + Client.Options {..} = toConnectionOptions db + Last (Just hostString) = host + -- I'm assuming here that I'm going to test + -- with this prefix + hostString `shouldStartWith` "/tmp/tmp-postgres-" + -- Ephemeral range + let Just thePort = getLast port + thePort `shouldSatisfy` (>32768) + toDataDirectory db `shouldStartWith` "/tmp/tmp-postgres-" + dbname `shouldBe` pure expectedDbName + + in ConfigAndAssertion {..} + +optionsToDefaultConfigMempty :: ConfigAndAssertion +optionsToDefaultConfigMempty = memptyConfigAndAssertion + { cConfig = optionsToDefaultConfig mempty + } + +-- can't be combined +optionsToDefaultConfigSocket :: FilePath -> ConfigAndAssertion +optionsToDefaultConfigSocket socketPath = + let + cConfig = optionsToDefaultConfig mempty + { Client.host = pure socketPath + } + cAssert db = do + let + Client.Options {..} = toConnectionOptions db + Last (Just hostString) = host + -- I'm assuming here that I'm going to test + -- with this prefix + hostString `shouldStartWith` "/tmp/tmp-postgres-" + + in ConfigAndAssertion {..} + +optionsToDefaultConfigFilledOutConfigAssert :: Int -> ConfigAndAssertion +optionsToDefaultConfigFilledOutConfigAssert expectedPort = + let + expectedDbName = "fancy" + expectedUser = "some_user" + expectedPassword = "password" + expectedHost = "localhost" + + cConfig = optionsToDefaultConfig mempty + { Client.dbname = pure expectedDbName + , Client.user = pure expectedUser + , Client.port = pure expectedPort + , Client.password = pure expectedPassword + , Client.host = pure expectedHost + } + + cAssert db = do + let Client.Options {..} = toConnectionOptions db + port `shouldBe` pure expectedPort + user `shouldBe` pure expectedUser + host `shouldBe` pure expectedHost + password `shouldBe` pure expectedPassword + dbname `shouldBe` pure expectedDbName + + in ConfigAndAssertion {..} + +extraConfigAssert :: ConfigAndAssertion +extraConfigAssert = + let + cConfig = mempty + { plan = mempty + { postgresConfigFile = ["log_min_duration_statement='100ms'"] + } + } + + cAssert db = withConn db $ \conn -> do + [PG.Only actualDuration] <- PG.query_ conn "SHOW log_min_duration_statement" + actualDuration `shouldBe` ("100ms" :: String) + + in ConfigAndAssertion {..} + +defaultIpConfig :: ConfigAndAssertion +defaultIpConfig = + let + cConfig = mempty + { socketClass = IpSocket $ Last Nothing + } + + cAssert db = do + let Client.Options {..} = toConnectionOptions db + host `shouldBe` pure "127.0.0.1" + + in ConfigAndAssertion {..} + +-- TODO add check of actual host +specificHostIpConfigAssert :: ConfigAndAssertion +specificHostIpConfigAssert = + let + cConfig = mempty + { socketClass = IpSocket $ pure "localhost" + } + + cAssert db = do + let Client.Options {..} = toConnectionOptions db + host `shouldBe` pure "localhost" + + in ConfigAndAssertion {..} + +specificUnixSocket :: FilePath -> ConfigAndAssertion +specificUnixSocket filePath = + let + cConfig = mempty + { socketClass = UnixSocket $ Permanent filePath + } + cAssert db = do + let + Client.Options {..} = toConnectionOptions db + Last (Just hostString) = host + -- I'm assuming here that I'm going to test + -- with this prefix + hostString `shouldStartWith` filePath + + in ConfigAndAssertion {..} + +silentConfigAssert :: ConfigAndAssertion +silentConfigAssert = ConfigAndAssertion silentConfig mempty + +defaultConfigAssert :: ConfigAndAssertion +defaultConfigAssert = ConfigAndAssertion defaultConfig mempty + +createdbAndDescription :: ConfigAndAssertion +createdbAndDescription = + let + expectedDescription = "newdb description" + cConfig = mempty + { plan = mempty + { createDbConfig = pure silentProcessConfig + { commandLine = mempty + { indexBased = Map.fromList + [ (0, "newdb") + , (1, expectedDescription) + ] + } + } + } + } + + cAssert db = withConn db $ \conn -> do + [PG.Only actualDescription] <- PG.query_ conn $ fromString $ unlines + [ "SELECT description FROM pg_shdescription" + , "JOIN pg_database ON objoid = pg_database.oid" + , "WHERE datname = 'newdb'" + ] + actualDescription `shouldBe` expectedDescription + in ConfigAndAssertion {..} + +happyPaths :: Spec +happyPaths = describe "succeeds with" $ do + it "mempty and extra postgresql.conf" $ + testWithTemporaryDirectory + (silentConfigAssert <> memptyConfigAndAssertion <> extraConfigAssert) + testSuccessfulConfig + + it "optionsToDefaultConfig mempty is the same as mempty Config" $ + testWithTemporaryDirectory + optionsToDefaultConfigMempty + testSuccessfulConfig + + it "postgres db name does not cause createdb failure" $ do + testWithTemporaryDirectory + ( silentConfigAssert + <> memptyConfigAndAssertion + <> ConfigAndAssertion (optionsToDefaultConfig mempty { Client.dbname = pure "postgres" }) mempty + ) + testSuccessfulConfig + + it "template1 db name does not cause createdb failure" $ do + testWithTemporaryDirectory + ( silentConfigAssert + <> memptyConfigAndAssertion' "template1" + <> ConfigAndAssertion (optionsToDefaultConfig mempty { Client.dbname = pure "template1" }) mempty + ) + testSuccessfulConfig + + it "specific socket works with optionsToDefaultConfig" $ + withTempDirectory "/tmp" "tmp-postgres-spec-socket" $ \socketFilePath -> + testWithTemporaryDirectory + (optionsToDefaultConfigSocket socketFilePath) + testSuccessfulConfig + + it "filled out optionsToDefaultConfig" $ do + thePort <- getFreePort + testWithTemporaryDirectory + (optionsToDefaultConfigFilledOutConfigAssert thePort) + testSuccessfulConfig + + it "default ip option works" $ + testWithTemporaryDirectory + (silentConfigAssert <> defaultIpConfig) + testSuccessfulConfig + + it "specific ip option works" $ + testWithTemporaryDirectory + (defaultConfigAssert <> specificHostIpConfigAssert) + testSuccessfulConfig + + it "specific unix socket works" $ + withTempDirectory "/tmp" "tmp-postgres-spec-socket" $ \socketFilePath -> + testWithTemporaryDirectory + (silentConfigAssert <> specificUnixSocket socketFilePath) + testSuccessfulConfig + + it "works with the default temporary directory to some degree at least" $ + testSuccessfulConfigNoTmp $ silentConfigAssert <> + memptyConfigAndAssertion <> createdbAndDescription + + it "works if on non-empty if initdb is disabled" $ + withTempDirectory "/tmp" "tmp-postgres-preinitdb" $ \dirPath -> do + throwIfNotSuccess id =<< system ("initdb " <> dirPath) + let nonEmptyFolderConfig = memptyConfigAndAssertion + { cConfig = silentConfig + { dataDirectory = Permanent dirPath + , plan = (plan silentConfig) + { initDbConfig = Nothing + } + } + } + testWithTemporaryDirectory nonEmptyFolderConfig testSuccessfulConfig + + it "makeResourcesDataDirPermanent works" $ + withTempDirectory "/tmp" "tmp-postgres-make-premanent" $ \dirPath -> do + let config = silentConfig { temporaryDirectory = pure dirPath } + pathToCheck <- bracket (either throwIO (pure . makeDataDirPermanent) =<< startConfig config) stop $ + pure . toDataDirectory + doesDirectoryExist pathToCheck >>= \case + True -> pure () + False -> fail "temporary file was not made permanent" + +-- +-- Error Plans. Can't be combined. Just list them out inline since they can't be combined +-- + +errorPaths :: Spec +errorPaths = describe "fails when" $ do + -- Should this test ensure that atleast a single connection + -- attempt was made? probably. + it "timesout if the connection parameters are wrong" $ do + let invalidConfig = mempty + { plan = mempty + { connectionTimeout = pure 0 + , postgresPlan = mempty + { connectionOptions = mempty + { Client.dbname = pure "doesnotexist" + } + } + } + } + withConfig (silentConfig <> invalidConfig) (const $ pure ()) + `shouldReturn` Left ConnectionTimedOut + + it "does not timeout quickly with an invalid connection and large timeout" $ do + let invalidConfig = mempty + { plan = mempty + { connectionTimeout = pure maxBound + , postgresPlan = mempty + { connectionOptions = mempty + { Client.dbname = pure "doesnotexist" + } + } + } + } + timeout 100000 (withConfig (silentConfig <> invalidConfig) (const $ pure ())) + `shouldReturn` Nothing + it "throws StartPostgresFailed if the port is taken" $ + bracket openFreePort (N.close . snd) $ \(thePort, _) -> do + let invalidConfig = optionsToDefaultConfig mempty + { Client.port = pure thePort + , Client.host = pure "127.0.0.1" + } + withConfig invalidConfig (const $ pure ()) + `shouldReturn` Left (StartPostgresFailed $ ExitFailure 1) + + it "throws StartPostgresFailed if the host does not exist" $ do + let invalidConfig = optionsToDefaultConfig mempty + { Client.host = pure "focalhost" + } + withConfig invalidConfig (const $ pure ()) + `shouldReturn` Left (StartPostgresFailed $ ExitFailure 1) + + it "throws StartPostgresFailed if the host does not resolve to ip that is local" $ do + let invalidConfig = optionsToDefaultConfig mempty + { Client.host = pure "yahoo.com" + } + withConfig invalidConfig (const $ pure ()) + `shouldReturn` Left (StartPostgresFailed $ ExitFailure 1) + + it "throws StartPostgresFailed if the host path does not exist" $ do + let invalidConfig = optionsToDefaultConfig mempty + { Client.host = pure "/focalhost" + } + withConfig invalidConfig (const $ pure ()) + `shouldReturn` Left (StartPostgresFailed $ ExitFailure 1) + + it "No initdb plan causes failure" $ do + let dontTimeout = silentConfig + { plan = (plan silentConfig) + { connectionTimeout = pure maxBound + , initDbConfig = Nothing + } + } + + withConfig dontTimeout (const $ pure ()) + `shouldReturn` Left (StartPostgresFailed $ ExitFailure 1) + + it "initdb with non-empty data directory fails with InitDbFailed" $ + withTempDirectory "/tmp" "tmp-postgres-test" $ \dirPath -> do + writeFile (dirPath <> "/PG_VERSION") "1 million" + let nonEmptyFolderPlan = silentConfig + { dataDirectory = Permanent dirPath + } + + withConfig nonEmptyFolderPlan mempty >>= \case + Right () -> fail "Should not succeed" + Left ((InitDbFailed theOut theErr code)) -> do + code `shouldBe` ExitFailure 1 + length theOut `shouldSatisfy` (> 0) + length theErr `shouldSatisfy` (> 0) + Left err -> fail $ "Wrong type of error " <> show err + + it "invalid initdb options cause an error" $ do + let invalidConfig = silentConfig + { plan = (plan silentConfig) + { initDbConfig = pure silentProcessConfig + { commandLine = mempty + { keyBased = Map.singleton "--super-sync" Nothing + } + } + } + } + withConfig invalidConfig (const $ pure ()) >>= \case + Right () -> fail "Should not succeed" + Left (InitDbFailed {}) -> pure () + Left err -> fail $ "Wrong type of error " <> show err + + it "invalid createdb plan causes an error" $ do + let invalidConfig = silentConfig + { plan = (plan silentConfig) + { createDbConfig = pure silentProcessConfig + { commandLine = mempty + { indexBased = + Map.singleton 0 "template1" + } + } + } + + } + withConfig invalidConfig (const $ pure ()) >>= \case + Right () -> fail "Should not succeed" + Left (CreateDbFailed {}) -> pure () + Left err -> fail $ "Wrong type of error " <> show err + + it "throws if initdb is not on the path" $ do + path <- getEnv "PATH" + + bracket (setEnv "PATH" "/foo") (const $ setEnv "PATH" path) $ \_ -> + withConfig silentConfig (const $ pure ()) + `shouldThrow` isDoesNotExistError + + it "throws if createdb is not on the path" $ + withTempDirectory "/tmp" "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" + + let config = silentConfig + { plan = (plan silentConfig) + { createDbConfig = pure mempty + } + } + + bracket (setEnv "PATH" dir) (const $ setEnv "PATH" path) $ \_ -> + withConfig config (const $ pure ()) + `shouldThrow` isDoesNotExistError + +withConfigSpecs :: Spec +withConfigSpecs = describe "withConfig" $ do + happyPaths + errorPaths + +-- I nest the db creation to make sure I can do that +withNewDbSpecs :: Spec +withNewDbSpecs = describe "withNewDb" $ do + it "works" $ withConfig' silentConfig $ \db -> do + withConn db $ \conn -> do + _ <- PG.execute_ conn "CREATE TABLE foo ( id int );" + void $ PG.execute_ conn "INSERT INTO foo (id) VALUES (1);" + + withNewDbConfig' mempty db $ \newDb -> do + one <- fmap (PG.fromOnly . head) $ + withConn newDb $ \conn -> PG.query_ conn "SELECT id FROM foo" + + one `shouldBe` (1 :: Int) + + let expectedDbName = "newname" + specificDbName = mempty + { commandLine = mempty + { indexBased = + Map.singleton 0 expectedDbName + } + } + + withNewDbConfig' specificDbName db $ \newerDb -> do + Client.dbname (toConnectionOptions newerDb) `shouldBe` + pure expectedDbName + + oneAgain <- fmap (PG.fromOnly . head) $ + withConn newerDb $ \conn -> PG.query_ conn "SELECT id FROM foo" + + oneAgain `shouldBe` (1 :: Int) + + let invalidConfig = silentProcessConfig + { commandLine = mempty + { indexBased = + Map.singleton 0 "template1" + } + } + + withNewDbConfig invalidConfig db (const $ pure ()) >>= \case + Right () -> fail "Should not succeed" + Left (CreateDbFailed {}) -> pure () + Left err -> fail $ "Wrong type of error " <> show err + +spec :: Spec +spec = do + withConfigSpecs + + withNewDbSpecs + + it "stopPostgres cannot be connected to" $ withConfig' silentConfig $ \db -> do + stopPostgres db `shouldReturn` ExitSuccess + PG.connectPostgreSQL (toConnectionString db) `shouldThrow` + (\(_ :: IOError) -> True) + + it "reloadConfig works" $ withConfig' silentConfig $ \db -> do + let + dataDir = toDataDirectory db + 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 + + -- Not a great test but don't want to be too rigid + let createdbPlan = optionsToDefaultConfig mempty { Client.dbname = pure "newdb" } + it "prettyPrintConfig seems to work" $ do + let configString = prettyPrintConfig createdbPlan + + wordsToSearchFor = Set.fromList + [ "commandLine:" + , "connectionOptions:" + , "connectionTimeout:" + , "dataDirectory:" + , "dataDirectoryString:" + , "environmentVariables:" + , "inherit:" + , "initDbConfig:" + , "port:" + , "postgresConfig:" + , "postgresConfigFile:" + , "postgresPlan:" + , "socketClass:" + , "specific:" + , "stdErr:" + , "stdIn:" + , "stdOut:" + ] + shouldSatisfy (Set.fromList $ words configString) $ + Set.isSubsetOf wordsToSearchFor + + it "prettyPrintDB seems to work" $ withConfig' (createdbPlan <> silentConfig) $ \db -> do + let dbString = prettyPrintDB db + + wordsToSearchFor = Set.fromList + [ "completePlanInitDb:" + , "completePlanCreateDb:" + , "completePlanPostgres:" + , "completePlanConfig:" + , "completePlanDataDirectory:" + ] + + shouldSatisfy (Set.fromList $ words dbString) $ + Set.isSubsetOf wordsToSearchFor + + let justBackupResources = defaultPostgresConf + [ "wal_level=replica" + , "archive_mode=on" + , "max_wal_senders=2" + , "fsync=on" + , "synchronous_commit=on" + ] + backupResources = silentConfig <> justBackupResources + + it "can support backup and restore" $ withConfig' backupResources $ \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 $ postgresProcessClientOptions dbPostgresProcess + Just host = getLast $ Client.host $ postgresProcessClientOptions dbPostgresProcess + backupCommand = "pg_basebackup -D " ++ baseBackupFile ++ " --format=tar -p" + ++ show port ++ " -h" ++ host + + 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)] + + +main :: IO () +main = hspec spec diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,468 +0,0 @@ -import Test.Hspec -import Database.Postgres.Temp.Internal.Core -import Database.Postgres.Temp.Internal.Config -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) -import qualified Data.Map.Strict as Map -import Plans () - -main :: IO () -main = hspec spec - -withConfig' :: Config -> (DB -> IO a) -> IO a -withConfig' config = either throwIO pure <=< withConfig config - -with' :: (DB -> IO a) -> IO a -with' = either throwIO pure <=< with - -fromCreateDb :: Maybe ProcessConfig -> Config -fromCreateDb createDb = mempty - { plan = mempty - { createDbConfig = createDb - } - } - -newtype Runner = Runner (forall a. (DB -> IO a) -> IO a) - -withRunner :: (DB -> IO ()) -> Runner -> IO () -withRunner g (Runner f) = f g - --- --- TODO this test should only use the public interface --- - -defaultConfigShouldMatchDefaultPlan :: SpecWith Runner -defaultConfigShouldMatchDefaultPlan = - it "default options should match default plan" $ withRunner $ \DB{..} -> do - let Resources {..} = dbResources - CompletePlan {..} = resourcesPlan - CompletePostgresPlan {..} = completePlanPostgres - Client.dbname completePostgresPlanClientOptions `shouldBe` pure "postgres" - let CTemporary tmpDataDir = resourcesDataDir - tmpDataDir `shouldStartWith` "/tmp/tmp-postgres-data" - let Just port = getLast $ Client.port completePostgresPlanClientOptions - port `shouldSatisfy` (>32768) - let CUnixSocket (CTemporary unixSocket) = resourcesSocket - unixSocket `shouldStartWith` "/tmp/tmp-postgres-socket" - completePostgresPlanClientOptions `shouldBe` - (mempty - { Client.port = Client.port completePostgresPlanClientOptions - , Client.host = Client.host completePostgresPlanClientOptions - , Client.dbname = Client.dbname completePostgresPlanClientOptions - } - ) - --- --- This is basically the optionsToDefaultConfig but also tests custom postgresql.conf values --- Simplify and only test the custom conf and it can be combined with another test -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" $ withTempDirectory "/tmp" "tmp-postgres-spec" $ \tmpDir -> do - let customPlan = mempty - { temporaryDirectory = pure tmpDir - , plan = mempty - { postgresPlan = mempty - { connectionOptions = mempty - { Client.user = pure expectedUser - , Client.password = pure expectedPassword - , Client.dbname = pure expectedDbName - } - } - , initDbConfig = pure silentProcessConfig - { commandLine = mempty - { keyBased = - Map.singleton "--username=" $ Just "user-name" - } - , environmentVariables = mempty - { specific = Map.singleton "PGPASSWORD" "password" - , inherit = pure True - } - } - , createDbConfig = pure silentProcessConfig - { commandLine = mempty - { keyBased = - Map.singleton "--username=" $ Just "user-name" - , indexBased = - Map.singleton 0 expectedDbName - } - , environmentVariables = - mempty - { specific = Map.singleton "PGPASSWORD" "password" - , inherit = pure True - } - } - , postgresConfigFile = [extraConfig] - } - } - -- hmm maybe I should provide lenses - let combinedResources = silentConfig <> customPlan - - initialFiles <- listDirectory tmpDir - - action combinedResources $ \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 - CompletePlan {..} = resourcesPlan - actualOptions = completePostgresPlanClientOptions completePlanPostgres - actualPostgresConfig = completePlanConfig - Client.user actualOptions `shouldBe` pure expectedUser - Client.dbname actualOptions `shouldBe` pure expectedDbName - Client.password actualOptions `shouldBe` pure expectedPassword - lines actualPostgresConfig `shouldContain` defaultPostgresConfig <> [extraConfig] - - listDirectory tmpDir `shouldReturn` initialFiles - -invalidConfigFailsQuickly :: (Config -> IO ()) -> Spec -invalidConfigFailsQuickly action = it "quickly fails with an invalid option" $ do - let customPlan = mempty - { plan = mempty - { postgresConfigFile = - [ "log_directory = /this/does/not/exist" - , "logging_collector = true" - ] - } - } - timeout 5000000 (action $ silentConfig <> 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) - --- 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 theOut theErr code) -> do - code == ExitFailure 1 && length theErr > 0 && theOut == "") - -spec :: Spec -spec = do - let defaultIpPlan = silentConfig - { socketClass = IpSocket $ Last Nothing - } - - specificHostIpPlan = silentConfig - { socketClass = IpSocket $ pure "localhost" - } - - describe "withConfig" $ do - let startAction plan = either throwIO pure =<< - withConfig plan pure - - throwsIfInitDbIsNotOnThePath $ startAction silentConfig - invalidConfigFailsQuickly $ void . startAction - customConfigWork $ \plan f -> either throwIO pure =<< - withConfig plan f - - let someStandardTests dbName= do - withAnyPlan - withInitDbEmptyInitially - createDbCreatesTheDb dbName - - describe "withRestart" $ do - let startAction f = with' $ \db -> - either throwIO pure =<< withRestart db f - before (pure $ Runner startAction) $ do - someStandardTests "postgres" - defaultConfigShouldMatchDefaultPlan - --- --- TODO these can be combined --- - - describe "start/stop" $ do - before (pure $ Runner with') $ do - someStandardTests "postgres" - 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 - --- --- Keep this test. Invalid createdb options test --- - let invalidCreateDbPlan = silentConfig <> fromCreateDb - ( pure $ silentProcessConfig - { commandLine = mempty - { indexBased = - Map.singleton 0 "template1" - } - } - ) - before (pure $ Runner $ either throwIO pure <=< withConfig invalidCreateDbPlan) $ - createDbThrowsIfTheDbExists - --- TODO --- combine this test with another plan --- tests that the dbName can be specified in the options --- This is covered by optionsToDefaultConfig test - let noCreateTemplate1 = mempty - { plan = mempty - { createDbConfig = Nothing - , postgresPlan = mempty - { connectionOptions = mempty - { Client.dbname = pure "template1" - } - } - } - } - noCreateDbPlan = defaultConfig <> noCreateTemplate1 - before (pure $ Runner $ withConfig' noCreateDbPlan) $ - someStandardTests "template1" - --- --- Test the default IpSocket plan. Can be combined. --- - before (pure $ Runner $ withConfig' defaultIpPlan) $ - someStandardTests "postgres" - --- Specific IpSocket plan --- Can be combined --- - before (pure $ Runner $ withConfig' specificHostIpPlan) $ - someStandardTests "postgres" - --- --- This test is okay but can be combine with other tests --- and should use withNewDbConf mempty instead --- also need to test that I can make a specific database name - - before (pure $ Runner $ withConfig' silentConfig) $ - it "withNewDb works" $ withRunner $ \db -> do - bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close $ - \conn -> do - _ <- PG.execute_ conn "CREATE TABLE foo ( id int );" - void $ PG.execute_ conn "INSERT INTO foo (id) VALUES (1);" - - void $ withNewDb db $ \newDb -> do - one <- fmap (PG.fromOnly . head) $ - bracket (PG.connectPostgreSQL $ toConnectionString newDb ) PG.close $ - \conn -> PG.query_ conn "SELECT id FROM foo" - - one `shouldBe` (1 :: Int) - --- --- This is a optionsToDefaultConfig test --- It is missing the host options of both --- a socket and ip address based --- - - thePort <- runIO getFreePort - let planFromCustomUserDbConnection = optionsToDefaultConfig mempty - { Client.dbname = pure "fancy" - , Client.user = pure "some_user" - , Client.port = pure thePort - , Client.password = pure "password" - , Client.host = pure "localhost" - } - - before (pure $ Runner $ withConfig' planFromCustomUserDbConnection) $ - someStandardTests "fancy" - --- --- end optionsToDefaultConfig test --- - --- --- Keep this test -- small connection timeout works --- - let immediantlyTimeout = silentConfig <> mempty - { plan = mempty - { connectionTimeout = pure 0 - } - } - - before (pure $ Runner $ withConfig' immediantlyTimeout) $ - it "should timeout" $ \(Runner runner) -> - runner (const $ pure ()) `shouldThrow` (== ConnectionTimedOut) --- --- End this test --- - --- --- Keep these tests --- - 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 = silentConfig - { dataDirectory = Permanent dirPath - } - startAction = withConfig' nonEmptyFolderPlan $ const $ pure () - - startAction `shouldThrow` (\(InitDbFailed theOut theErr code) -> do - code == ExitFailure 1 && length theOut > 0 && length theErr > 0) - - it "works if on non-empty if initdb is disabled" $ \dirPath -> do - throwIfNotSuccess id =<< system ("initdb " <> dirPath) - let nonEmptyFolderPlan = silentConfig - { dataDirectory = Permanent dirPath - , plan = (plan silentConfig) - { initDbConfig = Nothing - } - } - withConfig' nonEmptyFolderPlan $ \db -> do - one <- fmap (PG.fromOnly . head) $ - bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close $ - \conn -> PG.query_ conn "SELECT 1" - - one `shouldBe` (1 :: Int) - --- --- Backup "test" --- - - let justBackupResources = mempty - { plan = mempty - { postgresConfigFile = - [ "wal_level=replica" - , "archive_mode=on" - , "max_wal_senders=2" - , "fsync=on" - , "synchronous_commit=on" - ] - } - } - backupResources = silentConfig <> justBackupResources - before (pure $ Runner $ withConfig' backupResources) $ - 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 $ postgresProcessClientOptions dbPostgresProcess - Just host = getLast $ Client.host $ postgresProcessClientOptions dbPostgresProcess - backupCommand = "pg_basebackup -D " ++ baseBackupFile ++ " --format=tar -p" - ++ show port ++ " -h" ++ host - - 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)] diff --git a/tmp-postgres.cabal b/tmp-postgres.cabal --- a/tmp-postgres.cabal +++ b/tmp-postgres.cabal @@ -1,5 +1,5 @@ name: tmp-postgres -version: 1.13.1.1 +version: 1.13.1.2 synopsis: Start and stop a temporary postgres description: Start and stop a temporary postgres. See README.md homepage: https://github.com/jfischoff/tmp-postgres#readme @@ -58,12 +58,14 @@ test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Spec.hs + main-is: Main.hs build-depends: base , containers , directory + , generic-monoid , hspec , mtl + , network , port-utils , postgres-options , postgresql-simple