diff --git a/src/Database/Postgres/Temp.hs b/src/Database/Postgres/Temp.hs --- a/src/Database/Postgres/Temp.hs +++ b/src/Database/Postgres/Temp.hs @@ -38,6 +38,11 @@ , startWithHandles -- * Stopping @postgres@ , stop + -- * Starting and Stopping postgres without removing the temporary directory + , startPostgres + , stopPostgres + -- * Reloading the config + , reloadConfig , SocketClass (..) ) where import Database.Postgres.Temp.Internal 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 @@ -19,6 +19,7 @@ import Network.Socket.Free (openFreePort) import Data.Foldable import Control.Concurrent.Async(race_) +import Data.IORef getFreePort :: IO Int getFreePort = do @@ -33,13 +34,28 @@ Left (_ :: IOError) -> threadDelay 10000 >> waitForDB connStr Right _ -> return () +-- A helper for dealing with locks +withLock :: MVar a -> IO b -> IO b +withLock m f = withMVar m (const f) data DB = DB - { mainDir :: FilePath + { mainDir :: FilePath -- ^ Temporary directory where the unix socket, logs and data directory live. , connectionString :: String -- ^ PostgreSQL connection string. - , pid :: ProcessHandle + , 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. } @@ -85,6 +101,7 @@ = InitDBFailed ExitCode | CreateDBFailed [String] ExitCode | StartPostgresFailed [String] ExitCode + | StartPostgresDisappeared [String] deriving (Show, Eq, Typeable) instance Exception StartError @@ -127,6 +144,98 @@ -> 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 'Nothinng'. +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) + host = case socketClass of + Localhost -> "127.0.0.1" + Unix -> mainDir + makeConnectionString dbName = "postgresql:///" + ++ dbName ++ "?host=" ++ host ++ "&port=" ++ show port + + waitForDB (makeConnectionString "template1") `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 $ do + 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 = do + fmap fourth $ createProcess_ "postgres" $ + procWith theStdOut theStdErr "postgres" postgresOptions + data Event = InitDB | WriteConfig @@ -148,7 +257,7 @@ -> Handle -> Handle -> IO (Either StartError DB) -startWithLogger logger socketType options mainDir stdOut stdErr = try $ flip onException (rmDirIgnoreErrors mainDir) $ do +startWithLogger logger socketClass options mainDir stdOut stdErr = try $ flip onException (rmDirIgnoreErrors mainDir) $ do let dataDir = mainDir ++ "/data" logger InitDB @@ -157,37 +266,39 @@ throwIfError InitDBFailed initDBExitCode logger WriteConfig - writeFile (dataDir ++ "/postgresql.conf") $ config $ if socketType == Unix then Just mainDir else Nothing + 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 host = case socketType of + let host = case socketClass of Localhost -> "127.0.0.1" Unix -> mainDir let makeConnectionString dbName = "postgresql:///" ++ dbName ++ "?host=" ++ host ++ "&port=" ++ show port connectionString = makeConnectionString "test" logger StartPostgres - let extraOptions = map (\(key, value) -> "--" ++ key ++ "=" ++ value) options - postgresOptions = ["-D", dataDir, "-p", show port] ++ extraOptions - bracketOnError ( fmap (DB mainDir connectionString . fourth) - $ createProcess_ "postgres" - (procWith stdOut stdErr "postgres" postgresOptions) - ) - stop - $ \result -> do + pidLock <- newMVar () - let checkForCrash = - getProcessExitCode (pid result) >>= - traverse_ (throwIO . StartPostgresFailed postgresOptions) + let postgresOptions = makePostgresOptions options dataDir port + createDBResult = do + thePid <- runPostgres stdOut stdErr postgresOptions + pid <- newIORef $ Just thePid + pure $ DB mainDir connectionString options 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 (makeConnectionString "template1") `race_` forever (checkForCrash >> threadDelay 100000) logger CreateDB - let createDBHostArgs = case socketType of + let createDBHostArgs = case socketClass of Unix -> ["-h", mainDir] Localhost -> ["-h", "127.0.0.1"] @@ -223,20 +334,8 @@ Right _ -> pure () -- Surprising ... but I do not know yet if this is a failure of termination or not. -- | Stop postgres and clean up the temporary database folder. -stop :: DB -> IO ExitCode +stop :: DB -> IO (Maybe ExitCode) stop db@DB {..} = do - - withProcessHandle pid (\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 () - ) - - result <- waitForProcess pid + result <- stopPostgres db removeDirectoryRecursive mainDir return result diff --git a/test/Database/Postgres/Temp/InternalSpec.hs b/test/Database/Postgres/Temp/InternalSpec.hs --- a/test/Database/Postgres/Temp/InternalSpec.hs +++ b/test/Database/Postgres/Temp/InternalSpec.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} -module Database.Postgres.Temp.InternalSpec (main, spec) where +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, QuasiQuotes, ScopedTypeVariables #-} +module Database.Postgres.Temp.InternalSpec where import Test.Hspec import System.IO.Temp import Database.Postgres.Temp.Internal @@ -15,9 +15,6 @@ import System.Timeout(timeout) import Data.Either -main :: IO () -main = hspec spec - mkDevNull :: IO Handle mkDevNull = openFile "/dev/null" WriteMode @@ -36,36 +33,36 @@ 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 - stdOut <- mkDevNull - stdErr <- mkDevNull + theStdOut <- mkDevNull + theStdErr <- mkDevNull shouldThrow - (startWithLogger (\currentEvent -> when (currentEvent == event) $ throwIO Except) Unix [] mainFilePath stdOut stdErr) + (startWithLogger (\currentEvent -> when (currentEvent == event) $ throwIO Except) Unix [] mainFilePath theStdOut theStdErr) (\Except -> True) doesDirectoryExist mainFilePath `shouldReturn` False countPostgresProcesses `shouldReturn` beforePostgresCount it "creates a useful connection string and stop still cleans up" $ \mainFilePath -> do beforePostgresCount <- countPostgresProcesses - stdOut <- mkDevNull - stdErr <- mkDevNull - result <- startWithLogger (\_ -> return ()) Unix [] mainFilePath stdOut stdErr + theStdOut <- mkDevNull + theStdErr <- mkDevNull + result <- startWithLogger (\_ -> return ()) Unix [] 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)" - stop db `shouldReturn` ExitSuccess + stop db `shouldReturn` Just ExitSuccess doesDirectoryExist mainFilePath `shouldReturn` False countPostgresProcesses `shouldReturn` beforePostgresCount it "can override settings" $ \mainFilePath -> do let expectedDuration = "100ms" - stdOut <- mkDevNull - stdErr <- mkDevNull + theStdOut <- mkDevNull + theStdErr <- mkDevNull bracket (startWithLogger (const $ pure ()) Unix [("log_min_duration_statement", expectedDuration)] - mainFilePath stdOut stdErr + mainFilePath theStdOut theStdErr ) (either (\_ -> return ()) (void . stop)) $ \result -> do db <- case result of @@ -76,12 +73,12 @@ actualDuration `shouldBe` expectedDuration it "dies promptly when a bad setting is passed" $ \mainFilePath -> do - stdOut <- mkDevNull - stdErr <- mkDevNull + theStdOut <- mkDevNull + theStdErr <- mkDevNull r <- timeout 5000000 $ startWithLogger (const $ pure ()) Unix [ ("log_directory", "/this/does/not/exist") , ("logging_collector", "true") - ] mainFilePath stdOut stdErr + ] mainFilePath theStdOut theStdErr case r of Nothing -> -- bad test, shouldSatisfy is difficult because it wants Show on DB. @@ -96,9 +93,9 @@ pure () it "terminateConnections" $ \mainFilePath -> do - stdOut <- mkDevNull - stdErr <- mkDevNull - bracket (fromRight (error "failed to start db") <$> startWithLogger (\_ -> return ()) Unix [] mainFilePath stdOut stdErr) stop $ \db -> do + theStdOut <- mkDevNull + theStdErr <- mkDevNull + bracket (fromRight (error "failed to start db") <$> startWithLogger (\_ -> return ()) Unix [] 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" `shouldReturn` [Only (2 :: Int)] @@ -107,3 +104,60 @@ bracket (connectPostgreSQL $ BSC.pack $ connectionString db) close $ \conn3 -> query_ conn3 "SELECT COUNT(*) FROM pg_stat_activity" `shouldReturn` [Only (1 :: Int)] + + -- 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 = + [ ("wal_level", "replica") + , ("archive_mode", "on") + , ("max_wal_senders", "2") + ] + + theStdOut <- mkDevNull + theStdErr <- mkDevNull + + 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" + + appendFile (dataDir ++ "/pg_hba.conf") $ "local replication all trust" + let 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_xlogfile_name(pg_switch_xlog())" + _ :: [Only String] <- query_ conn "SELECT pg_xlogfile_name(pg_create_restore_point('pitr'))" + _ <- execute_ conn "BEGIN ISOLATION LEVEL READ COMMITTED READ WRITE; INSERT INTO foo (id) VALUES (2); COMMIT" + + query_ conn "SELECT id FROM foo ORDER BY id ASC" + `shouldReturn` [Only (1 :: Int), Only 2] + + close conn + + stopPostgres db `shouldReturn` Just ExitSuccess + + removeDirectoryRecursive dataDir + createDirectory dataDir + let untarCommand = "tar -C" ++ dataDir ++ " -xf " ++ baseBackupFile ++ "/base.tar" + _ <- system untarCommand + _ <- system ("chmod -R 700 " ++ dataDir) + writeFile (dataDir ++ "/recovery.conf") $ "recovery_target_name='pitr'\nrecovery_target_inclusive=true\nrestore_command='" + ++ "cp " ++ walArchiveDir ++ "/%f %p'" + + startPostgres db + bracket (connectPostgreSQL $ BSC.pack $ connectionString db) close $ \conn1 -> do + query_ conn1 "SELECT id FROM foo ORDER BY id ASC" + `shouldReturn` [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: 0.1.2.2 +version: 0.2.0.0 synopsis: Start and stop a temporary postgres for testing description: This module provides functions creating a temporary postgres instance on a random port for testing. @@ -31,7 +31,7 @@ license-file: LICENSE author: Jonathan Fischoff maintainer: jonathangfischoff@gmail.com -copyright: 2017 Jonathan Fischoff +copyright: 2017-2019 Jonathan Fischoff category: Web build-type: Simple extra-source-files: README.md