tmp-postgres 0.1.2.2 → 0.2.0.0
raw patch · 4 files changed
+212/−54 lines, 4 files
Files
- src/Database/Postgres/Temp.hs +5/−0
- src/Database/Postgres/Temp/Internal.hs +130/−31
- test/Database/Postgres/Temp/InternalSpec.hs +75/−21
- tmp-postgres.cabal +2/−2
src/Database/Postgres/Temp.hs view
@@ -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
src/Database/Postgres/Temp/Internal.hs view
@@ -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
test/Database/Postgres/Temp/InternalSpec.hs view
@@ -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)]
tmp-postgres.cabal view
@@ -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