diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,29 @@ ## [Unreleased] +## 0.20.0.0 — 2026-10-12 + +### Breaking Changes + +- Require the Kiroku 0.11 cohort from + mori://shinzui/kiroku/packages/kiroku-store; see the root changelog and + upgrade blueprint for subscription constructors, decoding, and migration + guidance. +- Require `kiroku-store-migrations ^>=0.7.1.0` from + mori://shinzui/kiroku/packages/kiroku-store-migrations. Stop workers for + migrations 0013 and 0014; plan the index build in 0015. The composed plan + now contains 47 migrations. + +### New Features + +- Add `withFreshResourceStoresSameDatabase` and + `withFreshResourceStoresSameDatabaseWithConnection` for independent resource + stores sharing one isolated database. +- Add `withMigratedBenchmarkSuite` for durable benchmark databases. It enables + fsync, synchronous commit, full-page writes and autovacuum locally, or uses an + external server supplied through `KEIRO_GUARDED_CATALOG_PG_ADMIN` while + creating and dropping only its uniquely named template and cloned databases. + ## 0.19.0.1 — 2026-10-05 ### Other Changes diff --git a/keiro-test-support.cabal b/keiro-test-support.cabal --- a/keiro-test-support.cabal +++ b/keiro-test-support.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: keiro-test-support -version: 0.19.0.1 +version: 0.20.0.0 synopsis: Shared PostgreSQL test fixtures for Keiro test suites description: Suite-level ephemeral-PostgreSQL fixtures shared by the Keiro test @@ -58,9 +58,9 @@ ephemeral-pg >=0.3.1 && <0.4, hasql >=1.10 && <1.11, hasql-pool >=1.2 && <1.5, - keiro-migrations ^>=0.19.0.1, - kiroku-store >=0.9.0.1 && <0.10, - kiroku-store-migrations ^>=0.6.0.0, + keiro-migrations ^>=0.20.0.0, + kiroku-store ^>=0.11.0.0, + kiroku-store-migrations ^>=0.7.1.0, pg-migrate ^>=1.2.0.0, stm >=2.5 && <2.6, text >=2.1 && <2.2, diff --git a/src/Keiro/Test/Postgres.hs b/src/Keiro/Test/Postgres.hs --- a/src/Keiro/Test/Postgres.hs +++ b/src/Keiro/Test/Postgres.hs @@ -25,6 +25,7 @@ ( Fixture, withMigratedSuite, withMigratedSuiteWith, + withMigratedBenchmarkSuite, withFreshDatabase, withFreshStore, withFreshStoreWith, @@ -33,6 +34,8 @@ withFreshResourceStoreWith, withFreshResourceStorePrepared, withFreshStores2, + withFreshResourceStoresSameDatabase, + withFreshResourceStoresSameDatabaseWithConnection, ) where @@ -46,6 +49,7 @@ import Effectful (Eff, IOE, Limit (..), Persistence (..), UnliftStrategy (..), runEff, withEffToIO) import Effectful.Error.Static (Error, runErrorNoCallStack) import EphemeralPg qualified as Pg +import GHC.Clock (getMonotonicTimeNSec) import Hasql.Connection.Settings qualified as Conn import Hasql.Pool qualified as Pool import Hasql.Pool.Config qualified as Pool.Config @@ -57,12 +61,14 @@ import Kiroku.Store.Error (StoreError) import Kiroku.Store.Migrations qualified as Kiroku import System.Directory (createDirectoryIfMissing) +import System.Environment (lookupEnv) import System.Posix.User (getEffectiveUserID) -- | A running, migrated suite fixture: one cached PostgreSQL server owning a -- single migrated template database, plus a counter for unique clone names. data Fixture = Fixture - { server :: Pg.Database, + { administrativeConnection :: Text, + databaseConnection :: Text -> Text, templateName :: Text, nextId :: TVar Int } @@ -111,13 +117,47 @@ withMigratedSuiteWith :: [MigrationComponent] -> (Fixture -> IO a) -> IO a withMigratedSuiteWith extraComponents action = do config <- ephemeralPgConfig + withConfiguredSuite config extraComponents action + +-- | Durable benchmark databases. An exclusively leased remote server may be +-- supplied through KEIRO_GUARDED_CATALOG_PG_ADMIN, a libpq keyword connection +-- string. Only uniquely named databases created here are dropped. Ordinary +-- correctness fixtures retain their fast local test configuration. +withMigratedBenchmarkSuite :: (Fixture -> IO a) -> IO a +withMigratedBenchmarkSuite action = + lookupEnv "KEIRO_GUARDED_CATALOG_PG_ADMIN" >>= \case + Nothing -> do + config <- ephemeralPgConfig + let durable = config {Pg.postgresSettings = filter (\(key, _) -> key `notElem` ["fsync", "synchronous_commit", "full_page_writes", "wal_level"]) config.postgresSettings <> [("fsync", "on"), ("synchronous_commit", "on"), ("full_page_writes", "on"), ("wal_level", "replica")]} + withConfiguredSuite durable [] action + Just prefix -> do + let connection = Text.pack prefix + if Text.null connection || "postgres://" `Text.isPrefixOf` connection || "postgresql://" `Text.isPrefixOf` connection + then fail "KEIRO_GUARDED_CATALOG_PG_ADMIN requires a libpq keyword connection string" + else do + unique <- getMonotonicTimeNSec + let template = "keiro_bench_" <> Text.pack (show unique) + connect name = connection <> " dbname=" <> name + bracket + ( do + runSqlOn connection ("CREATE DATABASE " <> quoteIdentifier template) + migrateTemplate [] (connect template) + `onException` runSqlOn connection ("DROP DATABASE " <> quoteIdentifier template <> " WITH (FORCE)") + counter <- newTVarIO 0 + pure (Fixture connection connect template counter) + ) + (\_ -> runSqlOn connection ("DROP DATABASE " <> quoteIdentifier template <> " WITH (FORCE)")) + action + +withConfiguredSuite :: Pg.Config -> [MigrationComponent] -> (Fixture -> IO a) -> IO a +withConfiguredSuite config extraComponents action = do started <- Pg.startCached config Pg.defaultCacheConfig case started of Left err -> fail (Text.unpack (Pg.renderStartError err)) Right server -> bracket (setup server `onException` Pg.stop server) - (\fixture -> Pg.stop fixture.server) + (const (Pg.stop server)) action where setup server = do @@ -128,7 +168,7 @@ -- released before any clone, so the template has no active sessions when -- PostgreSQL copies it. migrateTemplate extraComponents templateConnStr - pure (Fixture server templateDbName counter) + pure (Fixture (Pg.connectionString server) (connectionStringFor server) templateDbName counter) -- | Clone a fresh, empty, migrated database from the template, open a -- 'Store.KirokuStore' against it, run @action@, then drop the clone. The store @@ -159,7 +199,7 @@ -- | Like 'withFreshStore', but also supplies the resource-aware interpreter -- required by Keiro's transactional command runners. -withFreshResourceStore :: Fixture -> ((Store.KirokuStore, StoreRunner) -> IO ()) -> IO () +withFreshResourceStore :: Fixture -> ((Store.KirokuStore, StoreRunner) -> IO a) -> IO a withFreshResourceStore fixture = withFreshResourceStoreWith fixture id -- | Like 'withFreshResourceStore', with a connection-settings modifier for @@ -167,8 +207,8 @@ withFreshResourceStoreWith :: Fixture -> (Store.ConnectionSettings -> Store.ConnectionSettings) -> - ((Store.KirokuStore, StoreRunner) -> IO ()) -> - IO () + ((Store.KirokuStore, StoreRunner) -> IO a) -> + IO a withFreshResourceStoreWith fixture modify action = withFreshDatabase fixture \connStr -> runResourceStore (modify (Store.defaultConnectionSettings connStr)) action @@ -189,8 +229,8 @@ runResourceStore :: Store.ConnectionSettings -> - ((Store.KirokuStore, StoreRunner) -> IO ()) -> - IO () + ((Store.KirokuStore, StoreRunner) -> IO a) -> + IO a runResourceStore settings action = runEff $ withKirokuStore settings $ do @@ -201,6 +241,27 @@ StoreRunner (unlift . runErrorNoCallStack . runStoreResource) ) +-- | Independent resource-aware pools sharing one migrated database. Unlike +-- 'withFreshStores2', this fixture exercises contention in the same event store. +withFreshResourceStoresSameDatabase :: + Fixture -> + (((Store.KirokuStore, StoreRunner), (Store.KirokuStore, StoreRunner)) -> IO ()) -> + IO () +withFreshResourceStoresSameDatabase fixture action = + withFreshResourceStoresSameDatabaseWithConnection fixture (\_ -> action) + +-- | Also expose the clone's connection string for an independent SQL observer +-- or controller. All supplied stores are closed before the clone is dropped. +withFreshResourceStoresSameDatabaseWithConnection :: + Fixture -> + (Text -> ((Store.KirokuStore, StoreRunner), (Store.KirokuStore, StoreRunner)) -> IO ()) -> + IO () +withFreshResourceStoresSameDatabaseWithConnection fixture action = + withFreshDatabase fixture \connStr -> + runResourceStore (Store.defaultConnectionSettings connStr) \first -> + runResourceStore (Store.defaultConnectionSettings connStr) \second -> + action connStr (first, second) + -- | Like 'withFreshStore' but provides two independent migrated databases (and -- two stores) cloned from the same template — used by cross-context -- integration tests that need two isolated PostgreSQL databases. @@ -217,12 +278,12 @@ withFreshDatabase :: Fixture -> (Text -> IO a) -> IO a withFreshDatabase fixture action = bracket create dropDb \dbName -> - action (connectionStringFor fixture.server dbName) + action (fixture.databaseConnection dbName) where create = do n <- atomically $ stateTVar fixture.nextId \i -> (i + 1, i + 1) - let dbName = "keiro_test_" <> Text.pack (show n) - runSql fixture.server $ + let dbName = fixture.templateName <> "_" <> Text.pack (show n) + runSqlOn fixture.administrativeConnection $ "CREATE DATABASE " <> quoteIdentifier dbName <> " TEMPLATE " @@ -230,7 +291,7 @@ pure dbName dropDb dbName = - runSql fixture.server $ + runSqlOn fixture.administrativeConnection $ "DROP DATABASE IF EXISTS " <> quoteIdentifier dbName <> " WITH (FORCE)" migrateTemplate :: [MigrationComponent] -> Text -> IO ()