sydtest-persistent-postgresql 0.4.0.0 → 0.5.0.0
raw patch · 5 files changed
+602/−12 lines, 5 filesdep +directorydep +filepathdep +temporarysetup-changed
Dependencies added: directory, filepath, temporary, time, typed-process
Files
- CHANGELOG.md +43/−0
- Setup.hs +2/−0
- src/Test/Syd/Persistent/Postgresql.hs +505/−11
- sydtest-persistent-postgresql.cabal +8/−1
- test/Test/Syd/Persistent/Postgresql/StandbySpec.hs +44/−0
CHANGELOG.md view
@@ -1,5 +1,48 @@ # Changelog +## [0.5.0.0] - 2026-09-13++### Added++* A suite can run against a real PostgreSQL hot standby of the database it+ writes to, so an application that offloads reads onto a read replica can be+ tested on one. `persistPostgresqlReplicatedSpec` is `persistPostgresqlSpec`+ with a replica, and gives each test a `ReplicatedPools`: a pool to a fresh+ database on the primary, and a pool to the same database on the standby.++ The standby is a `pg_basebackup` streaming through a replication slot, held+ behind by `recovery_min_apply_delay` so that being behind is a fact rather+ than a race. It replays the same write-ahead log a production replica does,+ in the same order, and refuses writes because postgres refuses them.++* `onPrimary`, `onReplica` and `awaitReplica` for reaching either end and for+ waiting until the standby has caught up.++* `unreplicatedPools`, for the application that is configured without a+ replica: the same database through both pools, where `awaitReplica` returns+ at once.++* `ReplicaConfig` and `defaultReplicaConfig` for how far behind the replica is+ held, and `persistPostgresqlReplicatedSpecWith` to choose it.++* `persistPostgresqlReplicatedAdminSpec`, `replicatedPoolsSpec`,+ `postgresqlStandbySetupFunc`, `standbyPoolSetupFunc`,+ `replicatedPoolsSetupFunc`, `replicationPrimaryConfig`, `ReplicatedDB` and+ `Standby`, for a suite that needs the standby somewhere else in its resource+ stack.++* `postgresqlServerSetupFuncWith` and `persistPostgresqlAdminSpecWith`, which+ take the `tmp-postgres` configuration from the caller. `tmp-postgres`'+ `defaultConfig` asks for `wal_level = minimal`, which writes too little to+ the log for anything to replay and at which postgres refuses to start with a+ nonzero `max_wal_senders`, so the configuration had to become the caller's to+ choose.++* `testDatabaseSetupFunc`, which is `connectionPoolSetupFunc` plus the+ connection options the pool was opened with. A second connection to the same+ database, which is what the standby pool is, needs to know which database+ that is.+ ## [0.4.0.0] - 2026-05-17 ### Added
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
src/Test/Syd/Persistent/Postgresql.hs view
@@ -1,7 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -- | Testing with a temporary postgresql database using persistent-postgresql@@ -9,6 +13,7 @@ ( -- * Spec combinators persistPostgresqlSpec, persistPostgresqlAdminSpec,+ persistPostgresqlAdminSpecWith, persistPostgresqlDatabaseSpec, postgresqlMigrationSucceedsSpec, runPostgresqlTest,@@ -16,10 +21,36 @@ -- * Outer-stack handle TemplateDB, connectionPoolSetupFunc,+ testDatabaseSetupFunc, + -- * Read replicas+ -- $read-replicas+ persistPostgresqlReplicatedSpec,+ persistPostgresqlReplicatedSpecWith,+ ReplicatedPools (..),+ onPrimary,+ onReplica,+ awaitReplica,+ unreplicatedPools,+ ReplicaConfig (..),+ defaultReplicaConfig,+ ReplicatedDB (..),+ persistPostgresqlReplicatedAdminSpec,+ persistPostgresqlReplicatedAdminSpecWith,+ replicatedPoolsSpec,++ -- ** Assembling a replica by hand+ -- $read-replica-pieces+ Standby (..),+ replicationPrimaryConfig,+ postgresqlStandbySetupFunc,+ standbyPoolSetupFunc,+ replicatedPoolsSetupFunc,+ -- * Lower-level pieces -- $building-blocks postgresqlServerSetupFunc,+ postgresqlServerSetupFuncWith, postgresqlUserSetupFunc, postgresqlDatabaseSetupFunc, postgresqlPoolSetupFunc,@@ -28,20 +59,28 @@ ) where +import Control.Concurrent (threadDelay) import Control.Exception import Control.Monad import Control.Monad.Logger import Control.Monad.Reader import Data.Int+import Data.Maybe+import Data.Monoid (Last (..)) import Data.String import Data.Text (Text) import qualified Data.Text as Text+import Data.Time (NominalDiffTime) import Database.Persist.Postgresql import qualified Database.PostgreSQL.Simple as PostgreSQL import qualified Database.PostgreSQL.Simple.Options as Options import qualified Database.PostgreSQL.Simple.Options as Postgres import Database.Postgres.Temp as Temp+import System.Directory import System.Environment+import System.FilePath+import System.IO.Temp (withSystemTempDirectory)+import System.Process.Typed import System.Random import Test.Syd import Test.Syd.Persistent@@ -58,7 +97,12 @@ -- @tmp-postgres@ and tears it down on cleanup. Equivalent to the -- internal admin/superuser handle the other helpers need. postgresqlServerSetupFunc :: SetupFunc Temp.DB-postgresqlServerSetupFunc = SetupFunc $ \takeTempDB -> do+postgresqlServerSetupFunc = postgresqlServerSetupFuncWith adminConfig++-- | 'postgresqlServerSetupFunc' with the @tmp-postgres@ configuration chosen+-- by the caller.+postgresqlServerSetupFuncWith :: Temp.Config -> SetupFunc Temp.DB+postgresqlServerSetupFuncWith config = SetupFunc $ \takeTempDB -> do -- Clear PostgreSQL environment variables that might interfere with tmp-postgres unsetEnv "PGHOST" unsetEnv "PGPORT"@@ -66,7 +110,7 @@ unsetEnv "PGUSER" unsetEnv "PGPASSWORD" unsetEnv "PGDATA"- errOrRes <- Temp.withConfig adminConfig takeTempDB+ errOrRes <- Temp.withConfig config takeTempDB case errOrRes of Left err -> liftIO $ expectationFailure $ show err Right r -> pure r@@ -77,6 +121,434 @@ { Temp.createDbConfig = Temp.Zlich } +-- | 'adminConfig' for a server that can have a standby streaming from it.+--+-- 'Temp.defaultConfig' asks for @wal_level = minimal@, which writes too little+-- to the write-ahead log for anything to replay it, and at which postgres+-- refuses to start with a nonzero @max_wal_senders@. Both have to move+-- together.+replicationPrimaryConfig :: Temp.Config+replicationPrimaryConfig =+ adminConfig+ { Temp.postgresConfigFile =+ Temp.postgresConfigFile adminConfig+ ++ [ ("wal_level", "replica"),+ ("max_wal_senders", "4")+ ]+ }++-- $read-replicas+-- An application that offloads reads onto a read replica is an application+-- whose reads can be older than its writes. Give its suite one and find out+-- what it does about that:+--+-- > spec :: Spec+-- > spec = persistPostgresqlReplicatedSpec myMigration $+-- > it "serves what it was given" $ \pools -> do+-- > thing <- onPrimary pools $ insert something+-- > awaitReplica pools+-- > ...+--+-- As much to write as a suite without one.+--+-- 'replicatedPoolsPrimary' and 'replicatedPoolsReplica' are the pair such an+-- application is configured with, so they are the pair to hand it under test.+-- 'awaitReplica' is the one thing a test usually needs beyond them: most of a+-- test arranges what, in production, was arranged long before the request+-- under test, and a replica has all of that.++-- $read-replica-pieces+-- 'persistPostgresqlReplicatedSpec' is these composed. Reach for them when a+-- suite needs the standby somewhere else in its resource stack.++-- A 'Standby' is a real PostgreSQL hot standby streaming from a 'Temp.DB':+-- @pg_basebackup@ into a directory of its own, started with a replication+-- slot, torn down with the suite. It replays the+-- same write-ahead log a production replica does, in the same order, and+-- refuses writes because postgres refuses them.+--+-- Point the read-only half of an application at it to find out what the+-- application does when its reads are older than its writes.+--+-- Note what is a property of the cluster rather than of a database: how far+-- behind the standby is. Tests that share a server share their standby's lag,+-- so a test cannot pause replay or change the delay for itself alone. What it+-- can do is wait for the standby to catch up ('awaitReplica').++-- | A running hot standby of a 'Temp.DB'.+data Standby = Standby+ { -- | Connection options pointing at the standby. The database, user and+ -- password are the primary's; the host and port are the standby's.+ standbyConnectionOptions :: !Postgres.Options,+ standbyDataDirectory :: !FilePath+ }++-- | How far behind the replica is held.+newtype ReplicaConfig = ReplicaConfig+ { -- | Held this far behind, by @recovery_min_apply_delay@.+ --+ -- Zero lets it follow as fast as it can, which on one machine is fast+ -- enough that whether a read sees a just-committed write comes down to+ -- the machine. A delay makes being behind a fact.+ replicaConfigLag :: NominalDiffTime+ }++-- | Twenty milliseconds: what a replica that is keeping up looks like.+--+-- A larger delay tests less, despite sounding harsher. A replica far enough+-- behind to have replayed nothing answers every read with a clean miss, and a+-- clean miss is the case an application handles. Partway caught up, holding+-- one of two rows a query is choosing between, is what a real replica is at+-- any moment.+defaultReplicaConfig :: ReplicaConfig+defaultReplicaConfig = ReplicaConfig {replicaConfigLag = 0.02}++-- | As postgres spells an interval.+renderReplicaLag :: NominalDiffTime -> String+renderReplicaLag lag = show @Integer (round (lag * 1000)) ++ "ms"++-- | A 'SetupFunc' for a hot standby streaming from the given server.+--+-- The server has to have been started with 'replicationPrimaryConfig', or+-- there is no write-ahead log to stream.+postgresqlStandbySetupFunc :: ReplicaConfig -> Temp.DB -> SetupFunc Standby+postgresqlStandbySetupFunc ReplicaConfig {..} db = SetupFunc $ \takeStandby ->+ withSystemTempDirectory "sydtest-postgresql-standby" $ \tmpDir -> do+ let dataDir = tmpDir </> "data"+ let socketDir = tmpDir </> "socket"+ let logFile = tmpDir </> "standby.log"+ createDirectoryIfMissing True socketDir++ let primaryOptions = toConnectionOptions db+ let lastOr :: a -> Last a -> a+ lastOr d = fromMaybe d . getLast+ let primaryHost = lastOr "localhost" (Postgres.host primaryOptions)+ let primaryPort = lastOr 5432 (Postgres.port primaryOptions)++ slotName <- Text.unpack <$> genName "standby_slot"+ runProcessLoudly+ "pg_basebackup"+ $ concat+ [ [ "--pgdata=" ++ dataDir,+ "--host=" ++ primaryHost,+ "--port=" ++ show primaryPort+ ],+ -- Only when the server says who to connect as. Left out, libpq falls+ -- back to the operating system user, which is who a server that+ -- names nobody was initialised for.+ ["--username=" ++ user | user <- maybeToList (getLast (Postgres.user primaryOptions))],+ [ -- Writes standby.signal and primary_conninfo, which is what makes+ -- the copy a standby rather than a second copy of the data.+ "--write-recovery-conf",+ "--wal-method=stream",+ -- Never dropped, and a physical slot with nothing attached to it+ -- makes a server keep its write-ahead log forever. Harmless here+ -- only because the server this slot is on is torn down moments+ -- after the standby that holds it: compose this against one that+ -- outlives its standby and the log grows without bound.+ "--create-slot",+ "--slot=" ++ slotName+ ]+ ]++ -- tmp-postgres passes the port and socket directory on the command line+ -- rather than through postgresql.conf, so the base backup carries neither+ -- and the standby would come up on the default port.+ --+ -- A socket directory of its own keeps the two servers apart; the+ -- port only names a file inside it, so the standby keeps the primary's.+ -- postgresql.auto.conf, where --write-recovery-conf put primary_conninfo,+ -- is read after this file, so these cannot collide with it.+ appendFile (dataDir </> "postgresql.conf") $+ unlines $+ concat+ [ [ "port = " ++ show primaryPort,+ "unix_socket_directories = '" ++ socketDir ++ "'",+ "listen_addresses = ''",+ "hot_standby = on"+ ],+ ["recovery_min_apply_delay = '" ++ renderReplicaLag replicaConfigLag ++ "'"]+ ]++ let standby =+ Standby+ { standbyConnectionOptions =+ primaryOptions+ { Postgres.host = pure socketDir+ },+ standbyDataDirectory = dataDir+ }+ -- pg_ctl says only that the server did not start and to go and read the+ -- log, and the log is in a temporary directory that is about to be+ -- removed, so read it out while it is still there.+ let startStandby =+ runProcessLoudly "pg_ctl" ["-D", dataDir, "-l", logFile, "-w", "start"]+ `onException` (readFile logFile >>= putStr)+ -- Immediate: nothing here is worth a clean shutdown, and a standby+ -- that is deliberately behind would spend the apply delay on one.+ stopStandby = runProcessLoudly "pg_ctl" ["-D", dataDir, "-m", "immediate", "-w", "stop"]+ bracket_ startStandby stopStandby $ takeStandby standby++-- | 'awaitReplica' for a caller that has the two pools loose rather than in a+-- 'ReplicatedPools'.+--+-- A pool is all an application is given, so it is all its test harness can+-- count on having. Returns at once when the second pool is not a standby: a+-- primary is always caught up with itself.+awaitPoolCaughtUp :: ConnectionPool -> ConnectionPool -> IO ()+awaitPoolCaughtUp primaryPool standbyPool = do+ inRecovery <- runSingleQuery standbyPool "SELECT pg_is_in_recovery()"+ when inRecovery $ do+ target <- runSingleQuery primaryPool "SELECT pg_current_wal_insert_lsn()::text"+ let go :: Int -> IO ()+ go attemptsLeft = do+ caughtUp <-+ runSingleQuery+ standbyPool+ ( Text.concat+ [ "SELECT coalesce(pg_last_wal_replay_lsn() >= '",+ target,+ "'::pg_lsn, false)"+ ]+ )+ unless caughtUp $+ if attemptsLeft <= 0+ then+ expectationFailure $+ unwords+ [ "The standby did not replay up to",+ Text.unpack target,+ "within",+ show (pollAttempts * pollInterval `div` 1_000_000),+ "seconds."+ ]+ else do+ threadDelay pollInterval+ go (attemptsLeft - 1)+ go pollAttempts++runSingleQuery :: (PersistField a) => ConnectionPool -> Text -> IO a+runSingleQuery pool query =+ runNoLoggingT $+ runSqlPool+ ( do+ rows <- rawSql query []+ case rows of+ [Single a] -> pure a+ _ -> liftIO $ expectationFailure $ unwords ["Expected exactly one row from", show query]+ )+ pool++-- | Wait until the database the options name exists on the standby, then open+-- a pool to it.+--+-- The waiting is the point: a database created on the primary is not there+-- until the standby has replayed its creation, and until then a connection+-- fails outright rather than merely finding nothing.+standbyPoolSetupFunc :: Standby -> Postgres.Options -> SetupFunc ConnectionPool+standbyPoolSetupFunc standby options = do+ let standbyOptions =+ options+ { Postgres.host = Postgres.host (standbyConnectionOptions standby),+ Postgres.port = Postgres.port (standbyConnectionOptions standby)+ }+ liftIO $ awaitDatabase standbyOptions+ postgresqlPoolSetupFunc standbyOptions++-- | Retry connecting until it works, or until it has been failing long enough+-- that it is not going to.+--+-- Every failure is worth retrying here: until the standby has replayed the+-- database's creation there is no database to connect to, and libpq says so+-- differently depending on how far it got.+awaitDatabase :: Postgres.Options -> IO ()+awaitDatabase options = go pollAttempts+ where+ go :: Int -> IO ()+ go attemptsLeft = do+ errOrConn <-+ try $+ bracket+ (PostgreSQL.connectPostgreSQL (Options.toConnectionString options))+ PostgreSQL.close+ (\_ -> pure ())+ case errOrConn of+ Right () -> pure ()+ Left (err :: SomeException)+ | attemptsLeft <= 0 ->+ expectationFailure $+ unlines+ [ unwords+ [ "The standby never replayed the creation of the database",+ show (getLast (Postgres.dbname options)) ++ ":"+ ],+ displayException err+ ]+ | otherwise -> do+ threadDelay pollInterval+ go (attemptsLeft - 1)++-- | How long to wait between asking the standby again.+pollInterval :: Int+pollInterval = 10_000 -- 10ms++-- | How many times to ask before calling it a test failure rather than a wait.+--+-- Long enough that reaching it means the standby is never getting there, so+-- that such a standby fails the test rather than hanging the suite.+pollAttempts :: Int+pollAttempts = 6_000 -- a minute's worth++-- | One database, as an application that offloads reads onto a replica sees+-- it: the pool it writes through, and the pool it reads through.+--+-- This is the pair such an application is configured with, so it is the pair+-- to hand it under test.+data ReplicatedPools = ReplicatedPools+ { replicatedPoolsPrimary :: !ConnectionPool,+ replicatedPoolsReplica :: !ConnectionPool+ }++-- | The same database through both, which is what an application configured+-- without a read replica has.+--+-- Everything here works on these: 'awaitReplica' returns at once, because a+-- primary is always caught up with itself.+unreplicatedPools :: ConnectionPool -> ReplicatedPools+unreplicatedPools pool =+ ReplicatedPools+ { replicatedPoolsPrimary = pool,+ replicatedPoolsReplica = pool+ }++-- | Run a query on the primary, which is where an application writes.+--+-- 'runPostgresqlTest' for a suite that has a replica.+onPrimary :: ReplicatedPools -> SqlPersistM a -> IO a+onPrimary = runPostgresqlTest . replicatedPoolsPrimary++-- | Run a query on the replica, which is where an application reads.+--+-- What comes back is what the application would have seen, lag and all.+onReplica :: ReplicatedPools -> SqlPersistM a -> IO a+onReplica = runPostgresqlTest . replicatedPoolsReplica++-- | Wait until the replica has replayed everything the primary had committed+-- when this was called.+--+-- Only ever waiting, never pausing or hurrying the replica: how far behind it+-- is belongs to the cluster, and the tests sharing that cluster are running at+-- the same time as this one.+awaitReplica :: ReplicatedPools -> IO ()+awaitReplica ReplicatedPools {..} =+ awaitPoolCaughtUp replicatedPoolsPrimary replicatedPoolsReplica++-- | A server to write to and a replica of it to read from, for a whole suite.+--+-- One of each: a replica is a second server, and starting one per test would+-- cost more than the tests do.+data ReplicatedDB = ReplicatedDB+ { replicatedDBTemplate :: !TemplateDB,+ replicatedDBStandby :: !Standby+ }++replicatedDBSetupFunc :: ReplicaConfig -> Migration -> SetupFunc ReplicatedDB+replicatedDBSetupFunc config migration = do+ templateDB <- templateDBSetupFunc replicationPrimaryConfig migration+ standby <- postgresqlStandbySetupFunc config (fst templateDB)+ pure+ ReplicatedDB+ { replicatedDBTemplate = templateDB,+ replicatedDBStandby = standby+ }++-- | Declare a test suite that runs against a database and a read replica of+-- it.+--+-- 'persistPostgresqlSpec', with a replica. Every test gets its own database,+-- a pool to it, and a pool to the same database on the replica:+--+-- > spec :: Spec+-- > spec = persistPostgresqlReplicatedSpec migrateExample $+-- > it "reads back what it wrote" $ \pools -> do+-- > i <- onPrimary pools $ insert person+-- > awaitReplica pools+-- > mPerson <- onReplica pools $ get i+-- > mPerson `shouldBe` Just person+persistPostgresqlReplicatedSpec ::+ Migration ->+ TestDef (ReplicatedDB ': outers) ReplicatedPools ->+ TestDef outers a+persistPostgresqlReplicatedSpec = persistPostgresqlReplicatedSpecWith defaultReplicaConfig++-- | 'persistPostgresqlReplicatedSpec' with the replica held somewhere other+-- than 'defaultReplicaConfig' holds it.+persistPostgresqlReplicatedSpecWith ::+ ReplicaConfig ->+ Migration ->+ TestDef (ReplicatedDB ': outers) ReplicatedPools ->+ TestDef outers a+persistPostgresqlReplicatedSpecWith config migration =+ persistPostgresqlReplicatedAdminSpecWith config migration+ . replicatedPoolsSpec++-- | A server and a replica of it for the whole suite, and nothing per test.+--+-- 'persistPostgresqlAdminSpec' with a replica, for a suite that builds its own+-- per-test resources around the pair. Suites that want a database per test and+-- nothing else want 'persistPostgresqlReplicatedSpec' instead.+persistPostgresqlReplicatedAdminSpec ::+ Migration ->+ TestDef (ReplicatedDB ': outers) a ->+ TestDef outers a+persistPostgresqlReplicatedAdminSpec = persistPostgresqlReplicatedAdminSpecWith defaultReplicaConfig++-- | 'persistPostgresqlReplicatedAdminSpec' with the replica held somewhere+-- other than 'defaultReplicaConfig' holds it.+persistPostgresqlReplicatedAdminSpecWith ::+ ReplicaConfig ->+ Migration ->+ TestDef (ReplicatedDB ': outers) a ->+ TestDef outers a+persistPostgresqlReplicatedAdminSpecWith config migration =+ setupAroundAll (replicatedDBSetupFunc config migration)++-- | A database and a replica of it per test, from a 'ReplicatedDB' already in+-- the outer stack.+--+-- For a suite that puts other things around its database. Suites that do not+-- want 'persistPostgresqlReplicatedSpec' instead.+replicatedPoolsSpec ::+ (HContains outers ReplicatedDB) =>+ TestDef outers ReplicatedPools ->+ TestDef outers inner+replicatedPoolsSpec =+ setupAroundWith' $ \replicatedDB _ -> replicatedPoolsSetupFunc replicatedDB++-- | A fresh test database with pools to both ends of the replication.+replicatedPoolsSetupFunc :: ReplicatedDB -> SetupFunc ReplicatedPools+replicatedPoolsSetupFunc ReplicatedDB {..} = do+ (options, primaryPool) <- testDatabaseSetupFunc replicatedDBTemplate+ standbyPool <- standbyPoolSetupFunc replicatedDBStandby options+ pure+ ReplicatedPools+ { replicatedPoolsPrimary = primaryPool,+ replicatedPoolsReplica = standbyPool+ }++runProcessLoudly :: String -> [String] -> IO ()+runProcessLoudly cmd args = do+ (ec, out, err) <- readProcess (proc cmd args)+ case ec of+ ExitSuccess -> pure ()+ ExitFailure _ ->+ expectationFailure $+ unlines+ [ unwords ("Failed to run:" : cmd : args),+ show out,+ show err+ ]+ -- | Given libpq-style 'Postgres.Options', allocate a small -- 'ConnectionPool' to the database those options describe. postgresqlPoolSetupFunc :: Postgres.Options -> SetupFunc ConnectionPool@@ -260,14 +732,26 @@ Migration -> TestDef (TemplateDB ': outers) a -> TestDef outers a-persistPostgresqlAdminSpec migration =- setupAroundAll $ do- db <- postgresqlServerSetupFunc- (templateuser, templatepassword) <- postgresqlUserSetupFunc db- templatedb <- postgresqlDatabaseSetupFunc db templateuser- migrateTempDBSetupFunc db templateuser templatepassword templatedb migration- pure (db, (templateuser, templatepassword, templatedb))+persistPostgresqlAdminSpec = persistPostgresqlAdminSpecWith adminConfig +-- | 'persistPostgresqlAdminSpec' with the @tmp-postgres@ configuration chosen+-- by the caller.+persistPostgresqlAdminSpecWith ::+ Temp.Config ->+ Migration ->+ TestDef (TemplateDB ': outers) a ->+ TestDef outers a+persistPostgresqlAdminSpecWith config migration =+ setupAroundAll (templateDBSetupFunc config migration)++templateDBSetupFunc :: Temp.Config -> Migration -> SetupFunc TemplateDB+templateDBSetupFunc config migration = do+ db <- postgresqlServerSetupFuncWith config+ (templateuser, templatepassword) <- postgresqlUserSetupFunc db+ templatedb <- postgresqlDatabaseSetupFunc db templateuser+ migrateTempDBSetupFunc db templateuser templatepassword templatedb migration+ pure (db, (templateuser, templatepassword, templatedb))+ persistPostgresqlDatabaseSpec :: (HContains outers TemplateDB) => TestDef outers ConnectionPool -> TestDef outers a persistPostgresqlDatabaseSpec = setupAroundWith' $ \templatedb _ ->@@ -277,7 +761,16 @@ connectionPoolSetupFunc :: TemplateDB -> SetupFunc ConnectionPool-connectionPoolSetupFunc (db, (testuser, testpassword, templatedb)) = do+connectionPoolSetupFunc templateDB = snd <$> testDatabaseSetupFunc templateDB++-- | 'connectionPoolSetupFunc', but also saying which database the pool is to.+--+-- The name is what a second connection to the same database needs, which is+-- what a standby pool ('standbyPoolSetupFunc') is.+testDatabaseSetupFunc ::+ TemplateDB ->+ SetupFunc (Postgres.Options, ConnectionPool)+testDatabaseSetupFunc (db, (testuser, testpassword, templatedb)) = do testdb <- tempCopiedDatabaseSetupFunc db@@ -289,7 +782,8 @@ Postgres.password = pure (Text.unpack testpassword), Postgres.dbname = pure (Text.unpack testdb) }- postgresqlPoolSetupFunc options+ pool <- postgresqlPoolSetupFunc options+ pure (options, pool) -- | A 'SetupFunc' that provides connection 'Postgres.Options' for a -- fresh empty database — its own server, its own user, its own empty
sydtest-persistent-postgresql.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest-persistent-postgresql-version: 0.4.0.0+version: 0.5.0.0 synopsis: An persistent-postgresql companion library for sydtest category: Testing homepage: https://github.com/NorfairKing/sydtest#readme@@ -39,6 +39,8 @@ src build-depends: base >=4.7 && <5+ , directory+ , filepath , monad-logger , mtl , persistent-postgresql@@ -47,8 +49,11 @@ , random , sydtest , sydtest-persistent+ , temporary , text+ , time , tmp-postgres+ , typed-process default-language: Haskell2010 test-suite sydtest-persistent-postgresql-test@@ -56,6 +61,7 @@ main-is: Spec.hs other-modules: Test.Syd.Persistent.Example+ Test.Syd.Persistent.Postgresql.StandbySpec Test.Syd.Persistent.PostgresqlSpec Paths_sydtest_persistent_postgresql hs-source-dirs:@@ -66,6 +72,7 @@ build-depends: base >=4.7 && <5 , persistent+ , postgresql-simple , sydtest , sydtest-persistent-postgresql default-language: Haskell2010
+ test/Test/Syd/Persistent/Postgresql/StandbySpec.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Syd.Persistent.Postgresql.StandbySpec (spec) where++import Database.Persist+import Database.PostgreSQL.Simple (SqlError (..))+import Test.Syd+import Test.Syd.Persistent.Example+import Test.Syd.Persistent.Postgresql++spec :: Spec+spec =+ describe "persistPostgresqlReplicatedSpec" $+ persistPostgresqlReplicatedSpec migrateExample $ do+ it "does not show a write on the replica while it is behind" $ \pools -> do+ let p = Person {personName = "John Doe", personAge = Just 21}+ i <- onPrimary pools $ insert p+ mPerson <- onReplica pools $ get i+ mPerson `shouldBe` Nothing++ it "shows the write on the replica once it has caught up" $ \pools -> do+ let p = Person {personName = "Jane Doe", personAge = Just 22}+ i <- onPrimary pools $ insert p+ awaitReplica pools+ mPerson <- onReplica pools $ get i+ mPerson `shouldBe` Just p++ -- A hot standby is read-only because postgres refuses the write, not+ -- because the test was told to pretend.+ it "refuses a write through the replica" $ \pools -> do+ let p = Person {personName = "Jim Doe", personAge = Just 23}+ onReplica pools (insert_ p)+ `shouldThrow` (\(e :: SqlError) -> sqlState e == "25006")++ -- An application configured without a read replica reads and writes+ -- through the one pool it has, and everything here still works on it.+ it "reads back at once through pools that are not replicated" $ \pools -> do+ let unreplicated = unreplicatedPools (replicatedPoolsPrimary pools)+ let p = Person {personName = "Jess Doe", personAge = Just 25}+ i <- onPrimary unreplicated $ insert p+ awaitReplica unreplicated+ mPerson <- onReplica unreplicated $ get i+ mPerson `shouldBe` Just p