diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,37 @@ +# Changelog + +All notable changes to `keiro-test-support` are recorded here. The format follows +[Keep a Changelog](https://keepachangelog.com/), and the package follows the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.14.0.0 — 2026-08-21 + +First published release. `keiro-test-support` existed in the repository from the +beginning as an internal fixture library; it is published from this release on so +that the Keiro packages' test-suites are buildable from their Hackage tarballs, +and so that consumers can reuse the same fixtures for their own Keiro services. + +It enters the lockstep package set directly at the shared version 0.14.0.0 rather +than at its internal `0.1.0.0`, because a released `keiro-test-support` must say +which Keiro it pairs with. Its `keiro-migrations` dependency moves in lockstep +from here on. + +### New Features + +- `Keiro.Test.Postgres` exposes the suite-level `ephemeral-pg` template-database + fixture: `withMigratedSuite` / `withMigratedSuiteWith` start one cached server + and migrate one template database per suite, and `withFreshDatabase`, + `withFreshStore`, `withFreshStoreWith`, `withFreshResourceStore`, + `withFreshResourceStoreWith`, and `withFreshStores2` clone an isolated database + per example. `Fixture` is abstract and `StoreRunner` is exported for callers + that supply their own store runner. + +### Other Changes + +- Every dependency now carries a PVP upper bound. As an internal package it had + open-ended bounds on `aeson`, `containers`, `effectful`, `ephemeral-pg`, + `hasql`, `hasql-pool`, `stm`, `text`, and an entirely unbounded + `keiro-migrations`; all are bounded to match the rest of the package set. +- Ships a `LICENSE` file, like every other published package in the set. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +BSD 3-Clause License + +Copyright (c) 2026, Nadeem Bitar + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT INCLUDING +NEGLIGENCE OR OTHERWISE ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/keiro-test-support.cabal b/keiro-test-support.cabal new file mode 100644 --- /dev/null +++ b/keiro-test-support.cabal @@ -0,0 +1,57 @@ +cabal-version: 3.0 +name: keiro-test-support +version: 0.14.0.0 +synopsis: Shared PostgreSQL test fixtures for Keiro test suites +description: + Suite-level ephemeral-PostgreSQL fixtures shared by the Keiro test + suites. Implements the ephemeral-pg template-database pattern: one cached + server per suite, one migrated template database, and a clean cloned + database per example. + +license: BSD-3-Clause +license-file: LICENSE +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: 2026 Nadeem Bitar +category: Testing +homepage: https://github.com/shinzui/keiro#readme +bug-reports: https://github.com/shinzui/keiro/issues +build-type: Simple +extra-doc-files: CHANGELOG.md +tested-with: GHC >=9.12 && <9.13 + +source-repository head + type: git + location: https://github.com/shinzui/keiro.git + +common warnings + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + +library + import: warnings + default-language: GHC2024 + default-extensions: + BlockArguments + ImportQualifiedPost + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + + exposed-modules: Keiro.Test.Postgres + hs-source-dirs: src + build-depends: + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , containers >=0.6 && <0.8 + , effectful >=2.6 && <2.7 + , ephemeral-pg >=0.2 && <0.3 + , hasql >=1.10 && <1.11 + , hasql-pool >=1.2 && <1.5 + , keiro-migrations ^>=0.14.0.0 + , kiroku-store >=0.8 && <0.9 + , kiroku-store-migrations ^>=0.4.0.0 + , pg-migrate ^>=1.1.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 new file mode 100644 --- /dev/null +++ b/src/Keiro/Test/Postgres.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedRecordDot #-} + +-- | Suite-level PostgreSQL test fixture for Keiro test suites. +-- +-- This follows the @ephemeral-pg@ "suite-level template databases" best practice: +-- start one cached PostgreSQL server for the whole suite, migrate a template +-- database once, and clone a fresh, isolated database per example with +-- PostgreSQL's @CREATE DATABASE ... TEMPLATE ...@. Each example still receives an +-- empty, isolated database, but the expensive work — server startup and running +-- the Kiroku and Keiro migrations — happens once per suite rather than once per +-- example. +-- +-- Usage from @hspec@: +-- +-- @ +-- main :: IO () +-- main = +-- 'withMigratedSuiteWith' [pgmqMigrations] \\fixture -> +-- hspec $ +-- describe "..." $ around ('withFreshStore' fixture) $ do +-- it "..." $ \\store -> ... +-- @ +module Keiro.Test.Postgres + ( Fixture, + withMigratedSuite, + withMigratedSuiteWith, + withFreshDatabase, + withFreshStore, + withFreshStoreWith, + StoreRunner (..), + withFreshResourceStore, + withFreshResourceStoreWith, + withFreshStores2, + ) +where + +import Control.Concurrent.STM (TVar, atomically, newTVarIO, stateTVar) +import Control.Exception (bracket, onException) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Data.Text qualified as Text +import Database.PostgreSQL.Migrate (MigrationComponent, defaultRunOptions, migrationPlan, runMigrationPlan) +import Effectful (Eff, IOE, Limit (..), Persistence (..), UnliftStrategy (..), runEff, withEffToIO) +import Effectful.Error.Static (Error, runErrorNoCallStack) +import EphemeralPg qualified as Pg +import Hasql.Connection.Settings qualified as Conn +import Hasql.Pool qualified as Pool +import Hasql.Pool.Config qualified as Pool.Config +import Hasql.Session qualified as Session +import Keiro.Migrations (keiroMigrations) +import Kiroku.Store qualified as Store +import Kiroku.Store.Effect (Store, runStoreResource) +import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore, withKirokuStore) +import Kiroku.Store.Error (StoreError) +import Kiroku.Store.Migrations qualified as Kiroku + +-- | 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, + templateName :: Text, + nextId :: TVar Int + } + +templateDbName :: Text +templateDbName = "keiro_template" + +-- | Start one cached PostgreSQL server, create a template database, apply the +-- Kiroku event-store schema and Keiro framework schema to it once, then run +-- @action@ with the resulting 'Fixture'. The server is stopped on exit. +-- +-- 'EphemeralPg.startCached' restores a clean @initdb@ cluster (no schema), and +-- 'Kiroku.Store.withStore' deliberately creates no tables, so the migrations +-- are applied here against the template before any example clones it. +withMigratedSuite :: (Fixture -> IO a) -> IO a +withMigratedSuite = withMigratedSuiteWith [] + +-- | Like 'withMigratedSuite', but appends extra @pg-migrate@ components to the +-- framework plan so the template database also carries their schema — for example +-- @pgmq-migration@'s @pgmqMigrations@. The extra components are applied after +-- Kiroku's and Keiro's, in the order given, and before any example database is +-- cloned. +-- +-- They join the framework plan rather than running as a separate plan because a +-- @pg-migrate@ ledger is shared by every component in it: a plan that omits a +-- component already recorded in the ledger fails strict verification with +-- @UnknownStoredMigration@. +withMigratedSuiteWith :: [MigrationComponent] -> (Fixture -> IO a) -> IO a +withMigratedSuiteWith extraComponents action = do + started <- Pg.startCached Pg.defaultConfig 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) + action + where + setup server = do + counter <- newTVarIO 0 + runSql server ("CREATE DATABASE " <> quoteIdentifier templateDbName) + let templateConnStr = connectionStringFor server templateDbName + -- Apply migrations through short-lived pg-migrate connections, all of which are + -- released before any clone, so the template has no active sessions when + -- PostgreSQL copies it. + migrateTemplate extraComponents templateConnStr + pure (Fixture 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 +-- (including its notifier and publisher connections) is torn down before the +-- database is dropped. +withFreshStore :: Fixture -> (Store.KirokuStore -> IO ()) -> IO () +withFreshStore fixture = withFreshStoreWith fixture id + +-- | Like 'withFreshStore' but applies @modify@ to the default connection +-- settings before opening the store — for example to add an application projection +-- schema to @extraSearchPath@ so a read-model table in that schema resolves on the +-- store pool (see 'Keiro.Connection.withProjectionSchema'). The store @schema@ +-- field itself is left at kiroku's default. +withFreshStoreWith :: + Fixture -> + (Store.ConnectionSettings -> Store.ConnectionSettings) -> + (Store.KirokuStore -> IO ()) -> + IO () +withFreshStoreWith fixture modify action = + withFreshDatabase fixture \connStr -> + Store.withStore (modify (Store.defaultConnectionSettings connStr)) action + +-- | A reusable interpreter for computations that need both the dynamic +-- 'Store' effect and the resource effect carrying the same live store handle. +newtype StoreRunner + = StoreRunner + (forall a. Eff '[Store, Error StoreError, KirokuStoreResource, IOE] a -> IO (Either StoreError a)) + +-- | 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 = withFreshResourceStoreWith fixture id + +-- | Like 'withFreshResourceStore', with a connection-settings modifier for +-- projection schemas or store hooks. +withFreshResourceStoreWith :: + Fixture -> + (Store.ConnectionSettings -> Store.ConnectionSettings) -> + ((Store.KirokuStore, StoreRunner) -> IO ()) -> + IO () +withFreshResourceStoreWith fixture modify action = + withFreshDatabase fixture \connStr -> + runEff $ + withKirokuStore (modify (Store.defaultConnectionSettings connStr)) $ do + store <- getKirokuStore + withEffToIO (ConcUnlift Persistent Unlimited) \unlift -> + action + ( store, + StoreRunner (unlift . runErrorNoCallStack . runStoreResource) + ) + +-- | 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. +withFreshStores2 :: Fixture -> ((Store.KirokuStore, Store.KirokuStore) -> IO ()) -> IO () +withFreshStores2 fixture action = + withFreshDatabase fixture \connStrA -> + withFreshDatabase fixture \connStrB -> + Store.withStore (Store.defaultConnectionSettings connStrA) \storeA -> + Store.withStore (Store.defaultConnectionSettings connStrB) \storeB -> + action (storeA, storeB) + +-- | Clone a fresh database from the template, pass its connection string to +-- @action@, and drop it afterwards. Database names are unique per clone. +withFreshDatabase :: Fixture -> (Text -> IO a) -> IO a +withFreshDatabase fixture action = + bracket create dropDb \dbName -> + action (connectionStringFor fixture.server 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 $ + "CREATE DATABASE " + <> quoteIdentifier dbName + <> " TEMPLATE " + <> quoteIdentifier fixture.templateName + pure dbName + + dropDb dbName = + runSql fixture.server $ + "DROP DATABASE IF EXISTS " <> quoteIdentifier dbName <> " WITH (FORCE)" + +migrateTemplate :: [MigrationComponent] -> Text -> IO () +migrateTemplate extraComponents connStr = do + kiroku <- either (fail . show) pure Kiroku.kirokuMigrations + keiro <- either (fail . show) pure keiroMigrations + plan <- either (fail . show) pure (migrationPlan (kiroku :| keiro : extraComponents)) + result <- + runMigrationPlan + defaultRunOptions + (Conn.connectionString connStr) + plan + either (fail . show) (const (pure ())) result + +-- | Build a libpq connection string for a named database on the fixture's +-- server, addressing it over the server's Unix socket. +connectionStringFor :: Pg.Database -> Text -> Text +connectionStringFor db dbName = + Text.unwords + [ "host=" <> Text.pack db.socketDirectory, + "port=" <> Text.pack (show db.port), + "dbname=" <> dbName, + "user=" <> db.user + ] + +-- | Run a single SQL command against the server's default database (used for +-- @CREATE DATABASE@ / @DROP DATABASE@, which cannot run inside a transaction). +runSql :: Pg.Database -> Text -> IO () +runSql db = runSqlOn (Pg.connectionString db) + +runSqlOn :: Text -> Text -> IO () +runSqlOn connStr sql = + bracket acquire Pool.release \pool -> + Pool.use pool (Session.script sql) >>= either (fail . show) pure + where + acquire = + Pool.acquire $ + Pool.Config.settings + [ Pool.Config.staticConnectionSettings (Conn.connectionString connStr), + Pool.Config.size 1 + ] + +quoteIdentifier :: Text -> Text +quoteIdentifier ident = + "\"" <> Text.replace "\"" "\"\"" ident <> "\""