keiro-test-support (empty) → 0.14.0.0

raw patch · 4 files changed

+356/−0 lines, 4 filesdep +aesondep +basedep +containers

Dependencies added: aeson, base, containers, effectful, ephemeral-pg, hasql, hasql-pool, keiro-migrations, kiroku-store, kiroku-store-migrations, pg-migrate, stm, text

Files

• CHANGELOG.md +37/−0
• LICENSE +28/−0
• keiro-test-support.cabal +57/−0
• src/Keiro/Test/Postgres.hs +234/−0

@@ -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.

@@ -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.

@@ -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

@@ -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 <> "\""