packages feed

kiroku-store (empty) → 0.2.0.0

raw patch · 50 files changed

Files

+ CHANGELOG.md view
@@ -0,0 +1,388 @@+# Changelog++## Unreleased++## 0.2.0.0 — 2026-05-31++### Breaking Changes++* `currentState` changed type from `m SubscriptionState` to+  `m (Maybe SubscriptionState)` and is now resolved through the central registry+  by `(name, member)` and this handle's token: `Just s` while the worker is live+  and still owns the entry, `Nothing` once it has stopped/cancelled/crashed (its+  registry key is removed), before it starts, or after a newer worker supersedes+  the same key. This makes the registry genuinely the single source of truth for+  live state and unifies the "stopped = absent" rule across `currentState` and+  the snapshot. (The worker still solely writes its `stateVar`; only the handle's+  read path moved to a registry lookup of that same cell.) A deliberate pre-1.0+  breaking change.++### New Features++#### Per-batch delivery event (plan 46)++* New additive `KirokuEvent` constructor+  `KirokuEventSubscriptionDelivered !SubscriptionName !Int !SubscriptionDeliveryPhase !SubscriptionGroupContext`,+  emitted **once per non-empty batch** from the single delivery primitive+  `processEvents` — on **every** target (`$all`, category, consumer group) and in+  **both** the catch-up and live phases. The `Int` is the batch row count+  (always `>= 1`); the new `SubscriptionDeliveryPhase` (`DeliveredCatchUp` /+  `DeliveredLive`, also exported) is derived from the worker's driving FSM state.+  This makes an `$all` subscription's live deliveries observable, closing the gap+  where the `(Nothing, AllStreams)` live path emitted no per-batch event.+* `KirokuEventSubscriptionFetched` is **unchanged** and still emitted by the+  DB-driven live loops per fetch (the live-fetch-rate signal); a DB-driven live+  batch therefore emits both `Fetched` (the fetch) and `Delivered` (the delivery).++#### Central subscription-state registry (plan 45)++* `KirokuStore` gains a `subscriptionRegistry` field: a central, in-memory map+  keyed by `(SubscriptionName, member)` holding every live subscription worker's+  FSM-state cell, each guarded by a per-worker `Data.Unique.Unique` token. Each+  `subscribe` registers its worker's existing state `TVar` on start and removes+  it on any exit (stop, cancel, crash) via the worker's `finally` cleanup; the+  delete is token-conditional, so an older duplicate-key worker cannot delete a+  newer worker's replacement entry. The worker's writes are unchanged.+* New public view type `SubscriptionStateView { subscriptionName, member, state,+  statePhase, cursor }` (`deriving stock (Show, Generic)`) — the committed+  observability surface external consumers read via `^. #field`. New accessor+  `subscriptionStates :: KirokuStore -> IO (Map (SubscriptionName, Int32)+  SubscriptionStateView)` returns a near-instant snapshot of every live+  subscription as view records: it snapshots the outer map and reads each cell+  with `readTVarIO` (no large STM read set, so the reader never retries). Both+  re-exported from `Kiroku.Store`. This map of view records is the foundation+  for a future Prometheus exporter and admin tool (named future consumers, not+  built here), and the performant live-state layer that closes the OpenTelemetry+  export-on-end blind spot at zero per-event cost. The `cursor` field is the+  worker FSM cursor, not a guaranteed durable checkpoint row. A+  stopped/cancelled/crashed subscription is represented by absence, never a+  `"stopped"` phase.+* New `stateName :: SubscriptionState -> Text` (a stable low-cardinality state+  label) in `Kiroku.Store.Subscription.Fsm`; `stateName` and `stateCursor` are+  re-exported from `Kiroku.Store`.++#### Per-event retry / dead-letter dispositions (plan 40)++* `SubscriptionResult` gains two Kiroku-native dispositions:+  `Retry RetryDelay` (redeliver the same event after a delay, bounded by the new+  `SubscriptionConfig.retryPolicy`; default five attempts) and+  `DeadLetter DeadLetterReason` (record the event in `kiroku.dead_letters` and+  atomically advance the checkpoint past it). `RetryDelay`, `DeadLetterReason`,+  `RetryPolicy`, and `defaultRetryPolicy` are exported from+  `Kiroku.Store.Subscription.Types`; `RetryDelay` / `DeadLetterReason` live in+  `Kiroku.Store.Subscription.Fsm` and are also re-exported from+  `Kiroku.Store.Observability`.++* `SubscriptionState` gains a surfaced `Retrying` observability state, visible+  through the `currentState` handle accessor while a redelivery is pending. New+  lifecycle events `KirokuEventSubscriptionRetrying` and+  `KirokuEventSubscriptionDeadLettered`.++* New ack-coupled Streamly bridge `subscriptionAckStream` (emitting `AckItem`+  `{ event, attempt, reply }`); the consumer fills the reply to drive the+  worker's per-event disposition. `subscriptionStream` is unchanged in behavior+  (reimplemented on top of it, always replying `Continue`).++* New `kiroku.dead_letters` schema (shipped by `kiroku-store-migrations`) and the+  `SQL.insertDeadLetterAndCheckpointStmt` / `SQL.readDeadLettersStmt` statements;+  the dead-letter insert and checkpoint advance run in one atomic statement.++#### Per-subscription event-type filtering and selector (plan 43)++* `SubscriptionConfig.eventTypeFilter :: EventTypeFilter` — a declarative,+  closed filter (`AllEventTypes | OnlyEventTypes (Set EventType)`, default+  `AllEventTypes`) applied worker-side in `processEvents` before the handler:+  non-matching events skip delivery (never reaching the ack-coupled bridge, so+  they are never retried or dead-lettered) while the batch-tail checkpoint+  advances past them, so a highly selective subscription never stalls. Exported+  with `eventTypeMatches` from `Kiroku.Store.Subscription.Types` and forwarded+  through the Streamly bridge and the Shibuya adapter.++* `SubscriptionConfig.selector :: Maybe (RecordedEvent -> Bool)` — an optional+  opaque per-event predicate (default `Nothing`), the escape hatch for filtering+  that `eventTypeFilter` cannot express (e.g. on payload, metadata, or+  correlation/causation ids — typically a one-off catch-up reprocess). It is+  deliberately kept *separate* from `eventTypeFilter` rather than replacing it:+  the closed sum stays introspectable, `Eq`/`Show`-able, and SQL-pushdown-able,+  while the selector covers arbitrary predicates. The two compose as a logical+  AND via the new `shouldDeliver` helper (an event is delivered only when it+  passes both), with the same no-stall / checkpoint-advances guarantee. Both+  `eventTypeFilter` and `selector` are forwarded through the Shibuya adapter+  (`KirokuAdapterConfig` / `KirokuConsumerGroupConfig`).++#### Subscription worker driven by an explicit FSM (plan 41)++* The subscription worker is now driven by an explicit finite state machine+  (`Kiroku.Store.Subscription.Fsm`): a `SubscriptionState`+  (`CatchingUp`/`Live`/`Paused`/`Reconnecting`/`Stopped`) plus a single,+  exhaustively pattern-matched `step` transition function. Behavior of existing+  catch-up/live/stopped paths is unchanged; two recoverable states are added (see+  below). `SubscriptionStopReason` moved to the `Fsm` module and is re-exported+  from `Kiroku.Store.Observability`, so the public `KirokuEvent` API is unchanged.++* **Recoverable backpressure.** The new `PauseAndResume` `OverflowPolicy` is now+  the `defaultSubscriptionConfig` default (previously `DropSubscription`). When a+  bounded subscriber queue fills, the publisher pauses delivery and the worker+  drains the stale queue and re-catches-up from its checkpoint, so no event is+  lost and the checkpoint stays monotonic — instead of terminating the+  subscriber. `DropSubscription` (fail-fast `SubscriptionOverflowed`) and+  `DropOldest` (lossy) remain available.++* **Worker-level live reconnect.** A `Category` or consumer-group worker that+  hits a database error on a live-mode fetch now enters `Reconnecting` — it backs+  off and re-catches-up from its checkpoint — instead of retrying silently+  in place. (`AllStreams` live delivery is publisher-fed and has no worker fetch.)++#### Subscription observability events++* `KirokuEventSubscriptionPaused`, `KirokuEventSubscriptionResumed`, and+  `KirokuEventSubscriptionReconnecting` observability events for the new states.+* `currentState` on `SubscriptionHandleM`: a point-in-time read of the worker's+  `SubscriptionState` for observability, backed by a `TVar` the worker writes on+  every transition.++### Bug Fixes++#### Subscription catch-up DB errors++* Subscription catch-up now retries transient `FetchBatch` database errors at the+  same cursor with capped backoff instead of treating the error as an empty+  batch. This prevents `$all` subscribers from switching to live mode at a stale+  cursor and missing pre-live events. See+  `docs/plans/39-catchup-must-not-treat-db-errors-as-caught-up.md`.++#### Publisher restart history rebroadcast++* `EventPublisher` now initializes its in-memory cursor from the current `$all`+  stream tail at startup instead of `GlobalPosition 0`. Restarting a store no+  longer re-reads and re-broadcasts the full event history into live subscriber+  queues, avoiding spurious `DropSubscription` overflows for healthy+  `AllStreams` subscribers while they are still catching up. See+  `docs/plans/38-publisher-tail-init-to-avoid-restart-rebroadcast-and-allstreams-overflow.md`.++#### Category/consumer-group live subscriptions busy-spinning (plan 37)++* Live `Category` subscriptions and consumer-group members no longer busy-spin+  when idle while other categories/partitions advance the global `$all`+  position. `Category` subscriptions now wake from a per-category NOTIFY signal+  (the Notifier previously discarded the notification payload), so an idle+  category does zero DB work; consumer-group members now gate on the last+  observed global position instead of the per-category cursor. Delivery and+  checkpoint semantics are unchanged. See+  `docs/plans/37-fix-category-subscription-live-loop-busy-spin.md`.++#### Live fetch observability++* `KirokuEventSubscriptionFetched` observability event (per live DB-driven+  fetch), exposing per-subscription live-fetch activity.++## 0.1.0.0 — 2026-05-23++### Changed — migrations own schema lifecycle++* `kiroku-store` no longer embeds schema SQL or runs DDL during `withStore`.+  Apply `kiroku-store-migrations` before opening the store. This removes the+  duplicated bootstrap path between the runtime package and the migration+  package.+* Removed `Kiroku.Store.Schema`, `SchemaInitialization`,+  `InitializeSchemaOnAcquire`, `SkipSchemaInitialization`, and+  `ConnectionSettingsM.schemaInitialization`.++### Added — `lookupStreamNames` / `lookupStreamName` (plan 36)++* `Kiroku.Store.Read.lookupStreamNames :: [StreamId] -> Eff es (Map StreamId+  StreamName)` resolves a batch of surrogate stream ids to their names in a+  single round trip (and `lookupStreamName :: StreamId -> Eff es (Maybe+  StreamName)` for one). This is the inverse of `lookupStreamId` and the+  supported way to recover the source stream name from a `RecordedEvent`'s+  `originalStreamId` on fan-in reads — `$all`, categories,+  causation/correlation queries, and subscriptions — which carry only the+  surrogate id.+* Chosen over carrying a `originalStreamName` field on every `RecordedEvent`:+  benchmarking showed returning the name on every read row costs ~13% on+  `$all` 100-event pages (decoding ~100 extra `text` values per page), whether+  the name came from a join or a denormalized column. The lookup API keeps the+  read hot path at its prior latency and makes consumers pay only when, and+  only as much as, they actually need names (one round trip per batch for the+  distinct ids). See `docs/plans/36-add-originalstreamname-to-recordedevent.md`.++* A fresh installation now creates and uses a dedicated `kiroku` PostgreSQL+  schema instead of installing into `public`. The+  `kiroku-store-migrations` bootstrap creates the schema and sets+  `search_path` first, and every pooled connection runs+  `SET search_path TO "<schema>", pg_catalog` before any statement.+* `defaultConnectionSettings` now defaults `schema = "kiroku"` (was `"public"`).+  The `schema` field is now authoritative for object location, table+  resolution, and the `LISTEN <schema>.events` channel — previously it only+  named the notification channel while table resolution depended on the+  connection-string `search_path`.+* The `kiroku-store-migrations` codd bootstrap installs into `kiroku`; run it+  with `CODD_SCHEMAS=kiroku`. The runtime role needs privileges on the+  `kiroku` schema rather than on `public`.++### Added — consumer groups for partitioned subscriptions (MasterPlan 4, plans 28–31)++* Static, hash-partitioned consumer groups: a named subscription can be split+  across `N` members, each processing a disjoint, per-stream-ordered slice in+  parallel, with per-member checkpoints. Works for `Category` and `$all`+  targets.+* `Kiroku.Store.Subscription.Types` (re-exported from `Kiroku.Store`):+  * `ConsumerGroup { member :: Int32, size :: Int32 }` — static membership+    descriptor. A stream is assigned to member+    `(((hashtextextended(stream_id::text, 0) % size) + size) % size)`.+  * Two new fields on `SubscriptionConfigM m`: `consumerGroup :: Maybe+    ConsumerGroup` (default `Nothing`) and `consumerGroupGuard :: Bool`+    (default `False`, an opt-in startup advisory-lock conflict probe).+    `defaultSubscriptionConfig` sets both defaults, so existing callers compile+    unchanged.+  * Exceptions `InvalidConsumerGroup` (thrown by `subscribe` when `size < 1` or+    `member` is out of range) and `ConsumerGroupGuardConflict` (thrown at+    startup when the guard detects a duplicate member).+* `subscriptions` table gains `consumer_group_member` and `consumer_group_size`+  columns; the checkpoint key becomes the composite unique+  `(subscription_name, consumer_group_member)` (index+  `ix_subscriptions_name_member`). The change is applied by the migration+  package.+* The four `KirokuEventSubscription*` observability events carry a trailing+  `SubscriptionGroupContext` (`NonGroup` | `GroupMember member size`),+  re-exported from `Kiroku.Store`.+* Surfaced through every subscription entry point: the `MonadIO`+  `subscribe`/`withSubscription`, the effectful `Subscription` effect, the+  Streamly `subscriptionStream` bridge, and the Shibuya adapter+  (`KirokuAdapterConfig` gains `consumerGroup :: Maybe ConsumerGroup`).+* New user guide `docs/user/consumer-groups.md` and a runnable example,+  `cabal run kiroku-store:kiroku-consumer-group-example`.++### Added — causation chain and correlation walkers (plan 14)++* `Kiroku.Store.Causation` (new module, re-exported from `Kiroku.Store`):+  * `findCausationDescendants :: EventId -> Eff es (Vector RecordedEvent)`+    — walk the causation graph forward from a seed event. Returns the+    seed plus every event whose `causation_id` chain leads back to it,+    in ascending `global_position` order. Backed by the existing partial+    index `ix_events_causation_id`, so cost scales as O(depth · log n)+    against the total event count.+  * `findCausationAncestors :: EventId -> Eff es (Vector RecordedEvent)`+    — symmetric walk in the other direction: returns the seed plus+    every ancestor reachable by following `causation_id` upward, in+    leaf-first depth order. Uses the same index.+  * `findByCorrelation :: UUID -> Eff es (Vector RecordedEvent)` — return+    every event whose `correlation_id` equals the input, in ascending+    `global_position` order. Backed by `ix_events_correlation_id`.+* `Kiroku.Store.Effect.Store` gains a single new constructor+  `FindEvents :: EventFilter -> Store m (Vector RecordedEvent)` whose+  argument is a closed sum (`Kiroku.Store.Types.EventFilter` —+  `FilterCorrelation`, `FilterCausationDescendants`, `FilterCausationAncestors`).+  The closed-sum shape preserves exhaustiveness checking for downstream+  mock interpreters.+* The new reads honor `StoreSettings.decodeHook`, so any interpreter-level+  decode customization wired through `ConnectionSettings` applies on+  parity with `readStreamForward` / `readAllForward` / `readCategory`.++### Added — interpreter-level event-data hooks (plan 13)++* `Kiroku.Store.Settings` (new module, re-exported from `Kiroku.Store`):+  * `StoreSettings { enrichEvent :: Maybe (EventData -> IO EventData),+    decodeHook :: Maybe (RecordedEvent -> IO RecordedEvent) }` — optional+    interpreter-level hooks. `enrichEvent` runs on the append path before+    encoding (on the typed `EventData` the caller supplied); `decodeHook`+    runs on the read and subscription paths after decoding (on the typed+    `RecordedEvent` about to be surfaced). Both default to `Nothing`,+    taking a `pure` fast path that adds no traversal or allocation when+    the hook is absent.+  * `defaultStoreSettings` — both fields `Nothing` (no-op).+  * `enrichEvents :: StoreSettings -> [EventData] -> IO [EventData]` and+    `decodeEvents :: StoreSettings -> Vector RecordedEvent -> IO (Vector+    RecordedEvent)` — internal helpers reused by the interpreter, the+    subscription publisher, the subscription worker, and the new+    `enrichEventsIO` convenience.+* `Kiroku.Store.Connection.ConnectionSettings` and+  `Kiroku.Store.Connection.KirokuStore` gain a `storeSettings ::+  StoreSettings` field. `defaultConnectionSettings` seeds it with+  `defaultStoreSettings` so existing callers see no behaviour change.+  `withStore` copies the value onto the runtime handle for the+  interpreter, the publisher, and the worker to read.+* `Kiroku.Store.Transaction`:+  * `runTransactionAppendingResource` /+    `runTransactionAppendingResourceNoRetry` — hook-aware variants of+    `runTransactionAppending` / `runTransactionAppendingNoRetry` for+    callers running under a `KirokuStoreResource` effect. They apply+    `enrichEvent` to every `EventData` before opening the transaction.+  * `enrichEventsIO :: KirokuStore -> [EventData] -> IO [EventData]` —+    public convenience for direct callers of `appendToStreamTx`, who+    bypass the interpreter.++A typical use case is enriching every appended event with an+OpenTelemetry trace context:++```haskell+storeSettings = defaultStoreSettings+  { enrichEvent = Just $ \ed -> do+      ctx <- captureCurrentSpan+      pure (ed & #metadata %~ injectTraceContext ctx)+  }+```++Wired through `ConnectionSettings`'s `storeSettings` field, the hook+fires uniformly across `appendToStream`, `appendMultiStream`,+`runTransactionAppendingResource`, every read path, and the+subscription pipeline (live + catch-up).++### Added — streaming single-stream forward read++* `Kiroku.Store.Read.readStreamForwardStream` (re-exported from+  `Kiroku.Store`): a Streamly `Stream (Eff es) RecordedEvent` companion to+  `readStreamForward`. Internally paginates `readStreamForward` at a+  caller-supplied page size and yields events one at a time, enabling+  constant-memory folds over long streams. Shares SQL path and error+  semantics with `readStreamForward`.++### Added — single-stream `RunTransaction` combinator (plan 11)++* `Kiroku.Store.Transaction` (new module, re-exported from+  `Kiroku.Store`):+  * `runTransaction` / `runTransactionNoRetry` — bare escape hatch for+    running an arbitrary `Hasql.Transaction.Transaction a` against the+    store's connection pool. The default variant retries the body on+    PostgreSQL serialization conflicts; the `-NoRetry` variant runs+    exactly once. Both execute at `ReadCommitted` isolation in `Write`+    mode.+  * `appendToStreamTx :: StreamName -> ExpectedVersion ->+    [PreparedEvent] -> UTCTime -> Tx.Transaction (Either AppendConflict+    AppendResult)` — the `Tx`-flavored single-stream append building+    block. Useful inside a `runTransaction` block when the caller needs+    full control over conflict handling. Does not enforce reserved-stream+    rejection; pair with `prepareEventsIO` for UUIDv7 / `createdAt`+    prep.+  * `runTransactionAppending` /+    `runTransactionAppendingNoRetry` — recommended high-level wrapper+    for the `keiro` use case. Atomically composes a single-stream append+    with a caller-supplied `Tx.Transaction` continuation. Rejects `$all`+    up front, `Tx.condemn`s on append conflicts (the continuation never+    runs), and surfaces both conflict and connection failures through+    the `Either StoreError` return type. Carries `IOE :> es` in addition+    to `Store :> es`.+* `Kiroku.Store.Effect`:+  * New `Store` constructors `RunTransaction` and+    `RunTransactionNoRetry`. Mock interpreters are expected to reject+    these.+  * Internal building blocks `PreparedEvent`, `prepareEvents`,+    `buildAppendParams`, and `appendDispatchTx` are now exported (under+    the `$internal` haddock group) to support+    `Kiroku.Store.Transaction`. Not part of the supported public+    surface.+* `Kiroku.Store.Error`:+  * `AppendConflict` — sum of append-precondition failures observable+    inside a `Tx.Transaction` body+    (`WrongExpectedVersionConflict` / `StreamNotFoundConflict` /+    `StreamAlreadyExistsConflict`). 1:1 with the corresponding+    `StoreError` constructors.+  * `appendConflictToStoreError`, `emptyResultConflict` — supporting+    pure helpers.++### Changed++* `appendMultiStream`'s interpreter now dispatches per-stream appends+  through the shared `appendDispatchTx` helper. Behavior is unchanged.+* `appendToStream`'s haddock now describes when to reach for+  `runTransactionAppending` instead.
+ bench/Explain.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE MultilineStrings #-}++{- | PostgreSQL-side append profiling harness.++Two modes:++  * default — boots a cached ephemeral PostgreSQL via 'Pg.withCached', runs+    the production @AnyVersion@ CTE under+    @EXPLAIN (ANALYZE, BUFFERS, TIMING, FORMAT TEXT)@ wrapped in+    @BEGIN ... ROLLBACK@, prints the result to stdout, then runs the same+    query under @FORMAT JSON@ and writes the result to+    @kiroku-store/bench/explain-results/anyversion-singleton.json@.++  * @--auto-explain@ — boots an ephemeral PostgreSQL with the @auto_explain@+    contrib loaded via 'Pg.autoExplainConfig', redirects the server's stderr+    to @kiroku-store/bench/explain-results/auto-explain.log@, opens a+    'KirokuStore' (which migrates the schema), runs a small workload (one+    @AnyVersion@ append, one @ExactVersion@ append against the same stream,+    one @ReadStreamForward@, one @ReadAllForward@), and exits. PostgreSQL+    flushes the @auto_explain@ output to the captured log on shutdown.++Belongs to ExecPlan+@docs/plans/26-postgresql-side-append-profiling-with-explain-analyze-and-auto-explain.md@.+-}+module Main where++import Control.Concurrent (threadDelay)+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.ByteString qualified as BS+import Data.Functor.Contravariant ((>$<))+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.UUID (UUID)+import Data.UUID.V4 qualified as V4+import Data.Vector qualified as V+import EphemeralPg qualified as Pg+import EphemeralPg.Config qualified as PgC+import GHC.Generics (Generic)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, unpreparable)+import Kiroku.Store+import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory, listDirectory, removePathForcibly)+import System.Environment (getArgs)+import System.FilePath (takeDirectory, (</>))+import System.IO (BufferMode (..), hSetBuffering, stdout)++-- ---------------------------------------------------------------------------+-- Local copies of AppendParams + encoder + appendAnyVersionSQL+-- ---------------------------------------------------------------------------+-- Duplicated from Kiroku.Store.SQL (an other-modules module not exposed by+-- the kiroku-store library). EP-2 deliberately inlines these rather than+-- expose the SQL module; see the Decision Log of plan 26.+-- ---------------------------------------------------------------------------++data AppendParams = AppendParams+    { eventIds :: !(V.Vector UUID)+    , eventTypes :: !(V.Vector Text)+    , causationIds :: !(V.Vector (Maybe UUID))+    , correlationIds :: !(V.Vector (Maybe UUID))+    , payloads :: !(V.Vector Aeson.Value)+    , metadatas :: !(V.Vector (Maybe Aeson.Value))+    , createdAts :: !(V.Vector UTCTime)+    , streamName :: !Text+    }+    deriving stock (Generic)++appendParamsEncoder :: E.Params AppendParams+appendParamsEncoder =+    ((^. #eventIds) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+        <> ((^. #eventTypes) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+        <> ((^. #causationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+        <> ((^. #correlationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+        <> ((^. #payloads) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.jsonb))))+        <> ((^. #metadatas) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.jsonb))))+        <> ((^. #createdAts) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.timestamptz))))+        <> ((^. #streamName) >$< E.param (E.nonNullable E.text))++appendAnyVersionSQL :: Text+appendAnyVersionSQL =+    """+    WITH+      new_events AS (+        SELECT *+        FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+        WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+      ),+      stream_upsert AS (+        INSERT INTO streams (stream_name, stream_version)+        VALUES ($8, (SELECT count(*) FROM new_events))+        ON CONFLICT (stream_name)+        DO UPDATE SET stream_version = streams.stream_version + (SELECT count(*) FROM new_events)+          WHERE streams.deleted_at IS NULL+        RETURNING stream_id, stream_version - (SELECT count(*) FROM new_events) AS initial_version+      ),+      inserted_events AS (+        INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+        SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+        FROM new_events+        WHERE EXISTS (SELECT 1 FROM stream_upsert)+        ORDER BY idx+      ),+      source_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, su.stream_id, su.initial_version + ne.idx, su.stream_id, su.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN stream_upsert su+      ),+      all_update AS (+        UPDATE streams+        SET stream_version = stream_version + (SELECT count(*) FROM new_events)+        WHERE stream_id = 0+          AND EXISTS (SELECT 1 FROM stream_upsert)+        RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+      ),+      all_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN all_update au+        CROSS JOIN stream_upsert su+      )+    SELECT su.stream_id,+           su.initial_version + (SELECT count(*) FROM new_events),+           au.initial_global_version + (SELECT count(*) FROM new_events)+    FROM stream_upsert su+    CROSS JOIN all_update au+    """++-- ---------------------------------------------------------------------------+-- EXPLAIN wrappers + sample params+-- ---------------------------------------------------------------------------++{- | Wrap @appendAnyVersionSQL@ in @EXPLAIN (...) <CTE>@ with @FORMAT TEXT@.+Each row of the result is one indented plan line. Uses 'unpreparable'+because the EXPLAIN runs once and the statement-cache cost would be wasted.+-}+explainStatementText :: Statement AppendParams [Text]+explainStatementText =+    unpreparable+        sql+        appendParamsEncoder+        (D.rowList (D.column (D.nonNullable D.text)))+  where+    sql =+        "EXPLAIN (ANALYZE, BUFFERS, TIMING, FORMAT TEXT)\n"+            <> appendAnyVersionSQL++{- | Wrap @appendAnyVersionSQL@ in @EXPLAIN (...) <CTE>@ with @FORMAT JSON@.+PostgreSQL returns one row whose single column is of type @json@; we use+'D.jsonBytes' with an identity parser to preserve the original+byte-for-byte output.+-}+explainStatementJson :: Statement AppendParams BS.ByteString+explainStatementJson =+    unpreparable+        sql+        appendParamsEncoder+        (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right))))+  where+    sql =+        "EXPLAIN (ANALYZE, BUFFERS, TIMING, FORMAT JSON)\n"+            <> appendAnyVersionSQL++{- | One-event 'AppendParams' for an @AnyVersion@ append against a fresh+stream name.+-}+mkSampleParams :: IO AppendParams+mkSampleParams = do+    eid <- V4.nextRandom+    now <- getCurrentTime+    let nowMicros = show now+    pure+        AppendParams+            { eventIds = V.singleton eid+            , eventTypes = V.singleton "ExplainEvent"+            , causationIds = V.singleton Nothing+            , correlationIds = V.singleton Nothing+            , payloads = V.singleton (Aeson.object ["explain" Aeson..= Aeson.String "anyversion"])+            , metadatas = V.singleton Nothing+            , createdAts = V.singleton now+            , streamName = T.pack ("explain-" <> nowMicros)+            }++{- | Run a single TEXT-format EXPLAIN session inside @BEGIN ... ROLLBACK@+so the inserted rows do not persist.+-}+explainSessionText :: AppendParams -> Session.Session [Text]+explainSessionText params = do+    Session.script "BEGIN"+    rows <- Session.statement params explainStatementText+    Session.script "ROLLBACK"+    pure rows++{- | JSON-format counterpart of 'explainSessionText'. The result is the+@json@ column's raw bytes.+-}+explainSessionJson :: AppendParams -> Session.Session BS.ByteString+explainSessionJson params = do+    Session.script "BEGIN"+    bs <- Session.statement params explainStatementJson+    Session.script "ROLLBACK"+    pure bs++-- ---------------------------------------------------------------------------+-- Output paths+-- ---------------------------------------------------------------------------++{- | Walk up from the current working directory until a @cabal.project@ file+is found, then return that directory. Falls back to the CWD if no marker+is found. This makes the harness work whether invoked from the repo root+('cabal run', direct binary invocation) or from the package directory+('cabal bench', which sets CWD to @kiroku-store\/@).+-}+locateRepoRoot :: IO FilePath+locateRepoRoot = do+    cwd <- getCurrentDirectory+    go cwd+  where+    go dir = do+        let marker = dir </> "cabal.project"+        present <- doesFileExist marker+        if present+            then pure dir+            else+                let parent = takeDirectory dir+                 in if parent == dir+                        then getCurrentDirectory+                        else go parent++explainResultsDir :: FilePath -> FilePath+explainResultsDir repoRoot = repoRoot </> "kiroku-store" </> "bench" </> "explain-results"++jsonOutputPath :: FilePath -> FilePath+jsonOutputPath repoRoot = explainResultsDir repoRoot </> "anyversion-singleton.json"++textOutputPath :: FilePath -> FilePath+textOutputPath repoRoot = explainResultsDir repoRoot </> "anyversion-singleton.txt"++autoExplainLogPath :: FilePath -> FilePath+autoExplainLogPath repoRoot = explainResultsDir repoRoot </> "auto-explain.log"++autoExplainCsvPath :: FilePath -> FilePath+autoExplainCsvPath repoRoot = explainResultsDir repoRoot </> "auto-explain.csv"++-- ---------------------------------------------------------------------------+-- Milestone 1: targeted EXPLAIN ANALYZE+-- ---------------------------------------------------------------------------++runExplainAnalyze :: IO ()+runExplainAnalyze = do+    repoRoot <- locateRepoRoot+    let dir = explainResultsDir repoRoot+        jsonPath = jsonOutputPath repoRoot+        textPath = textOutputPath repoRoot+    createDirectoryIfMissing True dir+    putStrLn ("=== Output directory: " <> dir <> " ===")+    putStrLn "=== Booting cached ephemeral PostgreSQL for EXPLAIN ANALYZE ==="+    result <- Pg.withCached $ \db -> do+        let settings = defaultConnectionSettings (Pg.connectionString db)+        withStore settings $ \store -> do+            paramsText <- mkSampleParams+            paramsJson <- mkSampleParams++            putStrLn ""+            putStrLn "=== EXPLAIN (ANALYZE, BUFFERS, TIMING, FORMAT TEXT) of appendAnyVersionSQL ==="+            putStrLn ""+            textRows <- runSession store (explainSessionText paramsText)+            let textOut = T.intercalate "\n" textRows+            TIO.putStrLn textOut+            TIO.writeFile textPath textOut++            putStrLn ""+            putStrLn ("=== Writing FORMAT JSON output to " <> jsonPath <> " ===")+            jsonBytes <- runSession store (explainSessionJson paramsJson)+            BS.writeFile jsonPath jsonBytes++            putStrLn ""+            putStrLn ("=== TEXT output also archived at " <> textPath <> " ===")+    case result of+        Left err ->+            error ("EphemeralPg failed to start: " <> show err)+        Right () ->+            pure ()++-- ---------------------------------------------------------------------------+-- Milestone 2: auto_explain capture of a small workload+-- ---------------------------------------------------------------------------++{- | A representative slice of the production read+write paths so the+@auto_explain@ log captures one of each kind. Kept tiny so the resulting+log is human-readable.+-}+runSmallWorkload :: KirokuStore -> IO ()+runSmallWorkload store = do+    let sn = StreamName "explain-auto"+    -- AnyVersion append: hits the appendAnyVersionSQL CTE.+    r1 <- runStoreIO store $ appendToStream sn AnyVersion [mkEvent "Created"]+    forceOk "AnyVersion" r1+    let Right res1 = r1+    -- ExactVersion append against the same stream: hits the+    -- appendExpectedVersionSQL CTE with a non-trivial conflict check.+    r2 <-+        runStoreIO store $+            appendToStream sn (ExactVersion (res1 ^. #streamVersion)) [mkEvent "Updated"]+    forceOk "ExactVersion" r2+    -- One read forward from the same stream (limit 100 events).+    r3 <- runStoreIO store $ readStreamForward sn (StreamVersion 0) 100+    forceOk "readStreamForward" r3+    -- One read forward from the $all stream (limit 100 events).+    r4 <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+    forceOk "readAllForward" r4+  where+    mkEvent :: Text -> EventData+    mkEvent ty =+        EventData+            Nothing+            (EventType ty)+            (Aeson.object ["t" Aeson..= ty])+            Nothing+            Nothing+            Nothing++    forceOk :: (Show a) => Text -> Either StoreError a -> IO ()+    forceOk label = \case+        Left e -> error (T.unpack label <> " failed: " <> show e)+        Right _ -> pure ()++runAutoExplain :: IO ()+runAutoExplain = do+    repoRoot <- locateRepoRoot+    let dir = explainResultsDir repoRoot+        logPath = autoExplainLogPath repoRoot+        csvPath = autoExplainCsvPath repoRoot+    createDirectoryIfMissing True dir+    putStrLn ("=== Output directory: " <> dir <> " ===")+    putStrLn "=== Booting ephemeral PostgreSQL with auto_explain enabled ==="+    -- ephemeral-pg unconditionally discards the postgres process's stderr+    -- (`setStderr nullStream` at EphemeralPg/Process/Postgres.hs:78), so+    -- plan 26's documented "override Config.stderr to a file handle"+    -- approach cannot work. Instead, configure PostgreSQL's own logging+    -- collector to write a CSV log directly to disk; auto_explain's output+    -- is captured as the message column of those CSV rows. See plan 26's+    -- Surprises & Discoveries for the full debrief.+    let logDir = dir </> "pglog"+        logFilename = "auto-explain.log"+    createDirectoryIfMissing True logDir+    let collectorSettings =+            [ ("logging_collector", "'on'")+            , ("log_destination", "'csvlog'")+            , ("log_directory", "'" <> T.pack logDir <> "'")+            , ("log_filename", "'" <> T.pack logFilename <> "'")+            , ("log_rotation_age", "'0'")+            , ("log_rotation_size", "'0'")+            , ("log_truncate_on_rotation", "'off'")+            , ("log_line_prefix", "'%t [%p] '")+            , -- Required to actually capture auto_explain output: empirical+              -- testing showed that with default log_min_messages (warning)+              -- the csvlog file stayed at 0 bytes, even though+              -- auto_explain.log_min_duration was 0. Forcing the threshold+              -- down to log_min_messages = 'log' lets the auto_explain+              -- ereport(LOG, ...) calls through. See plan 26's Surprises+              -- & Discoveries for the empirical evidence.+              ("log_min_messages", "'log'")+            ]+    let cfg =+            PgC.defaultConfig+                <> PgC.autoExplainConfig 0+                <> (mempty :: PgC.Config){PgC.postgresSettings = collectorSettings}+    result <- Pg.withConfig cfg $ \db -> do+        let settings = defaultConnectionSettings (Pg.connectionString db)+        withStore settings $ \store -> do+            putStrLn "=== Running small workload (1 AnyVersion + 1 ExactVersion + 2 reads) ==="+            runSmallWorkload store+            putStrLn "=== Waiting so the logging collector flushes ==="+            threadDelay 3_000_000 -- 3 seconds+    case result of+        Left err ->+            error ("EphemeralPg failed to start: " <> show err)+        Right () -> do+            files <- listDirectory logDir+            let collectorCsv = logDir </> "auto-explain.csv"+            let collectorStderrLog = logDir </> "auto-explain.log"+            hasCsv <- doesFileExist collectorCsv+            hasLog <- doesFileExist collectorStderrLog+            if hasCsv+                then do+                    contents <- BS.readFile collectorCsv+                    BS.writeFile csvPath contents+                    putStrLn ("=== auto_explain csvlog: " <> csvPath <> " (" <> show (BS.length contents) <> " bytes) ===")+                else putStrLn ("=== WARNING: missing " <> collectorCsv <> "; emitted: " <> show files <> " ===")+            if hasLog+                then do+                    contents <- BS.readFile collectorStderrLog+                    BS.writeFile logPath contents+                    putStrLn ("=== auto_explain stderr (small): " <> logPath <> " (" <> show (BS.length contents) <> " bytes) ===")+                else putStrLn ("=== NOTE: collector did not produce a stderr-format log (csvlog only) ===")+            -- Drop the intermediate pglog/ directory; we have copies in the+            -- documented output paths above.+            removePathForcibly logDir++-- ---------------------------------------------------------------------------+-- Shared helpers+-- ---------------------------------------------------------------------------++{- | Run a Hasql 'Session' directly against the store's pool, surfacing+pool errors via 'error'. Used by the EXPLAIN harness which bypasses the+Store effect layer.+-}+runSession :: KirokuStore -> Session.Session a -> IO a+runSession store session = do+    r <- Pool.use (store ^. #pool) session+    case r of+        Left e -> error ("Hasql.Pool.use failed: " <> show e)+        Right a -> pure a++-- ---------------------------------------------------------------------------+-- main+-- ---------------------------------------------------------------------------++main :: IO ()+main = do+    hSetBuffering stdout LineBuffering+    args <- getArgs+    if "--auto-explain" `elem` args+        then runAutoExplain+        else runExplainAnalyze
+ bench/Main.hs view
@@ -0,0 +1,892 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultilineStrings #-}++module Main where++import Control.Concurrent.Async (mapConcurrently_)+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Functor.Contravariant ((>$<))+import Data.Generics.Labels ()+import Data.IORef+import Data.Int (Int64)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)+import Data.UUID (UUID)+import Data.UUID.V7 qualified as V7+import Data.Vector qualified as V+import EphemeralPg qualified as Pg+import GHC.Generics (Generic)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Hasql.Transaction qualified as Tx+import Hasql.Transaction.Sessions qualified as TxSessions+import Kiroku.Store+import Test.Tasty.Bench++data RawAppendParams = RawAppendParams+    { eventId :: !UUID+    , eventType :: !Text+    , causationId :: !(Maybe UUID)+    , correlationId :: !(Maybe UUID)+    , payload :: !Aeson.Value+    , metadata :: !(Maybe Aeson.Value)+    , createdAt :: !UTCTime+    , streamName :: !Text+    }+    deriving stock (Generic)++data RawProductionAppendParams = RawProductionAppendParams+    { productionEventIds :: !(V.Vector UUID)+    , productionEventTypes :: !(V.Vector Text)+    , productionCausationIds :: !(V.Vector (Maybe UUID))+    , productionCorrelationIds :: !(V.Vector (Maybe UUID))+    , productionPayloads :: !(V.Vector Aeson.Value)+    , productionMetadatas :: !(V.Vector (Maybe Aeson.Value))+    , productionCreatedAts :: !(V.Vector UTCTime)+    , productionStreamName :: !Text+    }+    deriving stock (Generic)++type RawAppendResult = (Int64, Int64, Int64)++rawAppendParamsEncoder :: E.Params RawAppendParams+rawAppendParamsEncoder =+    ((^. #eventId) >$< E.param (E.nonNullable E.uuid))+        <> ((^. #eventType) >$< E.param (E.nonNullable E.text))+        <> ((^. #causationId) >$< E.param (E.nullable E.uuid))+        <> ((^. #correlationId) >$< E.param (E.nullable E.uuid))+        <> ((^. #payload) >$< E.param (E.nonNullable E.jsonb))+        <> ((^. #metadata) >$< E.param (E.nullable E.jsonb))+        <> ((^. #createdAt) >$< E.param (E.nonNullable E.timestamptz))+        <> ((^. #streamName) >$< E.param (E.nonNullable E.text))++rawProductionAppendParamsEncoder :: E.Params RawProductionAppendParams+rawProductionAppendParamsEncoder =+    ((^. #productionEventIds) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+        <> ((^. #productionEventTypes) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+        <> ((^. #productionCausationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+        <> ((^. #productionCorrelationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+        <> ((^. #productionPayloads) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.jsonb))))+        <> ((^. #productionMetadatas) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.jsonb))))+        <> ((^. #productionCreatedAts) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.timestamptz))))+        <> ((^. #productionStreamName) >$< E.param (E.nonNullable E.text))++rawAppendResultDecoder :: D.Result (Maybe RawAppendResult)+rawAppendResultDecoder =+    D.rowMaybe $+        (,,)+            <$> D.column (D.nonNullable D.int8)+            <*> D.column (D.nonNullable D.int8)+            <*> D.column (D.nonNullable D.int8)++rawScalarAppendAnyVersion :: Statement RawAppendParams (Maybe RawAppendResult)+rawScalarAppendAnyVersion =+    preparable+        rawScalarAppendAnyVersionSQL+        rawAppendParamsEncoder+        rawAppendResultDecoder++rawProductionAppendAnyVersion :: Statement RawProductionAppendParams (Maybe RawAppendResult)+rawProductionAppendAnyVersion =+    preparable+        rawProductionAppendAnyVersionSQL+        rawProductionAppendParamsEncoder+        rawAppendResultDecoder++rawScalarAppendAnyVersionSQL :: Text+rawScalarAppendAnyVersionSQL =+    """+    WITH+      new_event AS (+        SELECT $1::uuid AS event_id,+               $2::text AS event_type,+               $3::uuid AS causation_id,+               $4::uuid AS correlation_id,+               $5::jsonb AS data,+               $6::jsonb AS metadata,+               $7::timestamptz AS created_at+      ),+      stream_upsert AS (+        INSERT INTO streams (stream_name, stream_version)+        VALUES ($8, 1)+        ON CONFLICT (stream_name)+        DO UPDATE SET stream_version = streams.stream_version + 1+          WHERE streams.deleted_at IS NULL+        RETURNING stream_id, stream_version - 1 AS initial_version+      ),+      inserted_events AS (+        INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+        SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+        FROM new_event+        WHERE EXISTS (SELECT 1 FROM stream_upsert)+      ),+      source_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, su.stream_id, su.initial_version + 1, su.stream_id, su.initial_version + 1+        FROM new_event ne+        CROSS JOIN stream_upsert su+      ),+      all_update AS (+        UPDATE streams+        SET stream_version = stream_version + 1+        WHERE stream_id = 0+          AND EXISTS (SELECT 1 FROM stream_upsert)+        RETURNING stream_version - 1 AS initial_global_version+      ),+      all_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, 0, au.initial_global_version + 1, su.stream_id, su.initial_version + 1+        FROM new_event ne+        CROSS JOIN all_update au+        CROSS JOIN stream_upsert su+      )+    SELECT su.stream_id,+           su.initial_version + 1,+           au.initial_global_version + 1+    FROM stream_upsert su+    CROSS JOIN all_update au+    """++rawProductionAppendAnyVersionSQL :: Text+rawProductionAppendAnyVersionSQL =+    """+    WITH+      new_events AS (+        SELECT *+        FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+        WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+      ),+      stream_upsert AS (+        INSERT INTO streams (stream_name, stream_version)+        VALUES ($8, (SELECT count(*) FROM new_events))+        ON CONFLICT (stream_name)+        DO UPDATE SET stream_version = streams.stream_version + (SELECT count(*) FROM new_events)+          WHERE streams.deleted_at IS NULL+        RETURNING stream_id, stream_version - (SELECT count(*) FROM new_events) AS initial_version+      ),+      inserted_events AS (+        INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+        SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+        FROM new_events+        WHERE EXISTS (SELECT 1 FROM stream_upsert)+        ORDER BY idx+      ),+      source_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, su.stream_id, su.initial_version + ne.idx, su.stream_id, su.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN stream_upsert su+      ),+      all_update AS (+        UPDATE streams+        SET stream_version = stream_version + (SELECT count(*) FROM new_events)+        WHERE stream_id = 0+          AND EXISTS (SELECT 1 FROM stream_upsert)+        RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+      ),+      all_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN all_update au+        CROSS JOIN stream_upsert su+      )+    SELECT su.stream_id,+           su.initial_version + (SELECT count(*) FROM new_events),+           au.initial_global_version + (SELECT count(*) FROM new_events)+    FROM stream_upsert su+    CROSS JOIN all_update au+    """++-- Two-round-trip variants: the proof-of-concept that the plan-23 restructure+-- is structurally faster than the production arrays/unnest CTE. The resolve+-- query reads (stream_id, stream_version, deleted_at) by stream_name; one of+-- two append CTEs then runs keyed on the resolved stream_id (existing) or on+-- the stream_name with no ON CONFLICT (new).++data RawResolution = RawResolution+    { resStreamId :: !Int64+    , resStreamVersion :: !Int64+    , resDeletedAt :: !(Maybe UTCTime)+    }+    deriving stock (Generic)++rawResolveStreamStmt :: Statement Text (Maybe RawResolution)+rawResolveStreamStmt =+    preparable+        rawResolveStreamSQL+        (E.param (E.nonNullable E.text))+        ( D.rowMaybe $+            RawResolution+                <$> D.column (D.nonNullable D.int8)+                <*> D.column (D.nonNullable D.int8)+                <*> D.column (D.nullable D.timestamptz)+        )++rawResolveStreamSQL :: Text+rawResolveStreamSQL =+    """+    SELECT stream_id, stream_version, deleted_at+    FROM streams+    WHERE stream_name = $1+    """++-- | Append params for the two-round-trip "existing" path: stream_id is known.+data RawAppendExistingParams = RawAppendExistingParams+    { existingStreamId :: !Int64+    , existingEventId :: !UUID+    , existingEventType :: !Text+    , existingCausationId :: !(Maybe UUID)+    , existingCorrelationId :: !(Maybe UUID)+    , existingPayload :: !Aeson.Value+    , existingMetadata :: !(Maybe Aeson.Value)+    , existingCreatedAt :: !UTCTime+    }+    deriving stock (Generic)++rawAppendExistingEncoder :: E.Params RawAppendExistingParams+rawAppendExistingEncoder =+    ((^. #existingStreamId) >$< E.param (E.nonNullable E.int8))+        <> ((^. #existingEventId) >$< E.param (E.nonNullable E.uuid))+        <> ((^. #existingEventType) >$< E.param (E.nonNullable E.text))+        <> ((^. #existingCausationId) >$< E.param (E.nullable E.uuid))+        <> ((^. #existingCorrelationId) >$< E.param (E.nullable E.uuid))+        <> ((^. #existingPayload) >$< E.param (E.nonNullable E.jsonb))+        <> ((^. #existingMetadata) >$< E.param (E.nullable E.jsonb))+        <> ((^. #existingCreatedAt) >$< E.param (E.nonNullable E.timestamptz))++rawAppendUpdateExisting :: Statement RawAppendExistingParams (Maybe RawAppendResult)+rawAppendUpdateExisting =+    preparable+        rawAppendUpdateExistingSQL+        rawAppendExistingEncoder+        rawAppendResultDecoder++{- | Update an existing stream keyed on integer stream_id. No version check,+no soft-delete check, no EXISTS gating, no count(*) — Haskell-side+validation has already done all of that.+-}+rawAppendUpdateExistingSQL :: Text+rawAppendUpdateExistingSQL =+    """+    WITH+      stream_update AS (+        UPDATE streams+        SET stream_version = stream_version + 1+        WHERE stream_id = $1::bigint+        RETURNING stream_id, stream_version - 1 AS initial_version+      ),+      inserted_event AS (+        INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+        VALUES ($2::uuid, $3::text, $4::uuid, $5::uuid, $6::jsonb, $7::jsonb, $8::timestamptz)+      ),+      source_link AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT $2::uuid, su.stream_id, su.initial_version + 1, su.stream_id, su.initial_version + 1+        FROM stream_update su+      ),+      all_update AS (+        UPDATE streams+        SET stream_version = stream_version + 1+        WHERE stream_id = 0+        RETURNING stream_version - 1 AS initial_global_version+      ),+      all_link AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT $2::uuid, 0, au.initial_global_version + 1, su.stream_id, su.initial_version + 1+        FROM all_update au+        CROSS JOIN stream_update su+      )+    SELECT su.stream_id,+           su.initial_version + 1,+           au.initial_global_version + 1+    FROM stream_update su+    CROSS JOIN all_update au+    """++-- | Append params for the two-round-trip "new stream" path: stream_name only.+data RawAppendNewParams = RawAppendNewParams+    { newStreamName :: !Text+    , newEventId :: !UUID+    , newEventType :: !Text+    , newCausationId :: !(Maybe UUID)+    , newCorrelationId :: !(Maybe UUID)+    , newPayload :: !Aeson.Value+    , newMetadata :: !(Maybe Aeson.Value)+    , newCreatedAt :: !UTCTime+    }+    deriving stock (Generic)++rawAppendNewEncoder :: E.Params RawAppendNewParams+rawAppendNewEncoder =+    ((^. #newStreamName) >$< E.param (E.nonNullable E.text))+        <> ((^. #newEventId) >$< E.param (E.nonNullable E.uuid))+        <> ((^. #newEventType) >$< E.param (E.nonNullable E.text))+        <> ((^. #newCausationId) >$< E.param (E.nullable E.uuid))+        <> ((^. #newCorrelationId) >$< E.param (E.nullable E.uuid))+        <> ((^. #newPayload) >$< E.param (E.nonNullable E.jsonb))+        <> ((^. #newMetadata) >$< E.param (E.nullable E.jsonb))+        <> ((^. #newCreatedAt) >$< E.param (E.nonNullable E.timestamptz))++rawAppendCreateNew :: Statement RawAppendNewParams (Maybe RawAppendResult)+rawAppendCreateNew =+    preparable+        rawAppendCreateNewSQL+        rawAppendNewEncoder+        rawAppendResultDecoder++{- | Create a new stream and append one event. No ON CONFLICT — Haskell-side+validation already proved the stream is absent; a race-loser hits the+ix_streams_stream_name unique constraint and surfaces as a usage error.+-}+rawAppendCreateNewSQL :: Text+rawAppendCreateNewSQL =+    """+    WITH+      stream_insert AS (+        INSERT INTO streams (stream_name, stream_version)+        VALUES ($1::text, 1)+        RETURNING stream_id, 0::bigint AS initial_version+      ),+      inserted_event AS (+        INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+        VALUES ($2::uuid, $3::text, $4::uuid, $5::uuid, $6::jsonb, $7::jsonb, $8::timestamptz)+      ),+      source_link AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT $2::uuid, si.stream_id, si.initial_version + 1, si.stream_id, si.initial_version + 1+        FROM stream_insert si+      ),+      all_update AS (+        UPDATE streams+        SET stream_version = stream_version + 1+        WHERE stream_id = 0+        RETURNING stream_version - 1 AS initial_global_version+      ),+      all_link AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT $2::uuid, 0, au.initial_global_version + 1, si.stream_id, si.initial_version + 1+        FROM all_update au+        CROSS JOIN stream_insert si+      )+    SELECT si.stream_id,+           si.initial_version + 1,+           au.initial_global_version + 1+    FROM stream_insert si+    CROSS JOIN all_update au+    """++mkRawAppendParams :: Text -> IO RawAppendParams+mkRawAppendParams name = do+    eventUuid <- oneUuid+    now <- getCurrentTime+    pure+        RawAppendParams+            { eventId = eventUuid+            , eventType = "RawBenchEvent"+            , causationId = Nothing+            , correlationId = Nothing+            , payload = Aeson.object [("benchmark", Aeson.Bool True)]+            , metadata = Nothing+            , createdAt = now+            , streamName = name+            }++mkRawProductionAppendParams :: RawAppendParams -> RawProductionAppendParams+mkRawProductionAppendParams params =+    RawProductionAppendParams+        { productionEventIds = V.singleton (params ^. #eventId)+        , productionEventTypes = V.singleton (params ^. #eventType)+        , productionCausationIds = V.singleton (params ^. #causationId)+        , productionCorrelationIds = V.singleton (params ^. #correlationId)+        , productionPayloads = V.singleton (params ^. #payload)+        , productionMetadatas = V.singleton (params ^. #metadata)+        , productionCreatedAts = V.singleton (params ^. #createdAt)+        , productionStreamName = params ^. #streamName+        }++oneUuid :: IO UUID+oneUuid = do+    generated <- V7.genUUIDs 1+    case generated of+        uuid : _ -> pure uuid+        [] -> error "oneUuid: UUID generator returned no IDs"++runRawScalarAppendAnyVersionNewStream :: KirokuStore -> IORef Int -> IO ()+runRawScalarAppendAnyVersionNewStream store counter = do+    streamId <- atomicModifyIORef' counter (\n -> (n + 1, n))+    params <- mkRawAppendParams ("raw-scalar-new-" <> T.pack (show streamId))+    result <- Pool.use (store ^. #pool) $ Session.statement params rawScalarAppendAnyVersion+    forceRawAppend result++runRawProductionAppendAnyVersionNewStream :: KirokuStore -> IORef Int -> IO ()+runRawProductionAppendAnyVersionNewStream store counter = do+    streamId <- atomicModifyIORef' counter (\n -> (n + 1, n))+    params <- mkRawProductionAppendParams <$> mkRawAppendParams ("raw-production-new-" <> T.pack (show streamId))+    result <- Pool.use (store ^. #pool) $ Session.statement params rawProductionAppendAnyVersion+    forceRawAppend result++runRawScalarAppendAnyVersionHotStream :: KirokuStore -> IO ()+runRawScalarAppendAnyVersionHotStream store = do+    params <- mkRawAppendParams "raw-scalar-hot"+    result <- Pool.use (store ^. #pool) $ Session.statement params rawScalarAppendAnyVersion+    forceRawAppend result++runRawProductionAppendAnyVersionHotStream :: KirokuStore -> IO ()+runRawProductionAppendAnyVersionHotStream store = do+    params <- mkRawProductionAppendParams <$> mkRawAppendParams "raw-production-hot"+    result <- Pool.use (store ^. #pool) $ Session.statement params rawProductionAppendAnyVersion+    forceRawAppend result++{- | Two-round-trip hot-stream variant: resolve stream by name, then UPDATE+the existing row keyed on integer stream_id. Both statements run on the+same pooled connection in a Session, each in its own implicit transaction+(no explicit BEGIN/COMMIT). This mirrors eventstore's small-batch path+(`EventStore.Streams.Stream.append_to_stream/5` at < 1000 events), which+runs two Postgrex.query calls without a transaction wrapper and relies on+the stream_events (stream_id, stream_version) unique constraint to detect+races. Wrapping in an explicit BEGIN/COMMIT adds two extra round-trips+and pessimises this path; that variant is measured separately below.+-}+runRawTwoRoundtripAppendExistingHotStream :: KirokuStore -> IO ()+runRawTwoRoundtripAppendExistingHotStream store = do+    base <- mkRawAppendParams "raw-two-roundtrip-hot"+    result <- Pool.use (store ^. #pool) $ do+        mRes <- Session.statement (base ^. #streamName) rawResolveStreamStmt+        case mRes of+            Nothing -> pure (Left "two-roundtrip hot bench: stream not pre-created")+            Just res -> do+                let params = mkRawAppendExistingParams (res ^. #resStreamId) base+                fmap Right (Session.statement params rawAppendUpdateExisting)+    forceTwoRoundtripResult result++{- | Two-round-trip new-stream variant. Same shape as the existing-stream+variant: two implicit-transaction round-trips on a pooled connection,+no explicit transaction wrapper.+-}+runRawTwoRoundtripAppendNewStream :: KirokuStore -> IORef Int -> IO ()+runRawTwoRoundtripAppendNewStream store counter = do+    streamId <- atomicModifyIORef' counter (\n -> (n + 1, n))+    base <- mkRawAppendParams ("raw-two-roundtrip-new-" <> T.pack (show streamId))+    result <- Pool.use (store ^. #pool) $ do+        mRes <- Session.statement (base ^. #streamName) rawResolveStreamStmt+        case mRes of+            Just _ -> pure (Left "two-roundtrip new bench: stream already exists")+            Nothing -> do+                let params = mkRawAppendNewParams base+                fmap Right (Session.statement params rawAppendCreateNew)+    forceTwoRoundtripResult result++{- | Two-round-trip hot-stream variant wrapped in an explicit+read-committed transaction. Provided as a separate benchmark to quantify+the BEGIN/COMMIT round-trip overhead so we can decide whether the live+append path can safely drop the transaction wrapper.+-}+runRawTwoRoundtripAppendExistingHotStreamTx :: KirokuStore -> IO ()+runRawTwoRoundtripAppendExistingHotStreamTx store = do+    base <- mkRawAppendParams "raw-two-roundtrip-hot"+    let txn = do+            mRes <- Tx.statement (base ^. #streamName) rawResolveStreamStmt+            case mRes of+                Nothing -> pure (Left "two-roundtrip hot tx bench: stream not pre-created")+                Just res -> do+                    let params = mkRawAppendExistingParams (res ^. #resStreamId) base+                    fmap Right (Tx.statement params rawAppendUpdateExisting)+    result <-+        Pool.use (store ^. #pool) $+            TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write txn+    forceTwoRoundtripResult result++-- | Two-round-trip new-stream variant wrapped in an explicit transaction.+runRawTwoRoundtripAppendNewStreamTx :: KirokuStore -> IORef Int -> IO ()+runRawTwoRoundtripAppendNewStreamTx store counter = do+    streamId <- atomicModifyIORef' counter (\n -> (n + 1, n))+    base <- mkRawAppendParams ("raw-two-roundtrip-new-tx-" <> T.pack (show streamId))+    let txn = do+            mRes <- Tx.statement (base ^. #streamName) rawResolveStreamStmt+            case mRes of+                Just _ -> pure (Left "two-roundtrip new tx bench: stream already exists")+                Nothing -> do+                    let params = mkRawAppendNewParams base+                    fmap Right (Tx.statement params rawAppendCreateNew)+    result <-+        Pool.use (store ^. #pool) $+            TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write txn+    forceTwoRoundtripResult result++mkRawAppendExistingParams :: Int64 -> RawAppendParams -> RawAppendExistingParams+mkRawAppendExistingParams sid base =+    RawAppendExistingParams+        { existingStreamId = sid+        , existingEventId = base ^. #eventId+        , existingEventType = base ^. #eventType+        , existingCausationId = base ^. #causationId+        , existingCorrelationId = base ^. #correlationId+        , existingPayload = base ^. #payload+        , existingMetadata = base ^. #metadata+        , existingCreatedAt = base ^. #createdAt+        }++mkRawAppendNewParams :: RawAppendParams -> RawAppendNewParams+mkRawAppendNewParams base =+    RawAppendNewParams+        { newStreamName = base ^. #streamName+        , newEventId = base ^. #eventId+        , newEventType = base ^. #eventType+        , newCausationId = base ^. #causationId+        , newCorrelationId = base ^. #correlationId+        , newPayload = base ^. #payload+        , newMetadata = base ^. #metadata+        , newCreatedAt = base ^. #createdAt+        }++forceTwoRoundtripResult ::+    Either Pool.UsageError (Either String (Maybe RawAppendResult)) -> IO ()+forceTwoRoundtripResult (Left e) =+    error ("Two-round-trip bench pool error: " <> show e)+forceTwoRoundtripResult (Right (Left msg)) =+    error ("Two-round-trip bench precondition failed: " <> msg)+forceTwoRoundtripResult (Right (Right inner)) =+    forceRawAppend (Right inner)++{- | Run @writers@ concurrent appenders, each performing @ops@ appends to+its own unique stream. Used by the structured concurrent-writer+benchmarks (EP-6 F19); replaces the wall-clock @mapConcurrently_@+measurement that previously lived inline in @main@.++The @runCounter@ ref is bumped once per call so stream names are unique+across the many iterations tasty-bench runs.+-}+runConcurrentWriters :: KirokuStore -> IORef Int -> Int -> Int -> IO ()+runConcurrentWriters store runCounter writers ops = do+    runId <- atomicModifyIORef' runCounter (\m -> (m + 1, m))+    mapConcurrently_+        (\tid -> mapM_ (appendOne tid runId) [1 .. ops])+        [1 .. writers]+  where+    appendOne :: Int -> Int -> Int -> IO ()+    appendOne tid runId i = do+        let sn = StreamName ("conc-" <> T.pack (show runId) <> "-" <> T.pack (show tid) <> "-" <> T.pack (show i))+        r <- runStoreIO store $ appendToStream sn AnyVersion [makeEvent "ConcEvent"]+        forceAppend r++-- | Exercise the hot stream named in the focused reliability audit.+runHotInvoicePayment :: KirokuStore -> Int -> IO ()+runHotInvoicePayment store ops =+    mapM_+        ( \i -> do+            r <- runStoreIO store $ appendToStream (StreamName "invoice-payment") AnyVersion [makeEvent ("InvoicePayment" <> T.pack (show i))]+            forceAppend r+        )+        [1 .. ops]++-- | Exercise appendMultiStream against existing streams.+runAppendMultiStream :: KirokuStore -> IO ()+runAppendMultiStream store = do+    r <-+        runStoreIO store $+            appendMultiStream+                [ (StreamName "bench-multi-a", AnyVersion, [makeEvent "MultiA"])+                , (StreamName "bench-multi-b", AnyVersion, [makeEvent "MultiB"])+                , (StreamName "bench-multi-c", AnyVersion, [makeEvent "MultiC"])+                ]+    forceAppendList r++-- | Exercise subscription catch-up over a compact category-local backlog.+runSubscriptionCatchup :: KirokuStore -> IORef Int -> IO ()+runSubscriptionCatchup store runCounter = do+    runId <- atomicModifyIORef' runCounter (\m -> (m + 1, m))+    let cat = "benchsub" <> T.pack (show runId)+        sn = StreamName (cat <> "-stream")+        subName = SubscriptionName ("bench-sub-" <> T.pack (show runId))+        events = map (\i -> makeEvent ("SubCatchup" <> T.pack (show i))) [1 .. 100 :: Int]+    r <- runStoreIO store $ appendToStream sn NoStream events+    forceAppend r+    seenRef <- newIORef (0 :: Int)+    let handler _ = do+            n <- atomicModifyIORef' seenRef (\m -> let m' = m + 1 in (m', m'))+            pure $ if n >= 100 then Stop else Continue+        cfg =+            SubscriptionConfig+                { name = subName+                , target = Category (CategoryName cat)+                , handler = handler+                , batchSize = 100+                , queueCapacity = 16+                , overflowPolicy = DropSubscription+                , consumerGroup = Nothing+                , consumerGroupGuard = False+                , retryPolicy = defaultRetryPolicy+                , eventTypeFilter = AllEventTypes+                , selector = Nothing+                }+    handle <- subscribe store cfg+    result <- wait handle+    case result of+        Right () -> pure ()+        Left e -> error ("Subscription catch-up benchmark failed: " <> show e)++-- | Force evaluation of an append result or fail the benchmark.+forceAppend :: Either StoreError AppendResult -> IO ()+forceAppend (Right r) = (r ^. #streamVersion) `seq` (r ^. #globalPosition) `seq` pure ()+forceAppend (Left e) = error ("Benchmark append failed: " <> show e)++-- | Force evaluation of multi-stream append results or fail the benchmark.+forceAppendList :: Either StoreError [AppendResult] -> IO ()+forceAppendList (Right rs) = mapM_ (\r -> (r ^. #streamVersion) `seq` (r ^. #globalPosition) `seq` pure ()) rs+forceAppendList (Left e) = error ("Benchmark appendMultiStream failed: " <> show e)++-- | Force evaluation of a raw append shape result or fail the benchmark.+forceRawAppend :: Either Pool.UsageError (Maybe RawAppendResult) -> IO ()+forceRawAppend (Right (Just (!streamId, !streamVersion, !globalPosition))) =+    streamId `seq` streamVersion `seq` globalPosition `seq` pure ()+forceRawAppend (Right Nothing) = error "Raw append benchmark produced no result"+forceRawAppend (Left e) = error ("Raw append benchmark failed: " <> show e)++-- | Force evaluation of a read result or fail the benchmark.+forceRead :: Either StoreError (V.Vector RecordedEvent) -> IO ()+forceRead (Right v) = V.length v `seq` pure ()+forceRead (Left e) = error ("Benchmark read failed: " <> show e)++main :: IO ()+main = do+    -- Start ephemeral PostgreSQL once for all benchmarks+    result <- Pg.withCached $ \db -> do+        let settings = defaultConnectionSettings (Pg.connectionString db)+        withStore settings $ \store -> do+            -- Counter for unique stream names across benchmarks+            counter <- newIORef (0 :: Int)+            let nextStream :: Text -> IO StreamName+                nextStream prefix = do+                    n <- atomicModifyIORef' counter (\n -> (n + 1, n))+                    pure (StreamName (prefix <> "-" <> T.pack (show n)))++            -- Pre-populate streams for category benchmarks (B10)+            -- 100 categories × 10 streams × 100 events = 100K events+            putStrLn "\n--- Pre-populating category data (100 cats × 10 streams × 100 events) ---"+            catT0 <- getCurrentTime+            mapM_+                ( \cat -> do+                    mapM_+                        ( \s -> do+                            let sn = StreamName ("cat" <> T.pack (show cat) <> "-" <> T.pack (show s))+                            let evts = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. 100 :: Int]+                            r' <- runStoreIO store $ appendToStream sn NoStream evts+                            forceAppend r'+                        )+                        [1 .. 10 :: Int]+                )+                [1 .. 100 :: Int]+            catT1 <- getCurrentTime+            let catElapsed = realToFrac (diffUTCTime catT1 catT0) :: Double+            putStrLn $ "  Setup time: " <> show catElapsed <> "s (100K events)"++            -- Pre-populate streams for read benchmarks+            -- B4: Single stream with 1000 events+            let readStreamName = StreamName "bench-read-stream"+            let readEvents = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. 1000 :: Int]+            r <- runStoreIO store $ appendToStream readStreamName NoStream readEvents+            forceAppend r++            -- B5: 10 streams with 100 events each for $all reads (1000 total)+            mapM_+                ( \s -> do+                    let sn = StreamName ("bench-all-" <> T.pack (show s))+                    let evts = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. 100 :: Int]+                    r' <- runStoreIO store $ appendToStream sn NoStream evts+                    forceAppend r'+                )+                [1 .. 10 :: Int]++            -- Pre-create fixed streams for appendMultiStream benchmark iterations.+            mapM_+                ( \sn -> do+                    r' <- runStoreIO store $ appendToStream sn NoStream [makeEvent "Init"]+                    forceAppend r'+                )+                [StreamName "bench-multi-a", StreamName "bench-multi-b", StreamName "bench-multi-c"]++            -- Pre-create the hot stream targeted by the two-round-trip raw+            -- shape variant. rawAppendUpdateExisting requires the row to+            -- exist (no ON CONFLICT), so without this warmup the first+            -- iteration would fail. The scalar-singleton and production+            -- variants already create their hot stream on first iteration+            -- via ON CONFLICT — pre-creating them here would change the+            -- existing benchmark contract, so we only seed the two-round-trip+            -- target.+            do+                r' <- runStoreIO store $ appendToStream (StreamName "raw-two-roundtrip-hot") AnyVersion [makeEvent "Init"]+                forceAppend r'++            -- B9: Pool saturation benchmark (64 concurrent writers, 100 appends each)+            putStrLn "\n--- B9: Pool saturation (64 writers × 100 appends, pool size 10) ---"+            satCounter <- newIORef (0 :: Int)+            let nextSatStream :: Int -> Int -> StreamName+                nextSatStream tid i = StreamName ("sat-" <> T.pack (show tid) <> "-" <> T.pack (show i))+            t0 <- getCurrentTime+            mapConcurrently_+                ( \tid -> do+                    mapM_+                        ( \i -> do+                            let sn = nextSatStream tid i+                            r' <- runStoreIO store $ appendToStream sn AnyVersion [makeEvent "SatEvent"]+                            forceAppend r'+                            atomicModifyIORef' satCounter (\n -> (n + 1, ()))+                        )+                        [1 .. 100 :: Int]+                )+                [1 .. 64 :: Int]+            t1 <- getCurrentTime+            totalOps <- readIORef satCounter+            let elapsed = realToFrac (diffUTCTime t1 t0) :: Double+            let throughput = fromIntegral totalOps / elapsed+            let avgLatency = elapsed / fromIntegral totalOps * 1000 -- ms+            putStrLn $ "  Total appends: " <> show totalOps+            putStrLn $ "  Elapsed: " <> show elapsed <> "s"+            putStrLn $ "  Throughput: " <> show (round throughput :: Int) <> " ops/s"+            putStrLn $ "  Avg latency: " <> show avgLatency <> " ms"+            putStrLn "---"++            -- Counter shared by the concurrent-writer benchmarks so each+            -- iteration uses a fresh stream-name run-id.+            concCounter <- newIORef (0 :: Int)+            rawCounter <- newIORef (0 :: Int)+            subCounter <- newIORef (0 :: Int)++            defaultMain+                [ bgroup+                    "append"+                    [ bgroup+                        "single-event"+                        [ bench "NoStream (new stream)" $ whnfIO $ do+                            sn <- nextStream "bench-single"+                            r' <- runStoreIO store $ appendToStream sn NoStream [makeEvent "BenchEvent"]+                            forceAppend r'+                        , bench "AnyVersion (new stream)" $ whnfIO $ do+                            sn <- nextStream "bench-any"+                            r' <- runStoreIO store $ appendToStream sn AnyVersion [makeEvent "BenchEvent"]+                            forceAppend r'+                        ]+                    , bgroup+                        "batch-10"+                        [ bench "NoStream" $ whnfIO $ do+                            sn <- nextStream "bench-b10"+                            let events = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. 10 :: Int]+                            r' <- runStoreIO store $ appendToStream sn NoStream events+                            forceAppend r'+                        ]+                    , bgroup+                        "batch-100"+                        [ bench "NoStream" $ whnfIO $ do+                            sn <- nextStream "bench-b100"+                            let events = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. 100 :: Int]+                            r' <- runStoreIO store $ appendToStream sn NoStream events+                            forceAppend r'+                        ]+                    , bgroup+                        "sequential"+                        [ bench "10 appends to same stream" $ whnfIO $ do+                            sn <- nextStream "bench-seq"+                            r0 <- runStoreIO store $ appendToStream sn NoStream [makeEvent "Init"]+                            forceAppend r0+                            let Right res0 = r0+                            let go _ 0 = pure ()+                                go v n = do+                                    r' <- runStoreIO store $ appendToStream sn (ExactVersion v) [makeEvent "Seq"]+                                    case r' of+                                        Right res -> go (res ^. #streamVersion) (n - 1 :: Int)+                                        Left e -> error ("Sequential append failed: " <> show e)+                            go (res0 ^. #streamVersion) 9+                        ]+                    ]+                , bgroup+                    "raw-append-shape"+                    [ bgroup+                        "AnyVersion"+                        [ bench "scalar singleton (new stream)" $+                            whnfIO $+                                runRawScalarAppendAnyVersionNewStream store rawCounter+                        , bench "production arrays/unnest (new stream)" $+                            whnfIO $+                                runRawProductionAppendAnyVersionNewStream store rawCounter+                        , bench "two-roundtrip (new stream)" $+                            whnfIO $+                                runRawTwoRoundtripAppendNewStream store rawCounter+                        , bench "two-roundtrip + BEGIN/COMMIT (new stream)" $+                            whnfIO $+                                runRawTwoRoundtripAppendNewStreamTx store rawCounter+                        , bench "scalar singleton (hot stream)" $+                            whnfIO $+                                runRawScalarAppendAnyVersionHotStream store+                        , bench "production arrays/unnest (hot stream)" $+                            whnfIO $+                                runRawProductionAppendAnyVersionHotStream store+                        , bench "two-roundtrip (hot stream)" $+                            whnfIO $+                                runRawTwoRoundtripAppendExistingHotStream store+                        , bench "two-roundtrip + BEGIN/COMMIT (hot stream)" $+                            whnfIO $+                                runRawTwoRoundtripAppendExistingHotStreamTx store+                        ]+                    ]+                , bgroup+                    "read"+                    [ bench "stream forward (100-event page)" $ whnfIO $ do+                        r' <- runStoreIO store $ readStreamForward readStreamName (StreamVersion 0) 100+                        forceRead r'+                    , bench "$all forward (100-event page)" $ whnfIO $ do+                        r' <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+                        forceRead r'+                    ]+                , bgroup+                    "category"+                    [ bench "category forward (100-event page)" $ whnfIO $ do+                        -- Read from cat1 category (has 10 streams × 100 events = 1000 events)+                        r' <- runStoreIO store $ readCategory (CategoryName "cat1") (GlobalPosition 0) 100+                        forceRead r'+                    , bench "exhausted-category" $ whnfIO $ do+                        -- cat1 events are inserted early in setup; a high cursor proves+                        -- category reads do not scan the rest of $all looking for matches.+                        r' <- runStoreIO store $ readCategory (CategoryName "cat1") (GlobalPosition 90_000) 100+                        forceRead r'+                    , bench "$all forward (100-event page, baseline)" $ whnfIO $ do+                        r' <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+                        forceRead r'+                    ]+                , -- F19 — Concurrent-writer stress as structured benchmarks.+                  -- The legacy ad-hoc B9 measurement (still present above+                  -- for historical comparability) prints throughput and+                  -- latency once; these bgroup entries surface the same+                  -- workload through tasty-bench so it participates in the+                  -- baseline-regression workflow (Justfile bench-regression).+                  bgroup+                    "concurrent"+                    [ bench "8 writers x 10 appends" $ whnfIO $ runConcurrentWriters store concCounter 8 10+                    , bench "32 writers x 10 appends" $ whnfIO $ runConcurrentWriters store concCounter 32 10+                    ]+                , bgroup+                    "reliability-audit"+                    [ bench "hot invoice-payment 10 AnyVersion appends" $ whnfIO $ runHotInvoicePayment store 10+                    , bench "appendMultiStream 3 existing streams" $ whnfIO $ runAppendMultiStream store+                    , bench "subscription category catch-up 100 events" $ whnfIO $ runSubscriptionCatchup store subCounter+                    ]+                ]+    case result of+        Left err -> error ("Failed to start ephemeral PostgreSQL: " <> show err)+        Right () -> pure ()++makeEvent :: Text -> EventData+makeEvent typ =+    EventData+        { eventId = Nothing+        , eventType = EventType typ+        , payload = Aeson.object [("benchmark", Aeson.Bool True)]+        , metadata = Nothing+        , causationId = Nothing+        , correlationId = Nothing+        }
+ bench/ShibuyaOverhead.hs view
@@ -0,0 +1,313 @@+{- | Benchmark measuring the overhead of the Shibuya adapter layer+compared to bare kiroku subscriptions. Three layers are measured:++1. Bare subscribe: handler receives events directly from the subscription worker+2. subscriptionStream: events pass through a TBQueue bridge to a Streamly stream+3. Shibuya adapter: events flow through subscriptionStream → morphInner → Shibuya pipeline++The bare subscribe handler processes events synchronously (one at a time),+while the stream-based approaches decouple the producer from the consumer+via a TBQueue, allowing the subscription worker to batch-fetch ahead.+This means subscriptionStream and Shibuya can be *faster* for catch-up —+the relevant overhead comparison is shibuya vs subscriptionStream.+-}+module Main where++import Control.Concurrent (threadDelay)+import Control.Concurrent.STM (atomically, newTVarIO, readTVar, readTVarIO, registerDelay, writeTVar)+import Control.Concurrent.STM qualified as STM+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.HashMap.Strict qualified as HashMap+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import Data.List (sort)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time.Clock (diffUTCTime, getCurrentTime)+import Effectful (Eff, IOE, liftIO, runEff, (:>))+import EphemeralPg qualified as Pg+import Kiroku.Store+import Kiroku.Store.Subscription (subscribe)+import Kiroku.Store.Subscription.Stream (subscriptionStream)+import Kiroku.Store.Subscription.Types (OverflowPolicy (..), SubscriptionConfigM (..), SubscriptionHandleM (..))+import Shibuya.Adapter (Adapter (..))+import Shibuya.App (ProcessorId (..), SupervisionStrategy (..), mkProcessor, runApp, stopApp)+import Shibuya.Core.Ack (AckDecision (..))+import Shibuya.Core.AckHandle (AckHandle (..))+import Shibuya.Core.Ingested (Ingested (..))+import Shibuya.Core.Types (Cursor (..), Envelope (..), MessageId (..))+import Shibuya.Telemetry.Effect (runTracingNoop)+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Stream+import System.IO (hFlush, stdout)+import Text.Printf (printf)++iterations :: Int+iterations = 5++main :: IO ()+main = do+    result <- Pg.withCached $ \db -> do+        let settings = defaultConnectionSettings (Pg.connectionString db)+        withStore settings $ \store -> do+            putStrLn "=== Kiroku Shibuya Adapter Overhead Benchmark ==="+            printf "    %d iterations per measurement\n\n" iterations++            mapM_ (runBenchmarkSuite store) [100, 1000, 5000]++    case result of+        Left err -> error ("Failed to start ephemeral PostgreSQL: " <> show err)+        Right () -> pure ()++runBenchmarkSuite :: KirokuStore -> Int -> IO ()+runBenchmarkSuite store n = do+    printf "--- %d events ---\n\n" n++    -- Pre-populate events+    counter <- newIORef (0 :: Int)+    let nextId = atomicModifyIORef' counter (\i -> (i + 1, i))++    let streamPrefix = "bench-" <> T.pack (show n) <> "-"+    let events = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. n]+    let chunked = chunksOf 10 events+    mapM_+        ( \(idx, chunk) -> do+            let sn = StreamName (streamPrefix <> T.pack (show idx))+            Right _ <- runStoreIO store $ appendToStream sn AnyVersion chunk+            pure ()+        )+        (zip [(0 :: Int) ..] chunked)+    threadDelay 500_000++    -- Run each benchmark multiple times+    bareTimes <- sequence [benchBareSubscribe store n nextId | _ <- [1 .. iterations]]+    streamTimes <- sequence [benchSubscriptionStream store n nextId | _ <- [1 .. iterations]]+    shibuyaTimes <- sequence [benchShibuyaAdapter store n nextId | _ <- [1 .. iterations]]++    let bareMedian = median bareTimes+        streamMedian = median streamTimes+        shibuyaMedian = median shibuyaTimes++    putRow "  bare subscribe" n bareTimes+    putRow "  subscriptionStream" n streamTimes+    putRow "  shibuya adapter" n shibuyaTimes++    putStrLn ""+    let streamVsBare = (streamMedian - bareMedian) / bareMedian * 100+        shibuyaVsBare = (shibuyaMedian - bareMedian) / bareMedian * 100+        shibuyaVsStream = (shibuyaMedian - streamMedian) / streamMedian * 100+    printf "  stream vs bare:    %s\n" (showPct streamVsBare)+    printf "  shibuya vs bare:   %s\n" (showPct shibuyaVsBare)+    printf "  shibuya vs stream: %s  (adapter + framework overhead)\n" (showPct shibuyaVsStream)+    putStrLn ""++-- | Benchmark: bare subscribe with IO handler+benchBareSubscribe :: KirokuStore -> Int -> IO Int -> IO Double+benchBareSubscribe store n nextId = do+    subId <- nextId+    let subName = SubscriptionName ("bare-bench-" <> T.pack (show subId))+    countVar <- newTVarIO (0 :: Int)++    t0 <- getCurrentTime+    let handler _evt = do+            atomically $ do+                c <- readTVar countVar+                writeTVar countVar (c + 1)+            pure Continue+    let cfg =+            SubscriptionConfig+                { name = subName+                , target = AllStreams+                , handler = handler+                , batchSize = 500+                , queueCapacity = 16+                , overflowPolicy = DropSubscription+                , consumerGroup = Nothing+                , consumerGroupGuard = False+                , retryPolicy = defaultRetryPolicy+                , eventTypeFilter = AllEventTypes+                , selector = Nothing+                }+    handle <- subscribe store cfg+    waitForCount countVar n 30_000_000+    cancel handle+    t1 <- getCurrentTime+    pure (realToFrac (diffUTCTime t1 t0))++-- | Benchmark: subscriptionStream consumed via Streamly fold+benchSubscriptionStream :: KirokuStore -> Int -> IO Int -> IO Double+benchSubscriptionStream store n nextId = do+    subId <- nextId+    let subName = SubscriptionName ("stream-bench-" <> T.pack (show subId))++    let cfg =+            SubscriptionConfig+                { name = subName+                , target = AllStreams+                , handler = \_ -> pure Continue+                , batchSize = 500+                , queueCapacity = 16+                , overflowPolicy = DropSubscription+                , consumerGroup = Nothing+                , consumerGroupGuard = False+                , retryPolicy = defaultRetryPolicy+                , eventTypeFilter = AllEventTypes+                , selector = Nothing+                }++    t0 <- getCurrentTime+    (stream, cancelStream) <- subscriptionStream store cfg 256+    Stream.fold Fold.drain (Stream.take n stream)+    cancelStream+    t1 <- getCurrentTime+    pure (realToFrac (diffUTCTime t1 t0))++-- | Benchmark: Shibuya adapter with runApp+benchShibuyaAdapter :: KirokuStore -> Int -> IO Int -> IO Double+benchShibuyaAdapter store n nextId = do+    subId <- nextId+    let subName = SubscriptionName ("shibuya-bench-" <> T.pack (show subId))+    countVar <- newTVarIO (0 :: Int)++    t0 <- getCurrentTime+    runEff $ runTracingNoop $ do+        let cfg =+                SubscriptionConfig+                    { name = subName+                    , target = AllStreams+                    , handler = \_ -> pure Continue+                    , batchSize = 500+                    , queueCapacity = 16+                    , overflowPolicy = DropSubscription+                    , consumerGroup = Nothing+                    , consumerGroupGuard = False+                    , retryPolicy = defaultRetryPolicy+                    , eventTypeFilter = AllEventTypes+                    , selector = Nothing+                    }++        (ioStream, cancelAction) <- liftIO $ subscriptionStream store cfg 256++        let effStream = Stream.morphInner liftIO ioStream+            ingestedStream = fmap (mkIngested cancelAction) effStream++        let adapter =+                Adapter+                    { adapterName = "kiroku-bench"+                    , source = ingestedStream+                    , shutdown = liftIO cancelAction+                    }++        let handler :: (IOE :> es) => Ingested es RecordedEvent -> Eff es AckDecision+            handler _ingested = do+                liftIO $ atomically $ do+                    c <- readTVar countVar+                    writeTVar countVar (c + 1)+                pure AckOk++        res <- runApp IgnoreFailures 100 [(ProcessorId "bench", mkProcessor adapter handler)]+        case res of+            Left err -> liftIO $ error ("runApp failed: " <> show err)+            Right appHandle -> do+                liftIO $ waitForCount countVar n 30_000_000+                stopApp appHandle++    t1 <- getCurrentTime+    pure (realToFrac (diffUTCTime t1 t0))++-- Helpers++mkIngested :: (IOE :> es) => IO () -> RecordedEvent -> Ingested es RecordedEvent+mkIngested cancelAction event =+    Ingested+        { envelope =+            Envelope+                { messageId = MessageId (T.pack (show (event ^. #globalPosition)))+                , cursor = let GlobalPosition pos = event ^. #globalPosition in Just (CursorInt (fromIntegral pos))+                , partition = Nothing+                , enqueuedAt = Just (event ^. #createdAt)+                , traceContext = Nothing+                , attempt = Nothing+                , attributes = HashMap.empty+                , payload = event+                }+        , ack =+            AckHandle+                { finalize = \case+                    AckHalt _ -> liftIO cancelAction+                    _ -> pure ()+                }+        , lease = Nothing+        }++waitForCount :: STM.TVar Int -> Int -> Int -> IO ()+waitForCount countVar target timeoutMicros = do+    timeoutVar <- registerDelay timeoutMicros+    ok <-+        atomically $+            (readTVar countVar >>= \c -> STM.check (c >= target) >> pure True)+                `STM.orElse` (readTVar timeoutVar >>= STM.check >> pure False)+    actual <- readTVarIO countVar+    if ok+        then pure ()+        else error ("Timed out: expected " <> show target <> " events, got " <> show actual)++median :: [Double] -> Double+median xs =+    let sorted = sort xs+        len = length sorted+     in if even len+            then (sorted !! (len `div` 2 - 1) + sorted !! (len `div` 2)) / 2+            else sorted !! (len `div` 2)++putRow :: String -> Int -> [Double] -> IO ()+putRow label n times = do+    let med = median times+        lo = minimum times+        hi = maximum times+        throughput = fromIntegral n / med :: Double+        perEvent = med / fromIntegral n * 1_000_000 :: Double+    printf+        "%s:  median %s  [%s .. %s]  (%d events/s, %s/event)\n"+        label+        (showMs med)+        (showMs lo)+        (showMs hi)+        (round throughput :: Int)+        (showUs perEvent)+    hFlush stdout++showMs :: Double -> String+showMs s+    | ms < 1 = printf "%.1f ms" ms+    | ms < 100 = printf "%.0f ms" ms+    | otherwise = printf "%.0f ms" ms+  where+    ms = s * 1000++showUs :: Double -> String+showUs us+    | us >= 1000 = printf "%.1f ms" (us / 1000)+    | us >= 1 = printf "%.0f μs" us+    | otherwise = printf "%.1f μs" us++showPct :: Double -> String+showPct p+    | p >= 0 = printf "+%.0f%%" p+    | otherwise = printf "%.0f%%" p++chunksOf :: Int -> [a] -> [[a]]+chunksOf _ [] = []+chunksOf k xs = let (h, t) = splitAt k xs in h : chunksOf k t++makeEvent :: Text -> EventData+makeEvent typ =+    EventData+        { eventId = Nothing+        , eventType = EventType typ+        , payload = Aeson.object [("benchmark", Aeson.Bool True)]+        , metadata = Nothing+        , causationId = Nothing+        , correlationId = Nothing+        }
+ kiroku-store.cabal view
@@ -0,0 +1,210 @@+cabal-version:   3.0+name:            kiroku-store+version:         0.2.0.0+synopsis:        High-performance PostgreSQL event store+description:+  Kiroku is a PostgreSQL-backed event store for Haskell applications. It+  provides append, read, link, lifecycle, transaction, subscription, consumer+  group, and observability primitives around immutable domain events.++homepage:        https://github.com/shinzui/kiroku+bug-reports:     https://github.com/shinzui/kiroku/issues+author:          Nadeem Bitar+maintainer:      nadeem@gmail.com+license:         BSD-3-Clause+build-type:      Simple+category:        Database, Eventing+extra-doc-files: CHANGELOG.md++source-repository head+  type:     git+  location: https://github.com/shinzui/kiroku.git++common common+  default-language:   GHC2024+  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    OverloadedLabels+    OverloadedStrings++library+  import:          common+  exposed-modules:+    Kiroku.Store+    Kiroku.Store.Append+    Kiroku.Store.Causation+    Kiroku.Store.Connection+    Kiroku.Store.Effect+    Kiroku.Store.Effect.Resource+    Kiroku.Store.Error+    Kiroku.Store.Lifecycle+    Kiroku.Store.Link+    Kiroku.Store.Notification+    Kiroku.Store.Observability+    Kiroku.Store.Read+    Kiroku.Store.Settings+    Kiroku.Store.SQL+    Kiroku.Store.Subscription+    Kiroku.Store.Subscription.Effect+    Kiroku.Store.Subscription.EventPublisher+    Kiroku.Store.Subscription.Fsm+    Kiroku.Store.Subscription.Stream+    Kiroku.Store.Subscription.Types+    Kiroku.Store.Subscription.Worker+    Kiroku.Store.Transaction+    Kiroku.Store.Types++  build-depends:+    , aeson                 >=2.1  && <2.3+    , async                 >=2.2  && <2.3+    , base                  >=4.18 && <5+    , bytestring            >=0.11 && <0.13+    , containers            >=0.6  && <0.8+    , contravariant-extras  >=0.3  && <0.4+    , effectful-core        >=2.4  && <2.7+    , generic-lens          >=2.2  && <2.4+    , hasql                 >=1.10 && <1.11+    , hasql-notifications   >=0.2  && <0.3+    , hasql-pool            >=1.2  && <1.5+    , hasql-transaction     >=1.1  && <1.3+    , lens                  >=5.2  && <5.4+    , mmzk-typeid           >=0.6  && <0.8+    , stm                   >=2.5  && <2.6+    , streamly-core         >=0.3  && <0.4+    , text                  >=2.0  && <2.2+    , time                  >=1.12 && <1.15+    , unliftio-core         >=0.2  && <0.3+    , uuid                  >=1.3  && <1.4+    , vector                >=0.13 && <0.14++  hs-source-dirs:  src++test-suite kiroku-store-test+  import:         common+  type:           exitcode-stdio-1.0+  main-is:        Main.hs+  hs-source-dirs: test+  other-modules:+    Test.CatchupDbErrorNoPrematureSwitch+    Test.CategoryIdleNoSpin+    Test.Causation+    Test.Concurrency+    Test.ConsumerGroup+    Test.ConsumerGroupEffect+    Test.ConsumerGroupSql+    Test.EventTypeFilter+    Test.FailureInjection+    Test.Helpers+    Test.InterpreterHooks+    Test.Properties+    Test.PublisherRestartNoRebroadcast+    Test.ReadStream+    Test.StreamNameLookup+    Test.SubscriptionPauseResume+    Test.SubscriptionReconnect+    Test.SubscriptionRegistry+    Test.SubscriptionRetryDeadLetter+    Test.SubscriptionState+    Test.Transaction++  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  build-depends:+    , aeson                 >=2.1  && <2.3+    , async                 >=2.2  && <2.3+    , base                  >=4.18 && <5+    , containers            >=0.6  && <0.8+    , contravariant-extras  >=0.3+    , directory+    , effectful-core        >=2.4  && <2.7+    , ephemeral-pg          >=0.2  && <0.3+    , generic-lens          >=2.2  && <2.4+    , hasql                 >=1.10 && <1.11+    , hasql-pool            >=1.2  && <1.5+    , hasql-transaction     >=1.1  && <1.3+    , hedgehog              >=1.4  && <1.8+    , hspec                 >=2.10 && <2.12+    , hspec-hedgehog        >=0.0  && <0.4+    , kiroku-store+    , kiroku-test-support+    , lens                  >=5.2  && <5.4+    , stm                   >=2.5  && <2.6+    , streamly-core         >=0.3  && <0.4+    , text                  >=2.0  && <2.2+    , time                  >=1.12 && <1.15+    , uuid                  >=1.3  && <1.4+    , vector                >=0.13 && <0.14++benchmark kiroku-store-bench+  import:         common+  type:           exitcode-stdio-1.0+  main-is:        Main.hs+  hs-source-dirs: bench+  ghc-options:    -threaded -rtsopts "-with-rtsopts=-N -A32m"+  build-depends:+    , aeson              >=2.1  && <2.3+    , async              >=2.2  && <2.3+    , base               >=4.18 && <5+    , deepseq            >=1.4+    , ephemeral-pg       >=0.2  && <0.3+    , generic-lens       >=2.2  && <2.4+    , hasql              >=1.10 && <1.11+    , hasql-pool         >=1.2  && <1.5+    , hasql-transaction  >=1.1  && <1.3+    , kiroku-store+    , lens               >=5.2  && <5.4+    , mmzk-typeid        >=0.6+    , tasty-bench        >=0.4+    , text               >=2.0  && <2.2+    , time               >=1.12 && <1.15+    , uuid               >=1.3  && <1.4+    , vector             >=0.13 && <0.14++benchmark kiroku-shibuya-overhead+  import:         common+  type:           exitcode-stdio-1.0+  main-is:        ShibuyaOverhead.hs+  hs-source-dirs: bench+  ghc-options:    -threaded -rtsopts "-with-rtsopts=-N -A32m"+  build-depends:+    , aeson                 >=2.1  && <2.3+    , base                  >=4.18 && <5+    , containers            >=0.6  && <0.8+    , effectful             >=2.4  && <2.7+    , effectful-core        >=2.4  && <2.7+    , ephemeral-pg          >=0.2  && <0.3+    , generic-lens          >=2.2  && <2.4+    , kiroku-store+    , lens                  >=5.2  && <5.4+    , shibuya-core          >=0.6  && <0.7+    , stm                   >=2.5  && <2.6+    , streamly              >=0.11+    , streamly-core         >=0.3  && <0.4+    , text                  >=2.0  && <2.2+    , time                  >=1.12 && <1.15+    , unliftio              >=0.2+    , unordered-containers  >=0.2  && <0.3+    , uuid                  >=1.3  && <1.4++benchmark kiroku-store-bench-explain+  import:         common+  type:           exitcode-stdio-1.0+  main-is:        Explain.hs+  hs-source-dirs: bench+  ghc-options:    -threaded -rtsopts "-with-rtsopts=-N -A32m"+  build-depends:+    , aeson         >=2.1  && <2.3+    , base          >=4.18 && <5+    , bytestring    >=0.11 && <0.13+    , directory     >=1.3+    , ephemeral-pg  >=0.2  && <0.3+    , filepath      >=1.4+    , generic-lens  >=2.2  && <2.4+    , hasql         >=1.10 && <1.11+    , hasql-pool    >=1.2  && <1.5+    , kiroku-store+    , lens          >=5.2  && <5.4+    , text          >=2.0  && <2.2+    , time          >=1.12 && <1.15+    , uuid          >=1.3  && <1.4+    , vector        >=0.13 && <0.14
+ src/Kiroku/Store.hs view
@@ -0,0 +1,67 @@+{- | Kiroku Store — high-performance PostgreSQL event store.++Public API re-exports.++Note: The effectful @subscribe@ wrapper from "Kiroku.Store.Subscription.Effect"+is /not/ re-exported here to avoid a name clash with+"Kiroku.Store.Subscription.subscribe". Import @Kiroku.Store.Subscription.Effect@+explicitly to use the effectful version.+-}+module Kiroku.Store (+    module Kiroku.Store.Types,+    module Kiroku.Store.Connection,+    module Kiroku.Store.Effect,+    module Kiroku.Store.Effect.Resource,+    module Kiroku.Store.Error,+    module Kiroku.Store.Append,+    module Kiroku.Store.Causation,+    module Kiroku.Store.Lifecycle,+    module Kiroku.Store.Link,+    module Kiroku.Store.Read,+    module Kiroku.Store.Settings,+    module Kiroku.Store.Subscription,+    module Kiroku.Store.Transaction,++    -- * Subscription effect (interpreter only — import Effect module for @subscribe@)+    Subscription,+    runSubscription,+    runSubscriptionResource,++    -- * Notifier startup+    NotifierStartError (..),++    -- * Operational events emitted by the store itself+    KirokuEvent (..),+    SubscriptionDbPhase (..),+    SubscriptionStopReason (..),+    SubscriptionGroupContext (..),++    -- * Subscription FSM state helpers+    stateName,+    stateCursor,++    -- * Pool observation types (re-exported from hasql-pool)+    Observation (..),+    ConnectionStatus (..),+    ConnectionReadyForUseReason (..),+    ConnectionTerminationReason (..),+) where++import Hasql.Pool.Observation (ConnectionReadyForUseReason (..), ConnectionStatus (..), ConnectionTerminationReason (..), Observation (..))+import Kiroku.Store.Append+import Kiroku.Store.Causation+import Kiroku.Store.Connection+import Kiroku.Store.Effect+import Kiroku.Store.Effect.Resource+import Kiroku.Store.Error+import Kiroku.Store.Lifecycle+import Kiroku.Store.Link+import Kiroku.Store.Notification (NotifierStartError (..))+import Kiroku.Store.Observability (KirokuEvent (..), SubscriptionDbPhase (..), SubscriptionGroupContext (..), SubscriptionStopReason (..))+import Kiroku.Store.Read+import Kiroku.Store.Settings+import Kiroku.Store.Subscription+import Kiroku.Store.Subscription.Effect (Subscription, runSubscription, runSubscriptionResource)+import Kiroku.Store.Subscription.Fsm (stateCursor, stateName)+import Kiroku.Store.Transaction+import Kiroku.Store.Types
+ src/Kiroku/Store/Append.hs view
@@ -0,0 +1,110 @@+module Kiroku.Store.Append (+    appendToStream,+    appendMultiStream,+) where++import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Kiroku.Store.Effect (Store (..))+import Kiroku.Store.Types++{- | Append a batch of events to a single stream under the given+'ExpectedVersion' precondition.++When to use this vs.+'Kiroku.Store.Transaction.runTransactionAppending':++* Reach for 'appendToStream' by default. It is the cheapest path —+  one CTE on a pool connection, no Haskell-layer @BEGIN@/@COMMIT@+  envelope, no caller-driven retry semantics to reason about.+* Reach for 'Kiroku.Store.Transaction.runTransactionAppending' /only/+  when you need to atomically combine the append with additional SQL+  writes that the store doesn't perform (most prominently a+  projection-row insert from a downstream projection table). The+  wrapper opens an explicit 'BEGIN'/'COMMIT', enables PostgreSQL+  serialization-conflict retry of the entire body by default, and+  threads the caller's continuation into the same transaction.++Semantics:++* If the precondition fails, the entire batch is rejected — appends are+  all-or-nothing per call.+* On success, events are visible to subsequent reads on /this/ store+  handle (read-your-own-writes is guaranteed). Other store handles see+  the events after their pool connection's transaction-visibility+  horizon advances.+* The returned 'AppendResult' carries the position of the /last/ event+  in the batch.++Idempotent retries: supply 'Kiroku.Store.Types.EventData.eventId' yourself+and retry on transient failures. A retry whose previous attempt actually+committed surfaces as 'Kiroku.Store.Error.DuplicateEvent' (when the+events_pkey detail is parseable). A retry that observed+'Kiroku.Store.Error.WrongExpectedVersion' on an 'ExactVersion' append+should be treated as ambiguous: either a concurrent writer raced you or+your previous attempt succeeded; the recovery in both cases is to+re-read the stream and decide.++Errors (all variants of 'Kiroku.Store.Error.StoreError'):++* 'Kiroku.Store.Error.WrongExpectedVersion' — 'ExactVersion' mismatch.+* 'Kiroku.Store.Error.StreamNotFound' — 'StreamExists' against a missing+  or soft-deleted stream.+* 'Kiroku.Store.Error.ReservedStreamName' — the target is @$all@, which+  is the global read stream and cannot be appended as an application+  stream.+* 'Kiroku.Store.Error.StreamAlreadyExists' — 'NoStream' against an+  existing stream (including soft-deleted).+* 'Kiroku.Store.Error.DuplicateEvent' — caller-supplied 'eventId'+  collides with an existing event.++Empty event lists: passing @[]@ is a programming mistake. The+underlying CTE returns 0 rows, which the interpreter maps to a+constructor that depends on the supplied 'ExpectedVersion'+('Kiroku.Store.Error.WrongExpectedVersion' for 'ExactVersion',+'Kiroku.Store.Error.StreamNotFound' for 'StreamExists', and so on).+None of these is the caller's intent; reject the call yourself before+invoking the API.+-}+appendToStream ::+    (HasCallStack, Store :> es) =>+    StreamName ->+    ExpectedVersion ->+    [EventData] ->+    Eff es AppendResult+appendToStream name expected events = send (AppendToStream name expected events)++{- | Atomically append events to multiple streams in a single+transaction.++Either every per-stream append succeeds or all of them roll back —+there is no partial-commit state. The interpreter pre-locks the named+streams in deterministic @stream_id@ order to avoid deadlocks when two+concurrent multi-stream calls touch overlapping streams in different+user orders.++@$all@ is reserved for the global read stream. If any operation targets+@$all@, the whole call is rejected before opening the transaction with+'Kiroku.Store.Error.ReservedStreamName'.++Per-stream errors are attributed to the stream that caused them: the+@Right results@ branch of the interpreter iterates the input list and+maps each empty CTE result back to the corresponding @(StreamName,+ExpectedVersion)@. Errors raised as PostgreSQL exceptions are+attributed via 'Kiroku.Store.Error.attributeMultiStreamError', which+parses the server-error detail for the offending stream name when+possible; the latent misattribution path (a future schema change that+introduces a constraint violation visible to the client) is covered+defensively.++The returned list mirrors the input order. Each 'AppendResult' carries+the corresponding stream's final state.++Empty input @[]@ is a no-op programming mistake; do not call.+-}+appendMultiStream ::+    (HasCallStack, Store :> es) =>+    [(StreamName, ExpectedVersion, [EventData])] ->+    Eff es [AppendResult]+appendMultiStream ops = send (AppendMultiStream ops)
+ src/Kiroku/Store/Causation.hs view
@@ -0,0 +1,66 @@+{- | Smart constructors for the causation- and correlation-walking reads.++These wrap the 'Kiroku.Store.Effect.FindEvents' constructor with a filter+suited to a specific question:++* 'findCausationDescendants' — walk the causation graph forward from a+  trigger event and return every event that descended from it.+* 'findCausationAncestors' — walk the causation graph backward from a+  leaf event and return every event reachable by following+  @causation_id@ upward.+* 'findByCorrelation' — return every event whose @correlation_id@ equals+  the input.++All three reuse the existing partial indexes @ix_events_causation_id@ and+@ix_events_correlation_id@ on the @events@ table, so they do not require+any schema change.+-}+module Kiroku.Store.Causation (+    findCausationDescendants,+    findCausationAncestors,+    findByCorrelation,+) where++import Data.UUID (UUID)+import Data.Vector (Vector)+import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Kiroku.Store.Effect (Store (..))+import Kiroku.Store.Types++{- | Return the seed event and every event whose @causation_id@ chain leads+back to it, in ascending @global_position@ order. The seed event is+included as the depth-0 row when it exists; otherwise the result is+empty.++Uses the @ix_events_causation_id@ partial index. Cost is+@O(depth * log n)@ where @depth@ is the length of the longest chain+rooted at the seed and @n@ is the total event count.+-}+findCausationDescendants ::+    (HasCallStack, Store :> es) =>+    EventId ->+    Eff es (Vector RecordedEvent)+findCausationDescendants eid = send (FindEvents (FilterCausationDescendants eid))++{- | Return the seed event and every ancestor reachable via @causation_id@,+in depth-ascending order (the seed is first, its immediate cause is+second, etc.). The seed event is included as the depth-0 row when it+exists; otherwise the result is empty.+-}+findCausationAncestors ::+    (HasCallStack, Store :> es) =>+    EventId ->+    Eff es (Vector RecordedEvent)+findCausationAncestors eid = send (FindEvents (FilterCausationAncestors eid))++{- | Return every event whose @correlation_id@ equals the input, in+ascending @global_position@ order. Uses the @ix_events_correlation_id@+partial index.+-}+findByCorrelation ::+    (HasCallStack, Store :> es) =>+    UUID ->+    Eff es (Vector RecordedEvent)+findByCorrelation cid = send (FindEvents (FilterCorrelation cid))
+ src/Kiroku/Store/Connection.hs view
@@ -0,0 +1,279 @@+module Kiroku.Store.Connection (+    KirokuStore (..),+    ConnectionSettingsM (..),+    ConnectionSettings,+    defaultConnectionSettings,+    withStore,+) where++import Control.Concurrent.STM (TVar, newTVarIO)+import Control.Exception (bracket, onException)+import Control.Lens ((^.))+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Data.Generics.Labels ()+import Data.Int (Int32)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Data.Unique (Unique)+import GHC.Generics (Generic)+import Hasql.Connection.Settings qualified as Conn+import Hasql.Pool (Pool)+import Hasql.Pool qualified as Pool+import Hasql.Pool.Config qualified as Pool.Config+import Hasql.Pool.Observation (Observation)+import Hasql.Session qualified as Session+import Kiroku.Store.Notification (Notifier)+import Kiroku.Store.Notification qualified as Notifier+import Kiroku.Store.Observability (KirokuEvent)+import Kiroku.Store.Settings (StoreSettings, defaultStoreSettings)+import Kiroku.Store.Subscription.EventPublisher (EventPublisher)+import Kiroku.Store.Subscription.EventPublisher qualified as Publisher+import Kiroku.Store.Subscription.Fsm (SubscriptionState)+import Kiroku.Store.Subscription.Types (SubscriptionName)++-- | Connection settings for the store, parameterized by monad.+data ConnectionSettingsM m = ConnectionSettings+    { connString :: !Text+    {- ^ PostgreSQL connection string (libpq URI or key=value format).+    Reaches libpq verbatim; no application-level parsing or+    substitution. May contain a password.+    -}+    , poolSize :: !Int+    -- ^ Connection pool size (default: 10)+    , schema :: !Text+    {- ^ PostgreSQL schema that owns every Kiroku object+    (default: @"kiroku"@).++    This field is authoritative for two things, kept in lockstep:++    * __Table resolution.__ Every pooled connection runs+      @SET search_path TO \<schema\>, pg_catalog@ before any statement,+      so the unqualified names in "Kiroku.Store.SQL" resolve to this+      schema.+    * __Notification channel.__ The+      'Kiroku.Store.Notification.Notifier' issues+      @LISTEN \<schema\>.events@ on its dedicated connection, matching the+      channel published by the migration-created @notify_events()@+      trigger.++    To run more than one isolated 'KirokuStore' against the same database+    (for example schema-per-tenant), migrate each schema and give each+    store a distinct 'schema'; each gets its own set of Kiroku tables and+    its own notification channel.+    -}+    , extraSearchPath :: ![Text]+    {- ^ Additional schemas appended to every pooled connection's+    @search_path@, after 'schema' and before @pg_catalog@ (default: @[]@).++    The store's own unqualified names always resolve to 'schema' first.+    This is for consumers whose /application/ objects — typically inline+    projections' read-model tables, queried on the same pool as the event+    store — live in another schema (commonly @public@). Without it those+    unqualified application tables are unreachable on the store pool, since+    'schema' replaces the default @search_path@. Entries are quoted as+    identifiers; like 'schema' they are not validated at connection time+    (PostgreSQL does not validate @search_path@ entries).+    -}+    , idleInTransactionTimeout :: !Int+    -- ^ idle_in_transaction_session_timeout in seconds (default: 30)+    , statementTimeout :: !(Maybe Int)+    {- ^ When @Just s@, set @statement_timeout = 's'@ (in seconds) on+    every pooled connection via @initSession@. Bounds the wall-clock+    runtime of any single statement; protects against pathological+    queries holding pool slots indefinitely. Default 'Nothing'+    (PostgreSQL's session default applies — typically @0@,+    meaning no timeout).++    A reasonable starting value for typical workloads is @Just 30@+    (30 seconds) — long enough to absorb GC pauses and transient+    slow disks, short enough to free the pool slot under genuine+    pathology. See @docs\/PRODUCTION-TUNING.md@ for sizing+    guidance.+    -}+    , observationHandler :: !(Maybe (Observation -> m ()))+    -- ^ Optional callback for pool connection lifecycle events+    , eventHandler :: !(Maybe (KirokuEvent -> m ()))+    {- ^ Optional callback for store-emitted operational events. See+    "Kiroku.Store.Observability" for the event taxonomy. Covers+    notifier reconnection, publisher pool errors, subscription+    lifecycle and per-phase database errors, and hard-delete+    issuance — events that 'observationHandler' (which surfaces+    @hasql-pool@'s connection-lifecycle observations) does not+    cover.++    Invoked synchronously from the originating thread (notifier+    loop, publisher loop, worker loop, store interpreter); slow+    callbacks stall those loops. For callbacks that may block, fan+    out asynchronously (e.g., write to a 'TBQueue' and drain in a+    separate thread).+    -}+    , storeSettings :: !StoreSettings+    {- ^ Interpreter-level hooks applied to 'EventData' on the append+    path and to 'RecordedEvent' on the read and subscription paths.+    Defaults to 'defaultStoreSettings' (no-op).++    See "Kiroku.Store.Settings" for the hook semantics and the+    OpenTelemetry trace-context use case that motivates this seam.+    -}+    }+    deriving stock (Generic)++-- | Connection settings defaulting to 'IO'.+type ConnectionSettings = ConnectionSettingsM IO++-- | Default connection settings.+defaultConnectionSettings :: Text -> ConnectionSettings+defaultConnectionSettings cs =+    ConnectionSettings+        { connString = cs+        , poolSize = 10+        , schema = "kiroku"+        , extraSearchPath = []+        , idleInTransactionTimeout = 30+        , statementTimeout = Nothing+        , observationHandler = Nothing+        , eventHandler = Nothing+        , storeSettings = defaultStoreSettings+        }++-- | The store handle. Holds a connection pool, schema name, and subscription infrastructure.+data KirokuStore = KirokuStore+    { pool :: !Pool+    , schema :: !Text+    , notifier :: !Notifier+    , publisher :: !EventPublisher+    , eventHandler :: !(Maybe (KirokuEvent -> IO ()))+    {- ^ Effective event handler captured from+    'ConnectionSettingsM.eventHandler' when 'withStore' acquires+    the store. Surfaces hard-delete events emitted by+    'Kiroku.Store.Effect.runStorePool' and is the channel+    'Kiroku.Store.Subscription.subscribe' threads through to+    'Kiroku.Store.Subscription.Worker.runWorker'.+    -}+    , storeSettings :: !StoreSettings+    {- ^ Interpreter-level hooks captured from+    'ConnectionSettingsM.storeSettings' when 'withStore' acquires+    the store. Reached by 'Kiroku.Store.Effect.runStorePool' and the+    subscription publisher\/worker for every event flowing through.+    -}+    , subscriptionRegistry :: !(TVar (Map (SubscriptionName, Int32) (Unique, TVar SubscriptionState)))+    {- ^ Central registry of every live subscription worker's FSM-state cell,+    keyed by (subscription name, consumer-group member; 0 for non-group).+    Each entry also carries the worker's registry token, so cleanup from an+    older worker cannot delete a newer worker's replacement entry for the same+    key.+    Each 'Kiroku.Store.Subscription.subscribe' call registers its worker's+    'stateVar' here on start and removes it on any exit (stop, cancel, crash)+    via the worker's @finally@ cleanup. The cell is the same 'TVar' the worker+    writes on every transition and 'currentState' reads — it is registered, not+    copied — so the registry observes the live value with no extra write path.+    A subscription is represented in the snapshot by /presence/ while live and+    by /absence/ once it has stopped, been cancelled, or crashed; the FSM never+    writes 'Kiroku.Store.Subscription.Fsm.Stopped' into the cell, so a not-live+    subscription is never represented by a @"stopped"@ phase.+    Read a consistent snapshot with+    'Kiroku.Store.Subscription.subscriptionStates'.+    -}+    }+    deriving stock (Generic)++{- | Bracket-style store lifecycle.++Acquire phase, in order:++1. Acquire the connection pool from @hasql-pool@ with the configured+   size and the @idle_in_transaction_session_timeout@ init session.+2. Start the 'Kiroku.Store.Notification.Notifier' on a dedicated+   connection: @LISTEN \<schema\>.events@.+3. Start the 'Kiroku.Store.Subscription.EventPublisher' which consumes+   notifier ticks and broadcasts new events to subscribers.++Release phase, in reverse order:++1. Cancel the 'Kiroku.Store.Subscription.EventPublisher' worker.+2. Stop the 'Kiroku.Store.Notification.Notifier' (cancel listener,+   release connection).+3. Release the pool.++The @bracket@ semantics guarantee release runs on either normal exit+or an exception in the body. The 'MonadUnliftIO' constraint matches+'Control.Exception.bracket'; consumers in pure 'IO' get an exact match,+consumers in effectful monads with an unlift in scope (e.g., a+'ReaderT'-like stack) get the same guarantee transparently.+-}+withStore :: (MonadUnliftIO m) => ConnectionSettings -> (KirokuStore -> m a) -> m a+withStore settings action = withRunInIO $ \runInIO ->+    bracket acquire release (runInIO . action)+  where+    initScript :: Text+    initScript =+        T.intercalate "; " $+            -- Resolve unqualified Kiroku table names (see "Kiroku.Store.SQL")+            -- to the configured schema on every pooled connection, followed by+            -- any 'extraSearchPath' schemas (for application objects such as+            -- inline-projection read-model tables queried on the same pool).+            -- Setting a not-yet-created schema is harmless: PostgreSQL does not+            -- validate search_path entries. Runtime queries still require+            -- migrations to have created the schemas before the store is opened.+            ( "SET search_path TO "+                <> T.intercalate+                    ", "+                    (quoteIdentifier (settings ^. #schema) : map quoteIdentifier (settings ^. #extraSearchPath))+                <> ", pg_catalog"+            )+                : ("SET idle_in_transaction_session_timeout = '" <> T.pack (show (settings ^. #idleInTransactionTimeout)) <> "s'")+                : maybe+                    []+                    (\t -> ["SET statement_timeout = '" <> T.pack (show t) <> "s'"])+                    (settings ^. #statementTimeout)++    poolConfig :: Pool.Config.Config+    poolConfig =+        Pool.Config.settings $+            [ Pool.Config.staticConnectionSettings (Conn.connectionString (settings ^. #connString))+            , Pool.Config.size (settings ^. #poolSize)+            , Pool.Config.initSession (Session.script initScript)+            ]+                ++ maybe [] (\h -> [Pool.Config.observationHandler h]) (settings ^. #observationHandler)++    acquire = do+        p <- Pool.acquire poolConfig+        flip onException (Pool.release p) $ do+            let s = settings ^. #schema+                cs = settings ^. #connString+                evtHandler = settings ^. #eventHandler+                stSettings = settings ^. #storeSettings+            -- Start Notifier (dedicated LISTEN connection)+            n <- Notifier.startNotifier cs s evtHandler+            flip onException (Notifier.stopNotifier n) $ do+                -- Start EventPublisher (depends on Notifier's TChan)+                pub <- Publisher.startPublisher p (Notifier.tickChan n) evtHandler stSettings+                -- Central, in-memory subscription-state registry: starts empty+                -- and is populated/cleaned by each `subscribe` call's worker+                -- lifecycle. Purely in-memory; discarded when the store closes.+                reg <- newTVarIO Map.empty+                pure+                    KirokuStore+                        { pool = p+                        , schema = s+                        , notifier = n+                        , publisher = pub+                        , eventHandler = evtHandler+                        , storeSettings = stSettings+                        , subscriptionRegistry = reg+                        }++    release store = do+        -- Stop in reverse order: Publisher first, then Notifier, then pool+        Publisher.stopPublisher (store ^. #publisher)+        Notifier.stopNotifier (store ^. #notifier)+        Pool.release (store ^. #pool)++{- | Quote a 'Text' as a PostgreSQL identifier: wrap it in double quotes and+double any embedded double quote. Used to set the configured schema in+@search_path@ without risking SQL injection from a hostile schema setting.+-}+quoteIdentifier :: Text -> Text+quoteIdentifier ident = "\"" <> T.replace "\"" "\"\"" ident <> "\""
+ src/Kiroku/Store/Effect.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE TypeFamilies #-}++module Kiroku.Store.Effect (+    -- * The Store effect+    Store (..),++    -- * Interpreters+    runStorePool,+    runStoreResource,+    runStoreIO,++    -- * Internal building blocks++    --+    -- $internal+    PreparedEvent,+    prepareEvents,+    buildAppendParams,+    appendDispatchTx,+) where++import Control.Lens ((^.))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (Value)+import Data.Foldable (for_)+import Data.Generics.Labels ()+import Data.Int (Int32, Int64)+import Data.List (find)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (isNothing)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.UUID (UUID)+import Data.UUID.V7 qualified as V7+import Data.Vector (Vector)+import Data.Vector qualified as V+import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, runEff, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, runErrorNoCallStack, throwError)+import GHC.Generics (Generic)+import Hasql.Pool (Pool)+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Transaction qualified as Tx+import Hasql.Transaction.Sessions qualified as TxSessions+import Kiroku.Store.Connection (KirokuStore (..))+import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore)+import Kiroku.Store.Error (StoreError (..), attributeMultiStreamError, emptyResultError, mapUsageError)+import Kiroku.Store.Observability (KirokuEvent (..))+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Settings (decodeEvents, enrichEvents)+import Kiroku.Store.Types++-- ---------------------------------------------------------------------------+-- Store effect+-- ---------------------------------------------------------------------------++-- | The Store effect — dynamically dispatched, mockable.+data Store :: Effect where+    AppendToStream :: StreamName -> ExpectedVersion -> [EventData] -> Store m AppendResult+    ReadStreamForward :: StreamName -> StreamVersion -> Int32 -> Store m (Vector RecordedEvent)+    ReadStreamBackward :: StreamName -> StreamVersion -> Int32 -> Store m (Vector RecordedEvent)+    ReadAllForward :: GlobalPosition -> Int32 -> Store m (Vector RecordedEvent)+    ReadAllBackward :: GlobalPosition -> Int32 -> Store m (Vector RecordedEvent)+    GetStream :: StreamName -> Store m (Maybe StreamInfo)+    {- | Resolve a 'StreamName' to its surrogate 'StreamId' without+    materializing the full 'StreamInfo' row. Mirrors 'GetStream'\'s+    soft-delete semantics: returns 'Just' for both live and soft-deleted+    streams, 'Nothing' for hard-deleted or never-created streams.++    Cheaper than 'GetStream' — decodes one @int8@ column instead of five.+    Surfaced as 'Kiroku.Store.Read.lookupStreamId'.+    -}+    LookupStreamId :: StreamName -> Store m (Maybe StreamId)+    {- | Resolve a batch of surrogate 'StreamId's to their 'StreamName's in a+    single round trip. The result 'Map' contains an entry only for ids that+    name an existing stream (live or soft-deleted); hard-deleted or unknown ids+    are absent.++    The primary use is recovering source stream names from the+    'RecordedEvent.originalStreamId' of events obtained via fan-in reads+    (@$all@, categories, causation/correlation queries, subscriptions): collect+    the distinct ids from a batch and resolve them once, rather than per event.+    Surfaced as 'Kiroku.Store.Read.lookupStreamNames' (and the singular+    'Kiroku.Store.Read.lookupStreamName').+    -}+    LookupStreamNames :: [StreamId] -> Store m (Map StreamId StreamName)+    LinkToStream :: StreamName -> [EventId] -> Store m LinkResult+    ReadCategoryForward :: CategoryName -> GlobalPosition -> Int32 -> Store m (Vector RecordedEvent)+    AppendMultiStream :: [(StreamName, ExpectedVersion, [EventData])] -> Store m [AppendResult]+    {- | Fetch a set of 'RecordedEvent' rows that match an 'EventFilter'.+    Surfaced to consumers as the smart constructors in+    "Kiroku.Store.Causation": 'Kiroku.Store.Causation.findByCorrelation',+    'Kiroku.Store.Causation.findCausationDescendants', and+    'Kiroku.Store.Causation.findCausationAncestors'.++    The filter is a closed sum ('EventFilter'); mock interpreters can+    pattern-match exhaustively.+    -}+    FindEvents :: EventFilter -> Store m (Vector RecordedEvent)+    SoftDeleteStream :: StreamName -> Store m (Maybe StreamId)+    HardDeleteStream :: StreamName -> Store m (Maybe StreamId)+    UndeleteStream :: StreamName -> Store m (Maybe StreamId)+    {- | Run an arbitrary @hasql-transaction@ value in a 'BEGIN'/'COMMIT'+    block on a single pool connection. Escape hatch from the abstract+    'Store' effect into the underlying SQL world; mock interpreters are+    expected to reject this constructor.+    -}+    RunTransaction :: Tx.Transaction a -> Store m a+    {- | Like 'RunTransaction' but uses+    'Hasql.Transaction.Sessions.transactionNoRetry' under the hood —+    the body is run exactly once even on PostgreSQL serialization+    conflicts.+    -}+    RunTransactionNoRetry :: Tx.Transaction a -> Store m a++type instance DispatchOf Store = Dynamic++-- ---------------------------------------------------------------------------+-- PostgreSQL interpreter+-- ---------------------------------------------------------------------------++-- | Interpret Store operations against PostgreSQL via hasql-pool.+runStorePool ::+    (IOE :> es, Error StoreError :> es) =>+    KirokuStore ->+    Eff (Store : es) a ->+    Eff es a+runStorePool store = interpret_ $ \case+    AppendToStream (StreamName name) expected events -> do+        rejectReservedApplicationStream name+        events' <- liftIO $ enrichEvents (store ^. #storeSettings) events+        now <- liftIO getCurrentTime+        prepared <- prepareEvents events'+        let params = buildAppendParams name now prepared+        result <- liftIO $ Pool.use (store ^. #pool) $ case expected of+            ExactVersion (StreamVersion v) ->+                Session.statement (params, v) SQL.appendExpectedVersion+            StreamExists ->+                Session.statement params SQL.appendStreamExists+            NoStream ->+                Session.statement params SQL.appendNoStream+            AnyVersion ->+                Session.statement params SQL.appendAnyVersion+        case result of+            Left usageErr ->+                throwError (mapUsageError name expected usageErr)+            Right Nothing ->+                throwError (emptyResultError name expected)+            Right (Just r) ->+                pure r+    ReadStreamForward (StreamName name) (StreamVersion startVer) limit -> do+        evs <-+            usePool (store ^. #pool) $+                Session.statement (name, startVer, limit) SQL.readStreamForwardStmt+        liftIO $ decodeEvents (store ^. #storeSettings) evs+    ReadStreamBackward (StreamName name) (StreamVersion startVer) limit -> do+        evs <-+            usePool (store ^. #pool) $+                Session.statement (name, startVer, limit) SQL.readStreamBackwardStmt+        liftIO $ decodeEvents (store ^. #storeSettings) evs+    ReadAllForward (GlobalPosition startPos) limit -> do+        evs <-+            usePool (store ^. #pool) $+                Session.statement (startPos, limit) SQL.readAllForwardStmt+        liftIO $ decodeEvents (store ^. #storeSettings) evs+    ReadAllBackward (GlobalPosition startPos) limit -> do+        evs <-+            usePool (store ^. #pool) $+                Session.statement (startPos, limit) SQL.readAllBackwardStmt+        liftIO $ decodeEvents (store ^. #storeSettings) evs+    GetStream (StreamName name) ->+        usePool (store ^. #pool) $+            Session.statement name SQL.getStreamStmt+    LookupStreamId (StreamName name) ->+        fmap (fmap StreamId) $+            usePool (store ^. #pool) $+                Session.statement name SQL.findStreamIdStmt+    LookupStreamNames sids ->+        fmap+            (Map.fromList . map (\(s, nm) -> (StreamId s, StreamName nm)) . V.toList)+            ( usePool (store ^. #pool) $+                Session.statement [s | StreamId s <- sids] SQL.lookupStreamNamesStmt+            )+    LinkToStream (StreamName name) eventIds -> do+        rejectReservedApplicationStream name+        let uuids = V.fromList [uid | EventId uid <- eventIds]+        result <-+            usePool (store ^. #pool) $+                Session.statement (uuids, name) SQL.linkToStreamStmt+        case result of+            Nothing -> throwError (StreamNotFound (StreamName name))+            Just r -> pure r+    ReadCategoryForward (CategoryName cat) (GlobalPosition startPos) limit -> do+        evs <-+            usePool (store ^. #pool) $+                Session.statement (startPos, cat, limit) SQL.readCategoryForwardStmt+        liftIO $ decodeEvents (store ^. #storeSettings) evs+    AppendMultiStream ops -> do+        case find (\(StreamName name, _, _) -> isReservedApplicationStream name) ops of+            Just (sn, _, _) -> throwError (ReservedStreamName sn)+            Nothing -> pure ()+        now <- liftIO getCurrentTime+        -- Prepare all events for all streams+        preparedOps <-+            mapM+                ( \(sn, ev, evts) -> do+                    evts' <- liftIO $ enrichEvents (store ^. #storeSettings) evts+                    prepared <- prepareEvents evts'+                    pure (sn, ev, prepared)+                )+                ops+        let names = V.fromList [n | (StreamName n, _, _) <- ops]+        let txn = do+                -- Pre-lock the user-named streams in deterministic (stream_id)+                -- order to avoid row-lock deadlocks between concurrent+                -- multi-stream txns touching overlapping streams in different+                -- user orders. See EP-1 F4.+                Tx.statement names SQL.lockStreamsForMultiStmt+                results <-+                    mapM+                        ( \(StreamName name, expected, prepared) -> do+                            let params = buildAppendParams name now prepared+                            appendDispatchTx expected params+                        )+                        preparedOps+                -- If any result is Nothing (version conflict), condemn the transaction+                case any isNothing results of+                    True -> Tx.condemn >> pure results+                    False -> pure results+        result <-+            liftIO $+                Pool.use (store ^. #pool) $+                    TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write txn+        case result of+            Left usageErr ->+                throwError (attributeMultiStreamError [(sn, ev) | (sn, ev, _) <- ops] usageErr)+            Right results -> do+                -- Check for any Nothing results (version conflicts)+                let indexed = zip ops results+                mapM+                    ( \((StreamName sn, ev, _), mResult) ->+                        case mResult of+                            Nothing -> throwError (emptyResultError sn ev)+                            Just r -> pure r+                    )+                    indexed+    FindEvents filt -> do+        evs <- case filt of+            FilterCorrelation cid ->+                usePool (store ^. #pool) $+                    Session.statement cid SQL.findByCorrelationStmt+            FilterCausationDescendants (EventId eid) ->+                usePool (store ^. #pool) $+                    Session.statement eid SQL.findCausationDescendantsStmt+            FilterCausationAncestors (EventId eid) ->+                usePool (store ^. #pool) $+                    Session.statement eid SQL.findCausationAncestorsStmt+        liftIO $ decodeEvents (store ^. #storeSettings) evs+    SoftDeleteStream (StreamName name) -> do+        rejectReservedApplicationStream name+        usePool (store ^. #pool) $+            Session.statement name SQL.softDeleteStreamStmt+    HardDeleteStream (StreamName name) -> do+        rejectReservedApplicationStream name+        let txn = do+                Tx.sql "SET LOCAL kiroku.enable_hard_deletes = 'on'"+                mSid <- Tx.statement name SQL.findStreamIdStmt+                case mSid of+                    Nothing -> pure Nothing+                    Just sid -> do+                        affected <- Tx.statement sid SQL.deleteStreamJunctionsStmt+                        Tx.statement affected SQL.deleteOrphanedEventsStmt+                        Tx.statement sid SQL.deleteStreamRowStmt+                        pure (Just (StreamId sid))+        result <-+            usePool (store ^. #pool) $+                TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write txn+        -- Emit a fail-safe audit signal when the delete actually removed+        -- rows. Compliance-grade audit should still record an+        -- application-level event before calling hardDeleteStream — see+        -- docs/PRODUCTION-DEPLOYMENT.md.+        case result of+            Just sid -> liftIO $ for_ (store ^. #eventHandler) ($ KirokuEventHardDeleteIssued (StreamName name) sid)+            Nothing -> pure ()+        pure result+    UndeleteStream (StreamName name) -> do+        rejectReservedApplicationStream name+        usePool (store ^. #pool) $+            Session.statement name SQL.undeleteStreamStmt+    RunTransaction tx ->+        runTxOnPool (store ^. #pool) TxSessions.transaction tx+    RunTransactionNoRetry tx ->+        runTxOnPool (store ^. #pool) TxSessions.transactionNoRetry tx++-- | Convenience: run a Store computation to IO.+runStoreIO ::+    KirokuStore ->+    Eff '[Store, Error StoreError, IOE] a ->+    IO (Either StoreError a)+runStoreIO store = runEff . runErrorNoCallStack . runStorePool store++-- | Interpret Store by reading the store handle from 'KirokuStoreResource'.+runStoreResource ::+    (IOE :> es, Error StoreError :> es, KirokuStoreResource :> es) =>+    Eff (Store : es) a ->+    Eff es a+runStoreResource action = do+    store <- getKirokuStore+    runStorePool store action++-- ---------------------------------------------------------------------------+-- Internal pool helper+-- ---------------------------------------------------------------------------++-- | Run a hasql session against the pool, mapping pool errors to 'StoreError'.+usePool ::+    (IOE :> es, Error StoreError :> es) =>+    Pool ->+    Session.Session a ->+    Eff es a+usePool pool session = do+    result <- liftIO (Pool.use pool session)+    case result of+        Left usageErr -> throwError (ConnectionError (T.pack (show usageErr)))+        Right a -> pure a++{- | Run a 'Tx.Transaction' against the pool using the supplied entry+point ('TxSessions.transaction' or 'TxSessions.transactionNoRetry'),+mapping pool errors to 'StoreError'. The isolation level and access+mode mirror 'appendMultiStream' / 'HardDeleteStream'.+-}+runTxOnPool ::+    (IOE :> es, Error StoreError :> es) =>+    Pool ->+    (TxSessions.IsolationLevel -> TxSessions.Mode -> Tx.Transaction a -> Session.Session a) ->+    Tx.Transaction a ->+    Eff es a+runTxOnPool pool entry tx = do+    result <-+        liftIO $+            Pool.use pool $+                entry TxSessions.ReadCommitted TxSessions.Write tx+    case result of+        Left usageErr -> throwError (ConnectionError (T.pack (show usageErr)))+        Right a -> pure a++-- | The seeded $all row is the global read stream, not an application stream.+isReservedApplicationStream :: Text -> Bool+isReservedApplicationStream = (== "$all")++rejectReservedApplicationStream ::+    (Error StoreError :> es) =>+    Text ->+    Eff es ()+rejectReservedApplicationStream name+    | isReservedApplicationStream name = throwError (ReservedStreamName (StreamName name))+    | otherwise = pure ()++-- ---------------------------------------------------------------------------+-- Internal helpers (moved from Append)+-- ---------------------------------------------------------------------------++-- | An event with a guaranteed event ID (pre-generated if needed).+data PreparedEvent = PreparedEvent+    { peEventId :: !UUID+    , peEventType :: !EventType+    , pePayload :: !Value+    , peMetadata :: !(Maybe Value)+    , peCausationId :: !(Maybe UUID)+    , peCorrelationId :: !(Maybe UUID)+    }+    deriving stock (Generic)++{- | Prepare events by generating UUIDv7s for any event that doesn't+have a caller-supplied event ID.+-}+prepareEvents :: (MonadIO m) => [EventData] -> m [PreparedEvent]+prepareEvents evts = liftIO $ do+    let needCount = length (filter (\(EventData eid _ _ _ _ _) -> isNothing eid) evts)+    newIds <-+        if needCount > 0+            then V7.genUUIDs (fromIntegral needCount)+            else pure []+    pure (assign evts newIds)+  where+    assign :: [EventData] -> [UUID] -> [PreparedEvent]+    assign [] _ = []+    assign (EventData mEid eType ePayload eMeta eCaus eCorr : es) ids =+        case mEid of+            Just (EventId uid) ->+                PreparedEvent uid eType ePayload eMeta eCaus eCorr+                    : assign es ids+            Nothing -> case ids of+                (uid : rest) ->+                    PreparedEvent uid eType ePayload eMeta eCaus eCorr+                        : assign es rest+                [] -> error "prepareEvents: ran out of pre-generated UUIDs (bug)"++-- | Build SQL parameters from prepared events.+buildAppendParams :: Text -> UTCTime -> [PreparedEvent] -> SQL.AppendParams+buildAppendParams name now prepared =+    SQL.AppendParams+        { eventIds = V.fromList (map (^. #peEventId) prepared)+        , eventTypes = V.fromList (map (\e -> let EventType t = e ^. #peEventType in t) prepared)+        , causationIds = V.fromList (map (^. #peCausationId) prepared)+        , correlationIds = V.fromList (map (^. #peCorrelationId) prepared)+        , payloads = V.fromList (map (^. #pePayload) prepared)+        , metadatas = V.fromList (map (^. #peMetadata) prepared)+        , createdAts = V.fromList (replicate (length prepared) now)+        , streamName = name+        }++{- | Dispatch the four 'SQL.append*' statements through 'Tx.statement',+selecting the right one based on the supplied 'ExpectedVersion'.++This is the shared building block used by 'AppendMultiStream'\'s+interpreter branch and by 'Kiroku.Store.Transaction.appendToStreamTx'.+'AppendToStream' keeps its 'Session.statement'-flavored dispatch — see+the M2 entry in the Decision Log on plan 11 for why a 'Tx.Transaction'+wrapping a single statement was rejected as a refactoring target.++@'Nothing'@ comes back when the underlying CTE returns 0 rows — i.e.+the precondition failed silently. Callers map that to either+'Kiroku.Store.Error.AppendConflict' (the Tx surface) or+'Kiroku.Store.Error.StoreError' (the @Eff@ surface).+-}+appendDispatchTx :: ExpectedVersion -> SQL.AppendParams -> Tx.Transaction (Maybe AppendResult)+appendDispatchTx expected params = case expected of+    ExactVersion (StreamVersion v) ->+        Tx.statement (params, v) SQL.appendExpectedVersion+    StreamExists ->+        Tx.statement params SQL.appendStreamExists+    NoStream ->+        Tx.statement params SQL.appendNoStream+    AnyVersion ->+        Tx.statement params SQL.appendAnyVersion++{- $internal+These bindings are intentionally exposed so that+"Kiroku.Store.Transaction" can compose appends with arbitrary+'Tx.Transaction' work without re-implementing UUID prep, parameter+packing, or per-version dispatch. They are not part of the supported+public surface and may change without notice.+-}
+ src/Kiroku/Store/Effect/Resource.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TypeFamilies #-}++module Kiroku.Store.Effect.Resource (+    -- * The KirokuStoreResource effect+    KirokuStoreResource,++    -- * Operations+    getKirokuStore,++    -- * Bracket-style runner+    withKirokuStore,+) where++import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, UnliftStrategy (..), withEffToIO, (:>))+import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, getStaticRep)+import Kiroku.Store.Connection (ConnectionSettings, KirokuStore, withStore)++-- ---------------------------------------------------------------------------+-- KirokuStoreResource static effect+-- ---------------------------------------------------------------------------++{- | Static effect carrying a 'KirokuStore' handle.++Static rather than dynamic because the store handle is acquired exactly+once per program and is not meant to be mocked — the dynamic mocking+surface lives on the 'Kiroku.Store.Effect.Store' effect that operates+against the handle. Splitting the resource (static) from the operations+(dynamic) keeps mocking ergonomic without requiring callers to swap the+handle itself.++@Static WithSideEffects@ rather than @Static NoSideEffects@ because the+underlying connection pool performs IO during operation lookup.+-}+data KirokuStoreResource :: Effect++type instance DispatchOf KirokuStoreResource = Static WithSideEffects++newtype instance StaticRep KirokuStoreResource = KirokuStoreResource KirokuStore++-- | Retrieve the 'KirokuStore' handle from the effect stack.+getKirokuStore :: (KirokuStoreResource :> es) => Eff es KirokuStore+getKirokuStore = do+    KirokuStoreResource store <- getStaticRep+    pure store++-- | Bracket-style runner: acquire the store, install the effect, run the action, release.+withKirokuStore ::+    (IOE :> es) =>+    ConnectionSettings ->+    Eff (KirokuStoreResource : es) a ->+    Eff es a+withKirokuStore settings action = withEffToIO SeqUnlift $ \unlift ->+    withStore settings $ \store ->+        unlift (evalStaticRep (KirokuStoreResource store) action)
+ src/Kiroku/Store/Error.hs view
@@ -0,0 +1,347 @@+module Kiroku.Store.Error (+    StoreError (..),++    -- * Append-precondition conflicts (Tx-flavored)+    AppendConflict (..),+    appendConflictToStoreError,+    emptyResultConflict,+    -- Internal helpers used by Effect module+    mapUsageError,+    emptyResultError,+    attributeMultiStreamError,+    -- Internal pure helper exposed for unit testing+    extractStreamNameFromDetail,+) where++import Control.Exception (Exception)+import Data.Text (Text)+import Data.Text qualified as T+import Data.UUID (UUID)+import Data.UUID qualified as UUID+import GHC.Generics (Generic)+import Hasql.Errors qualified as Errors+import Hasql.Pool (UsageError (..))+import Kiroku.Store.Types++{- | Errors that can occur during store operations.++The constructor set is designed for additive evolution: new failure modes+are added rather than changing existing constructors. Pattern matches that+do not handle a new constructor will surface as @-Wincomplete-patterns@+warnings, never as silent misclassification.++The 'ConnectionError' catch-all is retained for backward compatibility:+anything not matched by a more specific constructor falls through to it.+Consumers should match on the specific constructors first when they want+to make retry-vs-escalate decisions.++'StoreError' derives 'Exception' so it can be thrown with 'throwIO' from+any 'IO' or 'MonadIO' context. The standard pattern for store callers+remains @runStoreIO :: IO (Either StoreError a)@; the 'Exception' instance+is for callers who prefer the exception-based idiom (e.g., when bridging+to libraries that expect 'SomeException').+-}+data StoreError+    = {- | The actual stream version did not match the caller's+      'ExactVersion' expectation. The third field is the actual+      version (or 'StreamVersion' 0 when the version could not be+      recovered, e.g., the row was concurrently soft-deleted).+      -}+      WrongExpectedVersion !StreamName !ExpectedVersion !StreamVersion+    | -- | The named stream does not exist (or has been soft-deleted).+      StreamNotFound !StreamName+    | {- | The named stream is reserved for store internals and cannot be+      used as an application stream target. For now this applies only+      to @$all@, which is the global read stream backed by the seeded+      @streams.stream_id = 0@ row.+      -}+      ReservedStreamName !StreamName+    | {- | The named stream already exists. Returned for 'NoStream'+      expectations against an existing stream and for 'linkToStream'+      targets that already exist with conflicting state.+      -}+      StreamAlreadyExists !StreamName+    | {- | A caller-supplied @event_id@ collides with an existing event.++      The constructor carries 'Just' the id when the PostgreSQL detail+      string could be parsed, 'Nothing' otherwise. A 'Nothing' payload+      is rare in practice; it occurs when the server's locale changes+      the detail-string format. Consumers that want to surface the+      offending id to the user should match on 'Just'.+      -}+      DuplicateEvent !(Maybe EventId)+    | {- | The connection pool timed out acquiring a connection. Almost+      always retryable after a small backoff; sustained timeouts+      indicate that the pool is undersized for the offered load or+      that the database is unreachable.+      -}+      PoolAcquisitionTimeout+    | {- | A network or session-level error tore down the connection+      mid-operation. The 'Text' carries the underlying hasql error+      description for diagnostics. Retryable in most cases.+      -}+      ConnectionLost !Text+    | {- | PostgreSQL raised a server error whose @SQLSTATE@ code is+      outside the set this store recognises (currently @23505@+      unique violation and @23503@ foreign key violation). The first+      'Text' is the @SQLSTATE@ code, the second is the human-readable+      message. This is *not* generally retryable — investigate.+      -}+      UnexpectedServerError !Text !Text+    | {- | Catch-all for everything not matched by a more specific+      constructor above. Retained for backward compatibility with+      consumers that already pattern-match on it; new code should+      prefer the specific constructors.+      -}+      ConnectionError !Text+    deriving stock (Eq, Show, Generic)+    deriving anyclass (Exception)++{- | Map a hasql 'UsageError' to a 'StoreError'.++Pattern matches on the error hierarchy:+  UsageError -> SessionUsageError -> StatementSessionError -> ServerStatementError -> ServerError++PostgreSQL error code mapping:+  23505 (unique_violation) + events_pkey            -> 'DuplicateEvent'+  23505 (unique_violation) + ix_streams_stream_name -> 'StreamAlreadyExists'+  23505 (unique_violation) + other                  -> 'WrongExpectedVersion'+  23503 (foreign_key_violation)                     -> 'StreamNotFound'+  any other server code                             -> 'UnexpectedServerError'++The constraint-name matching depends on the literal strings @events_pkey@+and @ix_streams_stream_name@. If a future schema migration renames a+constraint, the @23505@ branch falls through to the generic+'WrongExpectedVersion' mapping; keep the names stable in+@kiroku-store-migrations/sql-migrations@.+-}+mapUsageError :: Text -> ExpectedVersion -> UsageError -> StoreError+mapUsageError streamName expected = \case+    SessionUsageError sessionErr ->+        mapSessionError streamName expected sessionErr+    ConnectionUsageError connErr ->+        ConnectionLost (T.pack (show connErr))+    AcquisitionTimeoutUsageError ->+        PoolAcquisitionTimeout++mapSessionError :: Text -> ExpectedVersion -> Errors.SessionError -> StoreError+mapSessionError streamName expected = \case+    Errors.StatementSessionError _ _ _ _ _ stmtErr ->+        mapStatementError streamName expected stmtErr+    other ->+        ConnectionError ("Session error: " <> T.pack (show other))++mapStatementError :: Text -> ExpectedVersion -> Errors.StatementError -> StoreError+mapStatementError streamName expected = \case+    Errors.ServerStatementError serverErr ->+        mapServerError streamName expected serverErr+    other ->+        ConnectionError ("Statement error: " <> T.pack (show other))++mapServerError :: Text -> ExpectedVersion -> Errors.ServerError -> StoreError+mapServerError streamName expected (Errors.ServerError code message detail _hint _position)+    | code == "23505" = mapUniqueViolation streamName expected message detail+    | code == "23503" = StreamNotFound (StreamName streamName)+    | otherwise = UnexpectedServerError code message++{- | Map a unique_violation (23505) to an StoreError.++PostgreSQL reports constraint violations with:+  - message: "duplicate key value violates unique constraint \"events_pkey\""+  - detail: "Key (event_id)=(uuid-value) already exists."++We check both message and detail for the constraint name.++When the events_pkey case fires but the detail string cannot be parsed+(e.g., the server's locale produced an unexpected format), the+'DuplicateEvent' constructor carries 'Nothing' rather than a fabricated+all-zeroes UUID — see 'extractEventId'.+-}+mapUniqueViolation :: Text -> ExpectedVersion -> Text -> Maybe Text -> StoreError+mapUniqueViolation streamName expected message detail+    | containsConstraint "events_pkey" = DuplicateEvent (extractEventId detail)+    | containsConstraint "ix_streams_stream_name" = StreamAlreadyExists (StreamName streamName)+    | otherwise =+        -- Generic unique violation — treat as version conflict+        WrongExpectedVersion (StreamName streamName) expected (StreamVersion 0)+  where+    containsConstraint name =+        name `T.isInfixOf` message || maybe False (T.isInfixOf name) detail++    -- Try to extract event_id from detail like "Key (event_id)=(uuid) already exists."+    extractEventId (Just d) = EventId <$> extractUuidFromDetail d+    extractEventId Nothing = Nothing++{- | Append-precondition failures observable inside a+'Hasql.Transaction.Transaction' body.++'Kiroku.Store.Transaction.appendToStreamTx' returns+@'Either' 'AppendConflict' 'AppendResult'@ rather than throwing, because+'Hasql.Transaction.Transaction' has no exception channel — the caller+decides whether to call 'Hasql.Transaction.condemn', branch around the+conflict, or recover. Reserved-stream rejection is /not/ part of this+sum because callers of 'Kiroku.Store.Transaction.appendToStreamTx' are+expected to validate the stream name themselves before entering the+transaction body (the high-level wrapper+'Kiroku.Store.Transaction.runTransactionAppending' does so prior to+opening the transaction and surfaces 'ReservedStreamName' as a+'StoreError' instead).++The constructors are 1:1 with the corresponding 'StoreError' variants —+see 'appendConflictToStoreError'.+-}+data AppendConflict+    = {- | Mirror of 'WrongExpectedVersion'. The third field is the+      actual stream version, or @StreamVersion 0@ when it could not+      be recovered (e.g., the CTE returned no rows because the+      target was concurrently soft-deleted).+      -}+      WrongExpectedVersionConflict !StreamName !ExpectedVersion !StreamVersion+    | -- | Mirror of 'StreamNotFound'.+      StreamNotFoundConflict !StreamName+    | -- | Mirror of 'StreamAlreadyExists'.+      StreamAlreadyExistsConflict !StreamName+    deriving stock (Eq, Show, Generic)++{- | Project an 'AppendConflict' onto the corresponding 'StoreError'+constructor. Used by 'Kiroku.Store.Transaction.runTransactionAppending'+when surfacing conflicts at the @Eff@ boundary.+-}+appendConflictToStoreError :: AppendConflict -> StoreError+appendConflictToStoreError = \case+    WrongExpectedVersionConflict sn ev sv -> WrongExpectedVersion sn ev sv+    StreamNotFoundConflict sn -> StreamNotFound sn+    StreamAlreadyExistsConflict sn -> StreamAlreadyExists sn++{- | Infer the appropriate 'AppendConflict' from an empty CTE result.++Mirror of 'emptyResultError' for the 'AppendConflict' surface. When the+CTE returns 0 rows, the version check or existence check failed+silently — the constructor depends on the supplied 'ExpectedVersion':++  ExactVersion v -> WrongExpectedVersionConflict (version mismatch or+                    soft-deleted)+  StreamExists   -> StreamNotFoundConflict (missing or soft-deleted)+  NoStream       -> StreamAlreadyExistsConflict+  AnyVersion     -> StreamNotFoundConflict (only happens when the+                    existing row is soft-deleted and the upsert's DO+                    UPDATE WHERE filter rejects it)+-}+emptyResultConflict :: StreamName -> ExpectedVersion -> AppendConflict+emptyResultConflict sn = \case+    ExactVersion v ->+        WrongExpectedVersionConflict sn (ExactVersion v) (StreamVersion 0)+    StreamExists ->+        StreamNotFoundConflict sn+    NoStream ->+        StreamAlreadyExistsConflict sn+    AnyVersion ->+        StreamNotFoundConflict sn++{- | Infer the appropriate error from an empty CTE result.++When the CTE returns 0 rows (no ServerError raised), the version check+or existence check failed silently. Map based on the ExpectedVersion:+  ExactVersion v -> WrongExpectedVersion (version mismatch, or soft-deleted)+  StreamExists   -> StreamNotFound (stream doesn't exist, or soft-deleted)+  NoStream       -> StreamAlreadyExists (stream already exists)+  AnyVersion     -> StreamNotFound (only happens when the existing row is+                    soft-deleted and the upsert's DO UPDATE WHERE filter+                    rejects it; the soft-delete CTE filter was added in+                    EP-1 F2, so this branch is the soft-deleted-stream case)+-}+emptyResultError :: Text -> ExpectedVersion -> StoreError+emptyResultError streamName expected =+    appendConflictToStoreError+        (emptyResultConflict (StreamName streamName) expected)++{- | Extract a UUID from a PostgreSQL detail string like:+"Key (event_id)=(01234567-89ab-7def-8012-34567890abcd) already exists."+-}+extractUuidFromDetail :: Text -> Maybe UUID+extractUuidFromDetail detail =+    case T.breakOn "=(" detail of+        (_, rest)+            | not (T.null rest) ->+                let afterParen = T.drop 2 rest -- skip "=("+                    uuidText = T.takeWhile (/= ')') afterParen+                 in UUID.fromText uuidText+        _ -> Nothing++{- | Extract a stream name from a PostgreSQL unique-violation detail string+like @"Key (stream_name)=(orders-1) already exists."@.++Returns @Nothing@ when the format is unrecognized — most commonly because+the server emitted a non-English locale variant or because a future schema+change altered the constraint's column. Callers should use a sensible+fallback (e.g., the first stream in a multi-stream operation) rather than+treat 'Nothing' as a fatal condition.+-}+extractStreamNameFromDetail :: Text -> Maybe Text+extractStreamNameFromDetail detail =+    case T.breakOn "=(" detail of+        (_, rest)+            | not (T.null rest) ->+                let afterParen = T.drop 2 rest -- skip "=("+                    inner = T.takeWhile (/= ')') afterParen+                 in if T.null inner then Nothing else Just inner+        _ -> Nothing++{- | For 'appendMultiStream' errors, recover the offending stream from the+PostgreSQL detail string when possible.++The multi-stream interpreter's transaction returns a single+@Either UsageError result@; per-statement attribution is not visible at the+@hasql@ layer. When the failure is a @23505@ unique violation on+@ix_streams_stream_name@, the PostgreSQL detail string carries the+offending stream name (e.g., @"Key (stream_name)=(multi-c) already exists."@)+and we look up the matching op to recover its 'ExpectedVersion'.++When the detail cannot be parsed (any other failure mode, including+@events_pkey@ violations whose 'DuplicateEvent' constructor carries no+stream attribution, generic server errors, and connection errors), we fall+back to attributing against the first stream in the input list and let+'mapUsageError' map the rest.++This is defensive — the current SQL paths in @kiroku-store/src/Kiroku/Store/SQL.hs@+do not raise @ix_streams_stream_name@ violations because every append CTE+uses @ON CONFLICT DO NOTHING@/@DO UPDATE@ — but a future schema change could+introduce a path that does, and the attribution should be correct from day+one.+-}+attributeMultiStreamError ::+    {- | The (name, expected) pairs from the multi-stream ops, in the order+    the caller supplied them.+    -}+    [(StreamName, ExpectedVersion)] ->+    UsageError ->+    StoreError+attributeMultiStreamError [] usageErr =+    -- Defensive: an empty multi-stream call should not reach the+    -- transaction layer, but if it somehow does, surface the raw error.+    ConnectionError ("Empty multi-stream usage error: " <> T.pack (show usageErr))+attributeMultiStreamError ops@((StreamName firstName, firstExpected) : _) usageErr =+    case extractServerError usageErr of+        Just (Errors.ServerError "23505" message (Just detail) _ _)+            | "ix_streams_stream_name" `T.isInfixOf` message+                || "ix_streams_stream_name" `T.isInfixOf` detail+            , Just sn <- extractStreamNameFromDetail detail+            , Just (StreamName name, expected) <- lookupStream sn ops ->+                mapUsageError name expected usageErr+        _ ->+            mapUsageError firstName firstExpected usageErr+  where+    lookupStream tgt = lookup' tgt+    lookup' _ [] = Nothing+    lookup' tgt (op@(StreamName n, _) : rest)+        | n == tgt = Just op+        | otherwise = lookup' tgt rest++-- | Walk a 'UsageError' down to the underlying 'Errors.ServerError', if any.+extractServerError :: UsageError -> Maybe Errors.ServerError+extractServerError = \case+    SessionUsageError (Errors.StatementSessionError _ _ _ _ _ stmtErr) ->+        case stmtErr of+            Errors.ServerStatementError serverErr -> Just serverErr+            _ -> Nothing+    _ -> Nothing
+ src/Kiroku/Store/Lifecycle.hs view
@@ -0,0 +1,110 @@+module Kiroku.Store.Lifecycle (+    softDeleteStream,+    hardDeleteStream,+    undeleteStream,+) where++import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Kiroku.Store.Effect (Store (..))+import Kiroku.Store.Types++{- | Mark a stream as deleted without removing its rows.++Soft-deleted streams are invisible to 'Kiroku.Store.Read.readStreamForward'+(returns empty), to 'Kiroku.Store.Read.readStreamBackward', and to+'Kiroku.Store.Append.appendToStream' (returns+'Kiroku.Store.Error.StreamNotFound' or+'Kiroku.Store.Error.StreamAlreadyExists' depending on+'Kiroku.Store.Types.ExpectedVersion'). They remain visible in the+@$all@ stream — the global event log is append-only — and to+'Kiroku.Store.Read.readCategory'. Use 'undeleteStream' to restore.++The exact stream name @$all@ is reserved for the global read stream.+Lifecycle operations reject it with+'Kiroku.Store.Error.ReservedStreamName' so callers cannot hide, remove,+or restore the internal global stream row.++Returns @Just streamId@ on success, or @Nothing@ if the stream did not+exist or was already soft-deleted. Reverse with 'undeleteStream' or+'hardDeleteStream'.+-}+softDeleteStream ::+    (HasCallStack, Store :> es) =>+    StreamName ->+    Eff es (Maybe StreamId)+softDeleteStream name = send (SoftDeleteStream name)++{- | Permanently remove a stream, its events (where they are not+referenced by other streams), and its links.++== Authorization model++Hard delete is gated by a session-local PostgreSQL GUC+(@kiroku.enable_hard_deletes@) that the interpreter sets inside its+transaction. Direct @DELETE@ or @TRUNCATE@ against the underlying+tables without setting that GUC raises an exception via the+@protect_deletion@ and @protect_truncation@ triggers in+@kiroku-store-migrations/sql-migrations@.++/The GUC is an advisory protection, not a security boundary./ Any+PostgreSQL session with @DELETE@ privilege on @events@,+@stream_events@, and @streams@ can issue @SET LOCAL+kiroku.enable_hard_deletes = \'on\'@ before its own @DELETE@ —+PostgreSQL grants @SET LOCAL@ to every session. The trigger exists+to make accidental issuance of @DELETE@ (a typo, an ad-hoc operator+query, an ORM that does not know the table is meant to be+append-only) fail loudly rather than to enforce role-based access+control.++In practice the model is "applications running with full @DELETE@+privilege on the data tables are trusted to call hard-delete+correctly". Production deployments that need stricter control should:++* Run the application as a low-privileged role with only @INSERT,+  UPDATE, SELECT@ on the data tables (not @DELETE@); soft-delete+  via 'softDeleteStream' is unaffected. Issue hard-deletes from a+  separate, more privileged role gated by your own access controls.++* /Or/ wrap calls to 'hardDeleteStream' in your application's+  authorization layer before they reach this function. Reading the+  @protect_deletion@ trigger as a security boundary is incorrect.++== Event preservation semantics++The interpreter cleans up junction rows ('stream_events') first,+then deletes orphaned 'events' rows — events still linked to other+streams from this one's hard-deleted source junctions are removed;+events linked to streams /not/ owned by this deletion are preserved.++== Result++Returns @Just streamId@ on success, @Nothing@ if the stream did not+exist. The exact stream name @$all@ is rejected with+'Kiroku.Store.Error.ReservedStreamName'. There is no \"undo\" — for reversible deletes use+'softDeleteStream' instead. The deletion emits no in-band audit row;+operators relying on an audit log must capture hard-deletes through+the connection-pool observation handler (see+'Kiroku.Store.Connection.ConnectionSettings.observationHandler') or+record an application-level event /before/ calling this function.+-}+hardDeleteStream ::+    (HasCallStack, Store :> es) =>+    StreamName ->+    Eff es (Maybe StreamId)+hardDeleteStream name = send (HardDeleteStream name)++{- | Restore a soft-deleted stream by clearing its @deleted_at@ row.++Reads of the restored stream return its full event history. Subsequent+appends behave as if the soft-delete never happened. Returns+@Just streamId@ on success, @Nothing@ if the stream is missing or was+not soft-deleted (already live). The exact stream name @$all@ is+rejected with 'Kiroku.Store.Error.ReservedStreamName'.+-}+undeleteStream ::+    (HasCallStack, Store :> es) =>+    StreamName ->+    Eff es (Maybe StreamId)+undeleteStream name = send (UndeleteStream name)
+ src/Kiroku/Store/Link.hs view
@@ -0,0 +1,47 @@+module Kiroku.Store.Link (+    linkToStream,+) where++import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Kiroku.Store.Effect (Store (..))+import Kiroku.Store.Types++{- | Link existing events into a target stream.++Creates the target stream if it does not exist; otherwise appends+links to the existing target. Linking does not duplicate the event+payload — the @events@ row is shared, and only a new junction row in+@stream_events@ is created. Linked events keep their original+'Kiroku.Store.Types.GlobalPosition' and 'Kiroku.Store.Types.RecordedEvent.originalStreamId' /+'originalVersion' fields; the target's 'Kiroku.Store.Types.RecordedEvent.streamVersion'+reflects the link's position in the target.++Preconditions:++* Every supplied 'Kiroku.Store.Types.EventId' must reference an event+  that currently exists. Linking an unknown id (a typo, or an id that+  was hard-deleted) rejects the entire batch atomically — the target+  stream is left in its pre-call state. (See EP-1 F3.)+* The target must not be soft-deleted. Linking to a soft-deleted target+  fails with 'Kiroku.Store.Error.StreamNotFound'. (See EP-1 F5.)+* The target must not be @$all@. @$all@ is the global read stream, and+  linking into it would bypass the append-only global ordering contract;+  the interpreter rejects this with+  'Kiroku.Store.Error.ReservedStreamName'.+* Linking the same event into the same target stream twice fails with+  a primary-key violation on the junction's @(stream_id, event_id)@+  uniqueness.++Returns the target's 'Kiroku.Store.Types.LinkResult' — its id and the+position of the /last/ linked event in the target.++Empty input @[]@ is a no-op programming mistake; do not call.+-}+linkToStream ::+    (HasCallStack, Store :> es) =>+    StreamName ->+    [EventId] ->+    Eff es LinkResult+linkToStream targetStream eventIds = send (LinkToStream targetStream eventIds)
+ src/Kiroku/Store/Notification.hs view
@@ -0,0 +1,266 @@+module Kiroku.Store.Notification (+    Notifier (..),+    NotifierStartError (..),+    startNotifier,+    stopNotifier,+) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (Async)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.STM (TChan, TVar, atomically, modifyTVar', newBroadcastTChanIO, newTVarIO, readTVarIO, writeTChan, writeTVar)+import Control.Exception (Exception, SomeException, asyncExceptionFromException, bracketOnError, catch, throwIO, toException)+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BC+import Data.Foldable (for_)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8Lenient)+import Data.Word (Word64)+import Hasql.Connection (Connection)+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Conn+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Errors (ConnectionError)+import Hasql.Notifications (PgIdentifier, toPgIdentifier, waitForNotifications)+import Hasql.Notifications qualified as Notifications+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, unpreparable)+import Kiroku.Store.Observability (KirokuEvent (..))++{- | A Notifier manages a dedicated PostgreSQL connection for LISTEN/NOTIFY.+It writes a @()@ tick to a broadcast 'TChan' on every notification,+allowing subscribers to wake without polling.++The current connection is held in a 'TVar' so that+'Kiroku.Store.Notification.stopNotifier' releases whichever connection+the listener loop most recently acquired (rather than the original one,+which may have been replaced by reconnection).+-}+data Notifier = Notifier+    { tickChan :: !(TChan ())+    -- ^ Broadcast channel; consumers must use 'dupTChan' to get a personal copy+    , listenerThread :: !(Async ())+    -- ^ The async thread running the LISTEN loop+    , listenerConnRef :: !(TVar Connection)+    {- ^ The /current/ dedicated listener connection. Updated by the loop on+    each successful reconnection so 'stopNotifier' always releases the+    live socket.+    -}+    , categoryGenerations :: !(TVar (Map Text Word64))+    {- ^ Per-category wake counter. The listener callback increments a+    category's entry on every NOTIFY for a stream in that category. A+    'Kiroku.Store.Subscription.Types.Category' subscription worker blocks until+    its category's counter advances, so an idle category does zero database work+    while other categories receive traffic. Notifications lost across a listener+    reconnect are reconciled by the worker's safety-poll timeout.+    -}+    }++{- | Raised by 'startNotifier' when the initial dedicated @LISTEN@+connection cannot be acquired. Carries @hasql@'s underlying+'Connection.ConnectionError' (often a TCP-level failure or an+authentication error) for diagnostics.++Replaces the prior @IOException@-via-@fail@ shape so callers can pattern+match on a typed startup exception.+-}+newtype NotifierStartError = NotifierStartError ConnectionError+    deriving stock (Show)+    deriving anyclass (Exception)++-- Cap reconnect backoff at 30 seconds; the EventPublisher's safety poll+-- runs at the same cadence, so the worst-case latency between a+-- recovered database and a re-armed subscription is bounded by the safety+-- poll regardless of the backoff. Capping here avoids unnecessary+-- additional latency under sustained outage.+maxReconnectDelayMicros :: Int+maxReconnectDelayMicros = 30_000_000++-- Compute the backoff delay (microseconds) for the @n@-th consecutive+-- failure, @n >= 1@. Schedule: 1s, 2s, 4s, 8s, 16s, 30s, 30s, ...+reconnectDelayMicros :: Int -> Int+reconnectDelayMicros n+    | n <= 0 = 1_000_000+    | otherwise = min maxReconnectDelayMicros (1_000_000 * 2 ^ (min (n - 1) 30))++{- | Start a Notifier. Acquires a dedicated connection, sets+@application_name@ to @kiroku-listener@ for operator visibility, issues+LISTEN on the @\<schema\>.events@ channel, and spawns a thread that+writes @()@ to the broadcast TChan on every notification.++On connection failure during the loop, releases the dead connection,+waits a backoff interval (capped exponential: 1s, 2s, 4s, 8s, 16s, 30s+thereafter), acquires a replacement, re-LISTENs, and resumes. The+replacement is published into 'listenerConnRef' so 'stopNotifier'+releases it on shutdown.++If an 'eventHandler' callback is supplied, the notifier emits+'Kiroku.Store.Observability.KirokuEventNotifierReconnecting' on each+attempted reconnect (with the consecutive failure count and the+underlying exception) and 'KirokuEventNotifierReconnected' on each+successful reconnect. The failure counter resets after a successful+reconnect.++On 'Async.AsyncCancelled' (from cancellation), exits cleanly.++Initial-acquire failure raises 'NotifierStartError'.+-}+startNotifier ::+    (MonadIO m) =>+    -- | libpq connection string+    Text ->+    -- | schema name (used to construct the LISTEN channel)+    Text ->+    -- | optional event handler for reconnect observability+    Maybe (KirokuEvent -> IO ()) ->+    m Notifier+startNotifier connString schema mHandler = liftIO $ do+    chan <- newBroadcastTChanIO+    catGenVar <- newTVarIO Map.empty+    conn <- acquireOrThrow connString+    let channel = toPgIdentifier (schema <> ".events")+    Notifications.listen conn channel+    connRef <- newTVarIO conn+    thread <- Async.async (listenerLoop chan catGenVar connRef channel connString mHandler)+    pure+        Notifier+            { tickChan = chan+            , listenerThread = thread+            , listenerConnRef = connRef+            , categoryGenerations = catGenVar+            }++{- | Stop the Notifier. Cancels the listener thread, waits for it to+finish, and releases whichever connection the loop is currently holding.+-}+stopNotifier :: (MonadIO m) => Notifier -> m ()+stopNotifier notifier = liftIO $ do+    Async.cancel (listenerThread notifier)+    void $ Async.waitCatch (listenerThread notifier)+    conn <- readTVarIO (listenerConnRef notifier)+    Connection.release conn++-- Internal: the listener loop. Calls 'waitForNotifications' on the current+-- connection; that call blocks indefinitely under normal operation. If it+-- returns (because the underlying 'Hasql.Connection.use' swallowed a session+-- error and produced a 'Left') or throws (because the panic propagated),+-- the loop releases the dead connection and reconnects. On async exceptions+-- it exits without releasing — 'stopNotifier' owns the final release via+-- 'listenerConnRef'.+--+-- The reconnect path takes the underlying 'SomeException' so it can carry it+-- on the 'KirokuEventNotifierReconnecting' event; the wait-returned-without-+-- exception path uses a synthetic message.+listenerLoop ::+    TChan () ->+    TVar (Map Text Word64) ->+    TVar Connection ->+    PgIdentifier ->+    Text ->+    Maybe (KirokuEvent -> IO ()) ->+    IO ()+listenerLoop chan catGenVar connRef channel connStr mHandler = go+  where+    go =+        ( do+            currentConn <- readTVarIO connRef+            waitForNotifications (handleNotification chan catGenVar) currentConn+            -- waitForNotifications returns only if the underlying connection+            -- went bad and Hasql converted the error into a Left result; in+            -- that case we must reconnect rather than spin re-invoking the+            -- same dead conn.+            reconnect 1 (toException ListenerWaitReturned)+        )+            `catch` \(e :: SomeException) ->+                case asyncExceptionFromException e of+                    Just (_ :: Async.AsyncCancelled) -> pure ()+                    Nothing -> reconnect 1 e++    reconnect attempt cause = do+        emit (KirokuEventNotifierReconnecting attempt cause)+        oldConn <- readTVarIO connRef+        Connection.release oldConn+        threadDelay (reconnectDelayMicros attempt)+        -- bracketOnError releases the freshly acquired connection if an+        -- async exception lands between acquire and the TVar write — without+        -- it the new connection would be unreachable from stopNotifier and+        -- would leak.+        result <-+            ( Right+                <$> bracketOnError+                    (acquireOrThrow connStr)+                    Connection.release+                    ( \newConn -> do+                        Notifications.listen newConn channel+                        atomically (writeTVar connRef newConn)+                    )+            )+                `catch` (\(e :: SomeException) -> pure (Left e))+        case result of+            Left e ->+                case asyncExceptionFromException e of+                    Just (_ :: Async.AsyncCancelled) -> throwIO e+                    Nothing -> reconnect (attempt + 1) e+            Right () -> do+                emit KirokuEventNotifierReconnected+                go++    emit evt = for_ mHandler ($ evt)++-- The 'waitForNotifications' callback. Wakes the publisher (the bare @()@ tick,+-- preserving the existing AllStreams broadcast path) AND bumps the originating+-- stream's category generation so a 'Kiroku.Store.Subscription.Types.Category'+-- worker blocked on that category unblocks. Both updates happen in one STM+-- transaction. The two callback arguments are the channel and the payload; we+-- ignore the channel (we only LISTEN on one) and parse the payload.+handleNotification :: TChan () -> TVar (Map Text Word64) -> ByteString -> ByteString -> IO ()+handleNotification chan catGenVar _channel payload =+    atomically $ do+        writeTChan chan ()+        modifyTVar' catGenVar (Map.insertWith (+) (categoryFromPayload payload) 1)++-- Recover the originating stream's category from a @notify_events@ payload. The+-- payload is @stream_name,stream_id,stream_version@; @stream_id@ and+-- @stream_version@ are comma-free integers, so the @stream_name@ is everything+-- except the last two comma-separated fields (rejoined, since a stream name may+-- itself contain commas). The category is then the prefix before the first @-@,+-- matching the @streams.category GENERATED ALWAYS AS split_part(stream_name,'-',1)@+-- column. A category never contains @-@, so @takeWhile (/= '-')@ is exact.+categoryFromPayload :: ByteString -> Text+categoryFromPayload payload =+    let fields = BC.split ',' payload+        streamName = BC.intercalate "," (take (max 0 (length fields - 2)) fields)+     in decodeUtf8Lenient (BC.takeWhile (/= '-') streamName)++-- A synthetic exception used when 'waitForNotifications' returns without+-- raising (hasql-notifications turned a connection error into a Left+-- result and dropped the diagnostic). The reconnect-event payload still+-- needs an exception value — this is it.+data ListenerWaitReturned = ListenerWaitReturned+    deriving stock (Show)+    deriving anyclass (Exception)++-- Internal: acquire a connection, set its application_name, or throw on failure.+-- Throws 'NotifierStartError' (which derives 'Exception') instead of the+-- prior @fail@-based 'IOException', so callers can match on a typed startup+-- exception.+acquireOrThrow :: Text -> IO Connection+acquireOrThrow connStr = do+    result <- Connection.acquire (Conn.connectionString connStr)+    case result of+        Left err -> throwIO (NotifierStartError err)+        Right conn -> do+            -- Tag the connection so operators can identify the listener in+            -- pg_stat_activity. Failures here are non-fatal — fall back to the+            -- default application_name silently rather than aborting startup.+            _ <- Connection.use conn (Session.statement () setAppNameStmt)+            pure conn++setAppNameStmt :: Statement () ()+setAppNameStmt =+    unpreparable "SET application_name = 'kiroku-listener'" E.noParams D.noResult
+ src/Kiroku/Store/Observability.hs view
@@ -0,0 +1,235 @@+{- | Structured operational events emitted by 'Kiroku.Store'.++This module provides the 'KirokuEvent' sum type and its supporting+enumerations. It complements+'Kiroku.Store.Connection.ConnectionSettings.observationHandler' (which+covers @hasql-pool@'s connection-lifecycle events) with events the+package emits itself:++* Notifier reconnection (the dedicated @LISTEN@ connection went bad and+  is being re-established).+* EventPublisher pool errors (the publisher's read query failed and+  will retry on the next tick or 30-second safety poll).+* Per-subscription database errors (checkpoint load, batch fetch,+  checkpoint save).+* Subscription lifecycle (started, caught-up, paused, resumed, reconnecting,+  stopped).+* Subscription batch delivery (one per non-empty batch handed to the+  handler, on every target and in both catch-up and live phases).+* Subscription live fetches (one per DB-driven live-mode fetch).+* Hard-delete issuance (a fail-safe audit signal — see+  @docs\/PRODUCTION-DEPLOYMENT.md@ for the recommended in-band audit+  pattern).++Wire 'Kiroku.Store.Connection.ConnectionSettingsM.eventHandler' to a+callback that forwards to your structured logger or metrics pipeline.+The callback runs synchronously on the emit-site thread (notifier loop,+publisher loop, worker loop, store interpreter); slow callbacks therefore+stall those loops. For callbacks that may block, fan out asynchronously+(write to a 'Control.Concurrent.STM.TBQueue' and drain in a separate+thread).++The constructor set is /additive/: new events are added rather than+existing constructors changed. Pattern matches that do not handle a+new constructor will surface as @-Wincomplete-patterns@ warnings, never+as silent regressions.+-}+module Kiroku.Store.Observability (+    KirokuEvent (..),+    SubscriptionDbPhase (..),+    SubscriptionDeliveryPhase (..),+    SubscriptionStopReason (..),+    SubscriptionGroupContext (..),+    DeadLetterReason (..),+) where++import Control.Exception (SomeException)+import Data.Int (Int32)+import Hasql.Pool (UsageError)+import Kiroku.Store.Subscription.Fsm (DeadLetterReason (..), SubscriptionStopReason (..))+import Kiroku.Store.Subscription.Types (SubscriptionName)+import Kiroku.Store.Types (GlobalPosition, StreamId, StreamName)++{- | A structured operational event emitted by 'Kiroku.Store' itself.++Events are emitted synchronously from the originating thread; consumer+callbacks should be fast or fan out to an asynchronous worker. See the+module Haddock for context.+-}+data KirokuEvent+    = {- | The dedicated @LISTEN@ connection encountered a non-async+      exception and the listener loop is about to attempt reconnection.+      The 'Int' is the consecutive failure count starting at @1@; it+      drives the exponential-backoff delay (capped at 30 seconds) and+      is useful as a metric label for sustained-outage alerting.+      -}+      KirokuEventNotifierReconnecting !Int !SomeException+    | {- | The listener loop successfully re-established the @LISTEN@+      connection. Pairs with the most recent+      'KirokuEventNotifierReconnecting'; the failure counter resets to+      @0@ on observing this event.+      -}+      KirokuEventNotifierReconnected+    | {- | The 'Kiroku.Store.Subscription.EventPublisher.EventPublisher'+      read query returned a 'UsageError'. The publisher will retry on+      the next notification tick or the 30-second safety poll. Sustained+      emissions indicate either pool exhaustion (the publisher shares+      the application pool) or a persistent server error.+      -}+      KirokuEventPublisherPoolError !UsageError+    | {- | A subscription's worker thread encountered a 'UsageError' in+      the database phase identified by 'SubscriptionDbPhase'. The+      worker may continue with a documented fallback for checkpoint+      load/save phases, while fetch-batch errors are retried at the same+      cursor. The event is the operator's structured signal that this+      happened. The trailing 'SubscriptionGroupContext' identifies which+      consumer-group member (if any) emitted it.+      -}+      KirokuEventSubscriptionDbError !SubscriptionName !SubscriptionDbPhase !UsageError !SubscriptionGroupContext+    | {- | A subscription's worker thread has just started; the worker+      will begin from the recorded 'GlobalPosition' (zero if no+      checkpoint exists or 'KirokuEventSubscriptionDbError' fired in+      the @LoadCheckpoint@ phase). The trailing 'SubscriptionGroupContext'+      identifies which consumer-group member (if any) started.+      -}+      KirokuEventSubscriptionStarted !SubscriptionName !GlobalPosition !SubscriptionGroupContext+    | {- | The subscription has reached the EventPublisher's+      @lastPublished@ position and is switching from catch-up to+      live mode at the indicated 'GlobalPosition'. Fires at most+      once per worker run. The trailing 'SubscriptionGroupContext'+      identifies which consumer-group member (if any) caught up.+      -}+      KirokuEventSubscriptionCaughtUp !SubscriptionName !GlobalPosition !SubscriptionGroupContext+    | {- | The subscription's worker has stopped at the indicated+      'GlobalPosition'. The 'SubscriptionStopReason' discriminates+      normal completion (handler returned 'Stop') from cancellation,+      overflow, and worker-thread crashes. The trailing+      'SubscriptionGroupContext' identifies which consumer-group member+      (if any) stopped.+      -}+      KirokuEventSubscriptionStopped !SubscriptionName !GlobalPosition !SubscriptionStopReason !SubscriptionGroupContext+    | {- | A subscription's worker hit recoverable backpressure: its bounded+      queue filled under the 'Kiroku.Store.Subscription.Types.PauseAndResume'+      overflow policy, so the worker paused delivery at the indicated+      'GlobalPosition'. Pairs with a subsequent+      'KirokuEventSubscriptionResumed'. The trailing 'SubscriptionGroupContext'+      identifies which consumer-group member (if any) paused.+      -}+      KirokuEventSubscriptionPaused !SubscriptionName !GlobalPosition !SubscriptionGroupContext+    | {- | A subscription's worker resumed after a pause: it drained the stale+      queue and re-catches-up from its checkpoint (the indicated+      'GlobalPosition') so every event skipped while paused is re-read from the+      database. Pairs with a preceding 'KirokuEventSubscriptionPaused'.+      -}+      KirokuEventSubscriptionResumed !SubscriptionName !GlobalPosition !SubscriptionGroupContext+    | {- | A subscription's worker lost its database connection while live (a+      'UsageError' on a live-mode fetch) and is reconnecting: it backs off and+      re-catches-up from its checkpoint rather than dying. The 'Int' is the+      consecutive reconnect-attempt count starting at @1@; it drives the+      capped backoff and is a useful sustained-outage metric label. Emitted by+      Category and consumer-group subscriptions (AllStreams live delivery is fed+      by the publisher, which owns its own reconnect). The trailing+      'SubscriptionGroupContext' identifies the consumer-group member (if any).+      -}+      KirokuEventSubscriptionReconnecting !SubscriptionName !Int !SubscriptionGroupContext+    | {- | A live DB-driven subscription loop+      ('Kiroku.Store.Subscription.Worker') issued one category/partition fetch+      in live mode, returning the given row count ('Int'). Emitted by the+      @Category@ NOTIFY-driven loop and the consumer-group loop on every live+      fetch (not on the catch-up path). Lets operators observe the+      per-subscription live-fetch rate and lets tests assert that an idle+      category does no work. The trailing 'SubscriptionGroupContext' identifies+      the consumer-group member (if any).+      -}+      KirokuEventSubscriptionFetched !SubscriptionName !Int !SubscriptionGroupContext+    | {- | A subscription's worker delivered one non-empty batch of events to+      the handler through the single delivery primitive+      'Kiroku.Store.Subscription.Worker.processEvents'. Emitted once per batch on+      __every__ delivery path — catch-up for every target, @AllStreams@ live, and+      the @Category@\/consumer-group DB-driven live loops — so it is a uniform+      per-batch delivery signal. The 'Int' is the batch row count (always @>= 1@).+      The 'SubscriptionDeliveryPhase' says whether the worker was catching up or+      live when it delivered. The trailing 'SubscriptionGroupContext' identifies+      the consumer-group member (if any).++      This is distinct from 'KirokuEventSubscriptionFetched', which only the+      DB-driven live loops emit (per /fetch/, including empty fetches) and which+      this constructor does /not/ replace. A DB-driven live batch therefore emits+      both 'KirokuEventSubscriptionFetched' (the fetch) and+      'KirokuEventSubscriptionDelivered' (the delivery).+      -}+      KirokuEventSubscriptionDelivered !SubscriptionName !Int !SubscriptionDeliveryPhase !SubscriptionGroupContext+    | {- | A subscription handler returned+      'Kiroku.Store.Subscription.Types.Retry' for the event at the indicated+      'GlobalPosition' and the worker is about to redeliver it. The 'Int' is the+      redelivery attempt count starting at @1@ (so @1@ is the first redelivery+      after the initial delivery). Bounded by the subscription's+      'Kiroku.Store.Subscription.Types.RetryPolicy'; exhaustion produces a+      'KirokuEventSubscriptionDeadLettered' with+      'Kiroku.Store.Subscription.Types.DeadLetterMaxAttempts'. The trailing+      'SubscriptionGroupContext' identifies the consumer-group member (if any).+      -}+      KirokuEventSubscriptionRetrying !SubscriptionName !GlobalPosition !Int !SubscriptionGroupContext+    | {- | The worker recorded the event at the indicated 'GlobalPosition' in+      @kiroku.dead_letters@ with the given 'DeadLetterReason' and atomically+      advanced the checkpoint past it. Emitted when a handler returns+      'Kiroku.Store.Subscription.Types.DeadLetter' or when retry attempts are+      exhausted. The trailing 'SubscriptionGroupContext' identifies the+      consumer-group member (if any).+      -}+      KirokuEventSubscriptionDeadLettered !SubscriptionName !GlobalPosition !DeadLetterReason !SubscriptionGroupContext+    | {- | A hard-delete transaction completed successfully. Operators+      relying on a fail-safe audit log can capture this event;+      compliance-grade audit should still record an application-level+      event /before/ calling+      'Kiroku.Store.Lifecycle.hardDeleteStream' (see+      @docs\/PRODUCTION-DEPLOYMENT.md@). Not emitted when the named+      stream did not exist.+      -}+      KirokuEventHardDeleteIssued !StreamName !StreamId+    deriving stock (Show)++-- | Which database phase a 'KirokuEventSubscriptionDbError' fired in.+data SubscriptionDbPhase+    = {- | 'Kiroku.Store.Subscription.Worker' failed to read the saved+      checkpoint at subscription startup. The worker continues with+      'Kiroku.Store.Types.GlobalPosition' @0@; on a fresh subscription+      this is correct, on an existing subscription it silently+      re-processes events.+      -}+      LoadCheckpoint+    | {- | The worker's catch-up or category-live database fetch+      returned an error. The worker retries the same cursor with capped+      backoff instead of treating the error as an empty result.+      -}+      FetchBatch+    | {- | The worker's @saveCheckpoint@ statement failed. The+      subscription continues running but the next restart with the+      same name re-processes events the handler has already seen.+      -}+      SaveCheckpoint+    deriving stock (Eq, Show)++{- | Which FSM phase a 'KirokuEventSubscriptionDelivered' batch was delivered in:+the worker was either still catching up from history ('DeliveredCatchUp') or+already live ('DeliveredLive'). Derived from the driving 'SubscriptionState' the+worker wrote before the batch (see 'Kiroku.Store.Subscription.Worker.processEvents').+-}+data SubscriptionDeliveryPhase+    = -- | The batch was delivered while the worker was in 'CatchingUp'.+      DeliveredCatchUp+    | -- | The batch was delivered while the worker was 'Live'.+      DeliveredLive+    deriving stock (Eq, Show)++{- | Consumer-group context attached to subscription lifecycle events. A plain+(non-grouped) subscription reports 'NonGroup'; a member of a group reports+@GroupMember member size@ so operators can attribute a lifecycle event to a+specific @(member, size)@.+-}+data SubscriptionGroupContext+    = -- | Ordinary, non-grouped subscription.+      NonGroup+    | -- | Member of a group: @GroupMember member size@.+      GroupMember !Int32 !Int32+    deriving stock (Eq, Show)
+ src/Kiroku/Store/Read.hs view
@@ -0,0 +1,209 @@+module Kiroku.Store.Read (+    readStreamForward,+    readStreamForwardStream,+    readStreamBackward,+    readAllForward,+    readAllBackward,+    readCategory,+    getStream,+    lookupStreamId,+    lookupStreamName,+    lookupStreamNames,+) where++import Control.Lens ((^.))+import Data.Generics.Labels ()+import Data.Int (Int32)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Vector (Vector)+import Data.Vector qualified as V+import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Kiroku.Store.Effect (Store (..))+import Kiroku.Store.Types+import Streamly.Data.Stream (Stream)+import Streamly.Data.Stream qualified as Stream++{- | Read events from a named stream in forward (ascending version)+order.++The cursor is exclusive: events with @streamVersion > startVer@ are+returned. To read the entire stream from the beginning, pass+@'StreamVersion' 0@. Returns an empty vector for nonexistent or+soft-deleted streams. The @limit@ caps the batch size; pass a large+value for \"read everything\".+-}+readStreamForward ::+    (HasCallStack, Store :> es) =>+    StreamName ->+    StreamVersion ->+    Int32 ->+    Eff es (Vector RecordedEvent)+readStreamForward name startVer limit = send (ReadStreamForward name startVer limit)++{- | Forward read a single stream as a constant-memory Streamly 'Stream'.++The streaming sibling of 'readStreamForward'. Identical SQL path and identical+error semantics: this function dispatches 'readStreamForward' repeatedly with+the supplied @pageSize@ as the per-call limit, advancing the exclusive+'StreamVersion' cursor across pages until the next call returns an empty+batch.++The exclusive-cursor convention is preserved end-to-end: passing+@'StreamVersion' 0@ reads from the first event in the stream. Empty and+nonexistent streams terminate the stream immediately with zero elements.++The recommended @pageSize@ is @256@. Callers reading very wide events (large+payloads / metadata) should pass a smaller value to keep per-page memory+bounded; callers reading very long streams of small events may pass a larger+value to reduce round-trip count.+-}+readStreamForwardStream ::+    (HasCallStack, Store :> es) =>+    StreamName ->+    StreamVersion ->+    Int32 ->+    Stream (Eff es) RecordedEvent+readStreamForwardStream name startVer pageSize =+    Stream.concatMap (Stream.fromList . V.toList) pages+  where+    pages = Stream.unfoldrM nextPage startVer+    nextPage cursor = do+        events <- readStreamForward name cursor pageSize+        if V.null events+            then pure Nothing+            else+                let lastV = V.last events ^. #streamVersion+                 in pure (Just (events, lastV))++{- | Read events from a named stream in backward (descending version)+order.++The cursor is exclusive: events with @streamVersion < startVer@ are+returned (events older than the cursor). To read the entire stream from+the latest event backward, pass @'StreamVersion' 0@ (the SQL treats it+as \"newer than any\"). Returns an empty vector for nonexistent or+soft-deleted streams.+-}+readStreamBackward ::+    (HasCallStack, Store :> es) =>+    StreamName ->+    StreamVersion ->+    Int32 ->+    Eff es (Vector RecordedEvent)+readStreamBackward name startVer limit = send (ReadStreamBackward name startVer limit)++{- | Read events from the global @$all@ stream in forward+('GlobalPosition'-ascending) order.++Cursor exclusive: events with @globalPosition > startPos@ are returned.+@$all@ contains every event ever appended (including events from+soft-deleted streams; they survive in @$all@ even after their owning+stream is hidden). Hard-deleted streams' events do /not/ appear in+@$all@. The seed row at @globalPosition = 0@ is internal and is never+returned.+-}+readAllForward ::+    (HasCallStack, Store :> es) =>+    GlobalPosition ->+    Int32 ->+    Eff es (Vector RecordedEvent)+readAllForward startPos limit = send (ReadAllForward startPos limit)++{- | Read events from the global @$all@ stream in backward+('GlobalPosition'-descending) order.++Cursor exclusive. To start from the most recent event, pass+@'GlobalPosition' 0@ (treated as \"after everything\" by the SQL).+-}+readAllBackward ::+    (HasCallStack, Store :> es) =>+    GlobalPosition ->+    Int32 ->+    Eff es (Vector RecordedEvent)+readAllBackward startPos limit = send (ReadAllBackward startPos limit)++{- | Read events whose source stream's category prefix matches the given+'CategoryName', in 'GlobalPosition' order.++The category is the substring of a 'StreamName' before the first @-@:+@StreamName "orders-1"@ has @CategoryName "orders"@. Linked events+appear at their /source/ position; the category is the source's+category, not the link target's.+-}+readCategory ::+    (HasCallStack, Store :> es) =>+    CategoryName ->+    GlobalPosition ->+    Int32 ->+    Eff es (Vector RecordedEvent)+readCategory cat startPos limit = send (ReadCategoryForward cat startPos limit)++{- | Query stream metadata.++Returns 'Just' for both live and soft-deleted streams (with @deletedAt@+populated). Returns 'Nothing' for hard-deleted streams and streams that+have never been created.+-}+getStream ::+    (HasCallStack, Store :> es) =>+    StreamName ->+    Eff es (Maybe StreamInfo)+getStream name = send (GetStream name)++{- | Look up a stream's surrogate id by name.++Returns 'Just' the 'StreamId' for both live and soft-deleted streams (mirroring+'getStream'\'s soft-delete behavior). Returns 'Nothing' for streams that have+never been created and for streams that have been hard-deleted.++This is a lighter-weight alternative to 'getStream' when the caller only needs+the surrogate id: it decodes one @int8@ column instead of the five columns+that 'StreamInfo' carries. Equivalent to projecting @info ^. #id@ from a+successful 'getStream' result, but cheaper.+-}+lookupStreamId ::+    (HasCallStack, Store :> es) =>+    StreamName ->+    Eff es (Maybe StreamId)+lookupStreamId name = send (LookupStreamId name)++{- | Resolve a batch of surrogate 'StreamId's to their 'StreamName's in a single+round trip, returning a 'Map' that omits any id which does not name an existing+stream (hard-deleted or never created). Live and soft-deleted streams are+included, mirroring 'lookupStreamId'.++This is the inverse of 'lookupStreamId' and the supported way to recover the+human-readable source stream for events obtained from /fan-in/ reads — the+global @$all@ stream, 'readCategory', the "Kiroku.Store.Causation" queries, and+subscriptions — where each 'RecordedEvent' carries only its surrogate+@originalStreamId@. Collect the distinct ids from a batch and resolve them once,+rather than paying a round trip per event:++@+let ids = 'Data.List.nub' (map (^. #originalStreamId) events)+names <- 'lookupStreamNames' ids+-- names '!?' (event '^.' #originalStreamId) :: Maybe StreamName+@++Passing @[]@ returns an empty map without a database round trip's worth of work+(an empty @ANY(ARRAY[])@ matches nothing).+-}+lookupStreamNames ::+    (HasCallStack, Store :> es) =>+    [StreamId] ->+    Eff es (Map StreamId StreamName)+lookupStreamNames sids = send (LookupStreamNames sids)++{- | Resolve a single surrogate 'StreamId' to its 'StreamName', or 'Nothing' if+no such stream exists. A convenience wrapper over 'lookupStreamNames'; prefer+the batch form when resolving the ids of a whole read batch, to avoid one round+trip per id.+-}+lookupStreamName ::+    (HasCallStack, Store :> es) =>+    StreamId ->+    Eff es (Maybe StreamName)+lookupStreamName sid = Map.lookup sid <$> lookupStreamNames [sid]
+ src/Kiroku/Store/SQL.hs view
@@ -0,0 +1,1221 @@+{-# LANGUAGE MultilineStrings #-}++module Kiroku.Store.SQL (+    -- * Append statements+    AppendParams (..),+    appendExpectedVersion,+    appendStreamExists,+    appendNoStream,+    appendAnyVersion,++    -- * Link statements+    linkToStreamStmt,++    -- * Read statements+    readStreamForwardStmt,+    readStreamBackwardStmt,+    readAllForwardStmt,+    readAllBackwardStmt,+    readCategoryForwardStmt,+    getStreamStmt,+    lookupStreamNamesStmt,+    currentGlobalPositionStmt,++    -- * Consumer-group read statements+    readCategoryForwardConsumerGroupStmt,+    readAllForwardConsumerGroupStmt,++    -- * Causation / correlation statements+    findByCorrelationStmt,+    findCausationDescendantsStmt,+    findCausationAncestorsStmt,++    -- * Lifecycle statements+    softDeleteStreamStmt,+    undeleteStreamStmt,++    -- * Hard-delete statements (used in sequence inside one transaction)+    findStreamIdStmt,+    deleteStreamJunctionsStmt,+    deleteOrphanedEventsStmt,+    deleteStreamRowStmt,++    -- * Multi-stream pre-lock (avoids row-lock deadlocks)+    lockStreamsForMultiStmt,++    -- * Checkpoint statements+    getCheckpointStmt,+    saveCheckpointStmt,+    getCheckpointMemberStmt,+    saveCheckpointMemberStmt,++    -- * Dead-letter statements+    DeadLetterParams (..),+    DeadLetterRecord (..),+    insertDeadLetterAndCheckpointStmt,+    readDeadLettersStmt,+) where++import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5)+import Control.Lens ((^.))+import Data.Aeson (Value)+import Data.Functor.Contravariant ((>$<))+import Data.Generics.Labels ()+import Data.Int (Int32, Int64)+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.UUID (UUID)+import Data.Vector (Vector)+import GHC.Generics (Generic)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Kiroku.Store.Types++-- | Parameters for append CTE variants (the 7 parallel arrays + stream name).+data AppendParams = AppendParams+    { eventIds :: !(Vector UUID)+    , eventTypes :: !(Vector Text)+    , causationIds :: !(Vector (Maybe UUID))+    , correlationIds :: !(Vector (Maybe UUID))+    , payloads :: !(Vector Value)+    , metadatas :: !(Vector (Maybe Value))+    , createdAts :: !(Vector UTCTime)+    , streamName :: !Text+    }+    deriving stock (Show, Generic)++-- | Encoder for the common 8 parameters shared by all append variants.+appendParamsEncoder :: E.Params AppendParams+appendParamsEncoder =+    ((^. #eventIds) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+        <> ((^. #eventTypes) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+        <> ((^. #causationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+        <> ((^. #correlationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+        <> ((^. #payloads) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.jsonb))))+        <> ((^. #metadatas) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.jsonb))))+        <> ((^. #createdAts) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.timestamptz))))+        <> ((^. #streamName) >$< E.param (E.nonNullable E.text))++-- | Encoder for append_expected_version: base params + expected version (Int64).+appendExpectedEncoder :: E.Params (AppendParams, Int64)+appendExpectedEncoder =+    contrazip2 appendParamsEncoder (E.param (E.nonNullable E.int8))++{- | Decoder for append results: stream_id, stream_version, global_position.+Returns Nothing if the CTE produced 0 rows (version conflict / stream not found).+-}+appendResultDecoder :: D.Result (Maybe AppendResult)+appendResultDecoder =+    D.rowMaybe $+        AppendResult+            <$> (StreamId <$> D.column (D.nonNullable D.int8))+            <*> (StreamVersion <$> D.column (D.nonNullable D.int8))+            <*> (GlobalPosition <$> D.column (D.nonNullable D.int8))++{- | Append with exact expected version (optimistic concurrency).+Returns Nothing if the stream doesn't exist or version doesn't match.+-}+appendExpectedVersion :: Statement (AppendParams, Int64) (Maybe AppendResult)+appendExpectedVersion =+    preparable+        appendExpectedVersionSQL+        appendExpectedEncoder+        appendResultDecoder++{- | Append to an existing stream at any version.+Returns Nothing if the stream doesn't exist.+-}+appendStreamExists :: Statement AppendParams (Maybe AppendResult)+appendStreamExists =+    preparable+        appendStreamExistsSQL+        appendParamsEncoder+        appendResultDecoder++{- | Append to a new stream (must not already exist).+Returns Nothing if the stream already exists.+-}+appendNoStream :: Statement AppendParams (Maybe AppendResult)+appendNoStream =+    preparable+        appendNoStreamSQL+        appendParamsEncoder+        appendResultDecoder++{- | Append to a stream, creating it if it doesn't exist.+Should always return Just (unless duplicate event ID constraint violation).+-}+appendAnyVersion :: Statement AppendParams (Maybe AppendResult)+appendAnyVersion =+    preparable+        appendAnyVersionSQL+        appendParamsEncoder+        appendResultDecoder++-- ---------------------------------------------------------------------------+-- SQL Templates+-- ---------------------------------------------------------------------------++-- | CTE with exact version check: UPDATE streams WHERE stream_version = $9.+appendExpectedVersionSQL :: Text+appendExpectedVersionSQL =+    """+    WITH+      new_events AS (+        SELECT *+        FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+        WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+      ),+      stream_update AS (+        UPDATE streams+        SET stream_version = stream_version + (SELECT count(*) FROM new_events)+        WHERE stream_name = $8+          AND stream_version = $9+          AND deleted_at IS NULL+        RETURNING stream_id, stream_version - (SELECT count(*) FROM new_events) AS initial_version+      ),+      inserted_events AS (+        INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+        SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+        FROM new_events+        WHERE EXISTS (SELECT 1 FROM stream_update)+        ORDER BY idx+      ),+      source_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, su.stream_id, su.initial_version + ne.idx, su.stream_id, su.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN stream_update su+      ),+      all_update AS (+        UPDATE streams+        SET stream_version = stream_version + (SELECT count(*) FROM new_events)+        WHERE stream_id = 0+          AND EXISTS (SELECT 1 FROM stream_update)+        RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+      ),+      all_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN all_update au+        CROSS JOIN stream_update su+      )+    SELECT su.stream_id,+           su.initial_version + (SELECT count(*) FROM new_events),+           au.initial_global_version + (SELECT count(*) FROM new_events)+    FROM stream_update su+    CROSS JOIN all_update au+    """++-- | CTE without version check: UPDATE streams WHERE stream_name = $8 (no $9).+appendStreamExistsSQL :: Text+appendStreamExistsSQL =+    """+    WITH+      new_events AS (+        SELECT *+        FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+        WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+      ),+      stream_update AS (+        UPDATE streams+        SET stream_version = stream_version + (SELECT count(*) FROM new_events)+        WHERE stream_name = $8+          AND deleted_at IS NULL+        RETURNING stream_id, stream_version - (SELECT count(*) FROM new_events) AS initial_version+      ),+      inserted_events AS (+        INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+        SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+        FROM new_events+        WHERE EXISTS (SELECT 1 FROM stream_update)+        ORDER BY idx+      ),+      source_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, su.stream_id, su.initial_version + ne.idx, su.stream_id, su.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN stream_update su+      ),+      all_update AS (+        UPDATE streams+        SET stream_version = stream_version + (SELECT count(*) FROM new_events)+        WHERE stream_id = 0+          AND EXISTS (SELECT 1 FROM stream_update)+        RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+      ),+      all_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN all_update au+        CROSS JOIN stream_update su+      )+    SELECT su.stream_id,+           su.initial_version + (SELECT count(*) FROM new_events),+           au.initial_global_version + (SELECT count(*) FROM new_events)+    FROM stream_update su+    CROSS JOIN all_update au+    """++-- | CTE for new stream creation: INSERT INTO streams ... ON CONFLICT DO NOTHING.+appendNoStreamSQL :: Text+appendNoStreamSQL =+    """+    WITH+      new_events AS (+        SELECT *+        FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+        WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+      ),+      stream_insert AS (+        INSERT INTO streams (stream_name, stream_version)+        VALUES ($8, (SELECT count(*) FROM new_events))+        ON CONFLICT (stream_name) DO NOTHING+        RETURNING stream_id, 0::bigint AS initial_version+      ),+      inserted_events AS (+        INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+        SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+        FROM new_events+        WHERE EXISTS (SELECT 1 FROM stream_insert)+        ORDER BY idx+      ),+      source_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, si.stream_id, si.initial_version + ne.idx, si.stream_id, si.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN stream_insert si+      ),+      all_update AS (+        UPDATE streams+        SET stream_version = stream_version + (SELECT count(*) FROM new_events)+        WHERE stream_id = 0+          AND EXISTS (SELECT 1 FROM stream_insert)+        RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+      ),+      all_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, 0, au.initial_global_version + ne.idx, si.stream_id, si.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN all_update au+        CROSS JOIN stream_insert si+      )+    SELECT si.stream_id,+           si.initial_version + (SELECT count(*) FROM new_events),+           au.initial_global_version + (SELECT count(*) FROM new_events)+    FROM stream_insert si+    CROSS JOIN all_update au+    """++{- | CTE for create-or-append using INSERT ... ON CONFLICT DO UPDATE (upsert).+A plain INSERT + separate UPDATE in the same CTE won't work because+data-modifying CTEs cannot see each other's changes. Instead, we use+a single upsert that both creates the stream and bumps its version atomically.+-}+appendAnyVersionSQL :: Text+appendAnyVersionSQL =+    """+    WITH+      new_events AS (+        SELECT *+        FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+        WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+      ),+      stream_upsert AS (+        INSERT INTO streams (stream_name, stream_version)+        VALUES ($8, (SELECT count(*) FROM new_events))+        ON CONFLICT (stream_name)+        DO UPDATE SET stream_version = streams.stream_version + (SELECT count(*) FROM new_events)+          WHERE streams.deleted_at IS NULL+        RETURNING stream_id, stream_version - (SELECT count(*) FROM new_events) AS initial_version+      ),+      inserted_events AS (+        INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+        SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+        FROM new_events+        WHERE EXISTS (SELECT 1 FROM stream_upsert)+        ORDER BY idx+      ),+      source_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, su.stream_id, su.initial_version + ne.idx, su.stream_id, su.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN stream_upsert su+      ),+      all_update AS (+        UPDATE streams+        SET stream_version = stream_version + (SELECT count(*) FROM new_events)+        WHERE stream_id = 0+          AND EXISTS (SELECT 1 FROM stream_upsert)+        RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+      ),+      all_links AS (+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx+        FROM new_events ne+        CROSS JOIN all_update au+        CROSS JOIN stream_upsert su+      )+    SELECT su.stream_id,+           su.initial_version + (SELECT count(*) FROM new_events),+           au.initial_global_version + (SELECT count(*) FROM new_events)+    FROM stream_upsert su+    CROSS JOIN all_update au+    """++-- ---------------------------------------------------------------------------+-- Read Statements+-- ---------------------------------------------------------------------------++-- | Shared decoder for a RecordedEvent row (11 columns).+recordedEventRow :: D.Row RecordedEvent+recordedEventRow =+    RecordedEvent+        <$> (EventId <$> D.column (D.nonNullable D.uuid))+        <*> (EventType <$> D.column (D.nonNullable D.text))+        <*> (StreamVersion <$> D.column (D.nonNullable D.int8))+        <*> (GlobalPosition <$> D.column (D.nonNullable D.int8))+        <*> (StreamId <$> D.column (D.nonNullable D.int8))+        <*> (StreamVersion <$> D.column (D.nonNullable D.int8))+        <*> D.column (D.nonNullable D.jsonb)+        <*> D.column (D.nullable D.jsonb)+        <*> D.column (D.nullable D.uuid)+        <*> D.column (D.nullable D.uuid)+        <*> D.column (D.nonNullable D.timestamptz)++-- | Shared decoder for a StreamInfo row (5 columns).+streamInfoRow :: D.Row StreamInfo+streamInfoRow =+    StreamInfo+        <$> (StreamId <$> D.column (D.nonNullable D.int8))+        <*> (StreamName <$> D.column (D.nonNullable D.text))+        <*> (StreamVersion <$> D.column (D.nonNullable D.int8))+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nullable D.timestamptz)++-- | Encoder for stream read params: (stream_name, start_version, limit).+readStreamEncoder :: E.Params (Text, Int64, Int32)+readStreamEncoder =+    contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.int4))++-- | Encoder for $all read params: (start_position, limit).+readAllEncoder :: E.Params (Int64, Int32)+readAllEncoder =+    contrazip2+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.int4))++-- | Read events from a named stream in forward order.+readStreamForwardStmt :: Statement (Text, Int64, Int32) (Vector RecordedEvent)+readStreamForwardStmt =+    preparable+        readStreamForwardSQL+        readStreamEncoder+        (D.rowVector recordedEventRow)++-- | Read events from a named stream in backward order.+readStreamBackwardStmt :: Statement (Text, Int64, Int32) (Vector RecordedEvent)+readStreamBackwardStmt =+    preparable+        readStreamBackwardSQL+        readStreamEncoder+        (D.rowVector recordedEventRow)++-- | Read events from the global $all stream in forward order.+readAllForwardStmt :: Statement (Int64, Int32) (Vector RecordedEvent)+readAllForwardStmt =+    preparable+        readAllForwardSQL+        readAllEncoder+        (D.rowVector recordedEventRow)++-- | Read events from the global $all stream in backward order.+readAllBackwardStmt :: Statement (Int64, Int32) (Vector RecordedEvent)+readAllBackwardStmt =+    preparable+        readAllBackwardSQL+        readAllEncoder+        (D.rowVector recordedEventRow)++-- | Read the current tail of the global $all stream.+currentGlobalPositionStmt :: Statement () Int64+currentGlobalPositionStmt =+    preparable+        "SELECT stream_version FROM streams WHERE stream_id = 0"+        E.noParams+        (D.singleRow (D.column (D.nonNullable D.int8)))++-- | Get stream metadata by name.+getStreamStmt :: Statement Text (Maybe StreamInfo)+getStreamStmt =+    preparable+        getStreamSQL+        (E.param (E.nonNullable E.text))+        (D.rowMaybe streamInfoRow)++-- ---------------------------------------------------------------------------+-- Read SQL Templates+-- ---------------------------------------------------------------------------++{- | Read from a named stream in forward order.+Resolves stream name to ID via subquery, joins stream_events with events,+filters on stream_version > start_version, orders ascending, limits.+For stream reads, global_position is set to 0 (not available without $all join).+-}+readStreamForwardSQL :: Text+readStreamForwardSQL =+    """+    SELECT e.event_id, e.event_type,+           se.stream_version, 0::bigint AS global_position,+           se.original_stream_id, se.original_stream_version,+           e.data, e.metadata, e.causation_id, e.correlation_id,+           e.created_at+    FROM stream_events se+    JOIN events e ON e.event_id = se.event_id+    WHERE se.stream_id = (SELECT stream_id FROM streams WHERE stream_name = $1 AND deleted_at IS NULL)+      AND se.stream_version > $2+    ORDER BY se.stream_version ASC+    LIMIT $3+    """++-- | Read from a named stream in backward order.+readStreamBackwardSQL :: Text+readStreamBackwardSQL =+    """+    SELECT e.event_id, e.event_type,+           se.stream_version, 0::bigint AS global_position,+           se.original_stream_id, se.original_stream_version,+           e.data, e.metadata, e.causation_id, e.correlation_id,+           e.created_at+    FROM stream_events se+    JOIN events e ON e.event_id = se.event_id+    WHERE se.stream_id = (SELECT stream_id FROM streams WHERE stream_name = $1 AND deleted_at IS NULL)+      AND se.stream_version > $2+    ORDER BY se.stream_version DESC+    LIMIT $3+    """++{- | Read from the global $all stream in forward order.+stream_id = 0 is the $all stream. stream_version on $all is the global position.+-}+readAllForwardSQL :: Text+readAllForwardSQL =+    """+    SELECT e.event_id, e.event_type,+           se.stream_version, se.stream_version AS global_position,+           se.original_stream_id, se.original_stream_version,+           e.data, e.metadata, e.causation_id, e.correlation_id,+           e.created_at+    FROM stream_events se+    JOIN events e ON e.event_id = se.event_id+    WHERE se.stream_id = 0+      AND se.stream_version > $1+    ORDER BY se.stream_version ASC+    LIMIT $2+    """++-- | Read from the global $all stream in backward order.+readAllBackwardSQL :: Text+readAllBackwardSQL =+    """+    SELECT e.event_id, e.event_type,+           se.stream_version, se.stream_version AS global_position,+           se.original_stream_id, se.original_stream_version,+           e.data, e.metadata, e.causation_id, e.correlation_id,+           e.created_at+    FROM stream_events se+    JOIN events e ON e.event_id = se.event_id+    WHERE se.stream_id = 0+      AND se.stream_version > $1+    ORDER BY se.stream_version DESC+    LIMIT $2+    """++-- | Get stream metadata by name.+getStreamSQL :: Text+getStreamSQL =+    """+    SELECT stream_id, stream_name, stream_version, created_at, deleted_at+    FROM streams+    WHERE stream_name = $1+    """++-- ---------------------------------------------------------------------------+-- Causation / Correlation Statements+-- ---------------------------------------------------------------------------++{- | Return every event whose @correlation_id@ equals the input, in ascending+@global_position@ order. Uses the @ix_events_correlation_id@ partial index.++The @stream_events se ON se.stream_id = 0@ join resolves each event to its+single row in the global @$all@ stream, which is also where the global+position is materialized as @stream_version@.+-}+findByCorrelationStmt :: Statement UUID (Vector RecordedEvent)+findByCorrelationStmt =+    preparable+        findByCorrelationSQL+        (E.param (E.nonNullable E.uuid))+        (D.rowVector recordedEventRow)++findByCorrelationSQL :: Text+findByCorrelationSQL =+    """+    SELECT e.event_id, e.event_type,+           se.stream_version, se.stream_version AS global_position,+           se.original_stream_id, se.original_stream_version,+           e.data, e.metadata, e.causation_id, e.correlation_id,+           e.created_at+    FROM events e+    JOIN stream_events se+      ON se.event_id = e.event_id AND se.stream_id = 0+    WHERE e.correlation_id = $1+    ORDER BY se.stream_version ASC+    """++{- | Walk the causation graph forward from a seed event, returning the seed+itself and every event whose @causation_id@ chain leads back to it. The+result is ordered by ascending @global_position@.++The recursive CTE follows @causation_id@ links downstream: each child's+@causation_id@ equals a parent's @event_id@. Cost is @O(depth * log n)@+backed by the @ix_events_causation_id@ partial index.+-}+findCausationDescendantsStmt :: Statement UUID (Vector RecordedEvent)+findCausationDescendantsStmt =+    preparable+        findCausationDescendantsSQL+        (E.param (E.nonNullable E.uuid))+        (D.rowVector recordedEventRow)++findCausationDescendantsSQL :: Text+findCausationDescendantsSQL =+    """+    WITH RECURSIVE chain (event_id, depth) AS (+        SELECT event_id, 0+        FROM events+        WHERE event_id = $1+      UNION ALL+        SELECT e.event_id, c.depth + 1+        FROM events e+        JOIN chain c ON e.causation_id = c.event_id+    )+    SELECT e.event_id, e.event_type,+           se.stream_version, se.stream_version AS global_position,+           se.original_stream_id, se.original_stream_version,+           e.data, e.metadata, e.causation_id, e.correlation_id,+           e.created_at+    FROM chain c+    JOIN events e ON e.event_id = c.event_id+    JOIN stream_events se+      ON se.event_id = e.event_id AND se.stream_id = 0+    ORDER BY se.stream_version ASC+    """++{- | Walk the causation graph backward from a seed event, returning the seed+itself and every ancestor reachable via @causation_id@. Result is ordered+by ascending @depth@ (the seed is depth 0, its immediate cause is depth 1,+etc.).++The recursive CTE follows @causation_id@ links upstream: for each row+@current@ already in the working set, its parent is the row of @events@+whose @event_id@ equals @current.causation_id@.+-}+findCausationAncestorsStmt :: Statement UUID (Vector RecordedEvent)+findCausationAncestorsStmt =+    preparable+        findCausationAncestorsSQL+        (E.param (E.nonNullable E.uuid))+        (D.rowVector recordedEventRow)++findCausationAncestorsSQL :: Text+findCausationAncestorsSQL =+    """+    WITH RECURSIVE chain (event_id, depth) AS (+        SELECT event_id, 0+        FROM events+        WHERE event_id = $1+      UNION ALL+        SELECT parent.event_id, c.depth + 1+        FROM events parent+        JOIN events current ON parent.event_id = current.causation_id+        JOIN chain c ON c.event_id = current.event_id+    )+    SELECT e.event_id, e.event_type,+           se.stream_version, se.stream_version AS global_position,+           se.original_stream_id, se.original_stream_version,+           e.data, e.metadata, e.causation_id, e.correlation_id,+           e.created_at+    FROM chain c+    JOIN events e ON e.event_id = c.event_id+    JOIN stream_events se+      ON se.event_id = e.event_id AND se.stream_id = 0+    ORDER BY c.depth ASC+    """++-- ---------------------------------------------------------------------------+-- Link Statements+-- ---------------------------------------------------------------------------++{- | Link existing events into a target stream (upsert semantics).+Returns @Nothing@ when the target stream exists and is soft-deleted (the+@DO UPDATE WHERE streams.deleted_at IS NULL@ filter rejects the upsert,+so the stream_upsert CTE produces no rows). The interpreter maps @Nothing@+to @StreamNotFound@ for symmetry with @appendAnyVersion@'s soft-deleted+behavior added in EP-1 F2.+-}+linkToStreamStmt :: Statement (Vector UUID, Text) (Maybe LinkResult)+linkToStreamStmt =+    preparable+        linkToStreamSQL+        linkEncoder+        linkResultDecoder++linkEncoder :: E.Params (Vector UUID, Text)+linkEncoder =+    contrazip2+        (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+        (E.param (E.nonNullable E.text))++linkResultDecoder :: D.Result (Maybe LinkResult)+linkResultDecoder =+    D.rowMaybe $+        LinkResult+            <$> (StreamId <$> D.column (D.nonNullable D.int8))+            <*> (StreamVersion <$> D.column (D.nonNullable D.int8))++linkToStreamSQL :: Text+linkToStreamSQL =+    """+    WITH+      event_list AS (+        SELECT event_id, idx+        FROM unnest($1::uuid[]) WITH ORDINALITY AS t(event_id, idx)+      ),+      stream_upsert AS (+        INSERT INTO streams (stream_name, stream_version)+        VALUES ($2, (SELECT count(*) FROM event_list))+        ON CONFLICT (stream_name)+        DO UPDATE SET stream_version = streams.stream_version + (SELECT count(*) FROM event_list)+          WHERE streams.deleted_at IS NULL+        RETURNING stream_id, stream_version - (SELECT count(*) FROM event_list) AS initial_version+      ),+      link_inserts AS (+        -- LEFT JOIN LATERAL surfaces missing-event rows as NULLs for original_*; the+        -- NOT NULL constraint on stream_events.original_stream_id then aborts the+        -- entire CTE, rolling back the stream_upsert's version bump. Before the F3+        -- fix this was a plain JOIN LATERAL, which silently dropped missing-event+        -- rows while still bumping stream_version → silent gap in the link target.+        INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+        SELECT el.event_id, su.stream_id, su.initial_version + el.idx,+               orig.original_stream_id, orig.original_stream_version+        FROM event_list el+        CROSS JOIN stream_upsert su+        LEFT JOIN LATERAL (+          SELECT se.original_stream_id, se.original_stream_version+          FROM stream_events se+          WHERE se.event_id = el.event_id AND se.stream_id <> 0+          LIMIT 1+        ) orig ON true+      )+    SELECT su.stream_id, su.initial_version + (SELECT count(*) FROM event_list)+    FROM stream_upsert su+    """++-- ---------------------------------------------------------------------------+-- Category Read Statements+-- ---------------------------------------------------------------------------++-- | Read events from streams matching a category, in global position order.+readCategoryForwardStmt :: Statement (Int64, Text, Int32) (Vector RecordedEvent)+readCategoryForwardStmt =+    preparable+        readCategoryForwardSQL+        readCategoryEncoder+        (D.rowVector recordedEventRow)++readCategoryEncoder :: E.Params (Int64, Text, Int32)+readCategoryEncoder =+    contrazip3+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))++readCategoryForwardSQL :: Text+readCategoryForwardSQL =+    """+    SELECT e.event_id, e.event_type,+           se.stream_version, se.stream_version AS global_position,+           se.original_stream_id, se.original_stream_version,+           e.data, e.metadata, e.causation_id, e.correlation_id,+           e.created_at+    FROM streams s+    JOIN LATERAL (+      SELECT se.*+      FROM stream_events se+      WHERE se.stream_id = 0+        AND se.original_stream_id = s.stream_id+        AND se.stream_version > $1+      ORDER BY se.stream_version ASC+      LIMIT $3+    ) se ON true+    JOIN events e ON e.event_id = se.event_id+    WHERE s.category = $2+    ORDER BY se.stream_version ASC+    LIMIT $3+    """++-- ---------------------------------------------------------------------------+-- Consumer-Group Read Statements+-- ---------------------------------------------------------------------------++{- | Partition-filtered category read for one consumer-group member.++Mirrors 'readCategoryForwardStmt' but returns only events whose originating+stream is assigned to member @$3@ of a group of size @$4@. The assignment rule+(MasterPlan IP-1) hashes the originating stream's surrogate id and folds the+signed result into @[0, size)@:++@member_of(stream_id) = (((hashtextextended(stream_id::text, 0) % size) + size) % size)@++The predicate is applied to @s.stream_id@ in the outer @WHERE@ so whole+unassigned streams are pruned before the lateral join. Params:+@(startPosition, category, member, size, limit)@.+-}+readCategoryForwardConsumerGroupStmt ::+    Statement (Int64, Text, Int32, Int32, Int32) (Vector RecordedEvent)+readCategoryForwardConsumerGroupStmt =+    preparable+        readCategoryForwardConsumerGroupSQL+        readCategoryConsumerGroupEncoder+        (D.rowVector recordedEventRow)++readCategoryConsumerGroupEncoder :: E.Params (Int64, Text, Int32, Int32, Int32)+readCategoryConsumerGroupEncoder =+    contrazip5+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.int4))++readCategoryForwardConsumerGroupSQL :: Text+readCategoryForwardConsumerGroupSQL =+    """+    SELECT e.event_id, e.event_type,+           se.stream_version, se.stream_version AS global_position,+           se.original_stream_id, se.original_stream_version,+           e.data, e.metadata, e.causation_id, e.correlation_id,+           e.created_at+    FROM streams s+    JOIN LATERAL (+      SELECT se.*+      FROM stream_events se+      WHERE se.stream_id = 0+        AND se.original_stream_id = s.stream_id+        AND se.stream_version > $1+      ORDER BY se.stream_version ASC+      LIMIT $5+    ) se ON true+    JOIN events e ON e.event_id = se.event_id+    WHERE s.category = $2+      AND (((hashtextextended(s.stream_id::text, 0) % $4) + $4) % $4) = $3+    ORDER BY se.stream_version ASC+    LIMIT $5+    """++{- | Partition-filtered @$all@ read for one consumer-group member.++Mirrors 'readAllForwardStmt' but returns only events whose originating stream is+assigned to member @$2@ of a group of size @$3@, using the same MasterPlan IP-1+rule as 'readCategoryForwardConsumerGroupStmt'. The predicate is applied to+@se.original_stream_id@ — the real originating stream of each @$all@ junction row+(never the reserved id 0 for normal appends). Params:+@(startPosition, member, size, limit)@.+-}+readAllForwardConsumerGroupStmt ::+    Statement (Int64, Int32, Int32, Int32) (Vector RecordedEvent)+readAllForwardConsumerGroupStmt =+    preparable+        readAllForwardConsumerGroupSQL+        readAllConsumerGroupEncoder+        (D.rowVector recordedEventRow)++readAllConsumerGroupEncoder :: E.Params (Int64, Int32, Int32, Int32)+readAllConsumerGroupEncoder =+    contrazip4+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nonNullable E.int4))++readAllForwardConsumerGroupSQL :: Text+readAllForwardConsumerGroupSQL =+    """+    SELECT e.event_id, e.event_type,+           se.stream_version, se.stream_version AS global_position,+           se.original_stream_id, se.original_stream_version,+           e.data, e.metadata, e.causation_id, e.correlation_id,+           e.created_at+    FROM stream_events se+    JOIN events e ON e.event_id = se.event_id+    WHERE se.stream_id = 0+      AND se.stream_version > $1+      AND (((hashtextextended(se.original_stream_id::text, 0) % $3) + $3) % $3) = $2+    ORDER BY se.stream_version ASC+    LIMIT $4+    """++-- ---------------------------------------------------------------------------+-- Lifecycle Statements+-- ---------------------------------------------------------------------------++-- | Soft-delete a stream by setting deleted_at. Returns Nothing if stream doesn't exist or is already deleted.+softDeleteStreamStmt :: Statement Text (Maybe StreamId)+softDeleteStreamStmt =+    preparable+        softDeleteStreamSQL+        (E.param (E.nonNullable E.text))+        (D.rowMaybe (StreamId <$> D.column (D.nonNullable D.int8)))++-- | Undelete a soft-deleted stream by clearing deleted_at. Returns Nothing if stream doesn't exist or is not deleted.+undeleteStreamStmt :: Statement Text (Maybe StreamId)+undeleteStreamStmt =+    preparable+        undeleteStreamSQL+        (E.param (E.nonNullable E.text))+        (D.rowMaybe (StreamId <$> D.column (D.nonNullable D.int8)))++{- | Look up a stream's id by name. Returns Nothing if the stream does not exist.+Used as the first step in hard-delete; subsequent steps key off the id rather+than the name so a single resolution is reused.+-}+findStreamIdStmt :: Statement Text (Maybe Int64)+findStreamIdStmt =+    preparable+        "SELECT stream_id FROM streams WHERE stream_name = $1"+        (E.param (E.nonNullable E.text))+        (D.rowMaybe (D.column (D.nonNullable D.int8)))++{- | Resolve a batch of surrogate stream ids to their (id, name) pairs in one+round trip. Ids that do not name an existing stream simply produce no row, so+the caller's 'Data.Map.Strict.Map' omits them. Surfaced as+'Kiroku.Store.Read.lookupStreamNames'.+-}+lookupStreamNamesStmt :: Statement [Int64] (Vector (Int64, Text))+lookupStreamNamesStmt =+    preparable+        "SELECT stream_id, stream_name FROM streams WHERE stream_id = ANY($1::bigint[])"+        (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.int8))))+        ( D.rowVector+            ( (,)+                <$> D.column (D.nonNullable D.int8)+                <*> D.column (D.nonNullable D.text)+            )+        )++{- | Delete every junction row that references the given stream — both rows whose+@stream_id@ is the target (the stream's own and any links from elsewhere) and+rows whose @original_stream_id@ is the target ($all entries plus link rows in+other streams that referenced events originating from the deleted stream).++Returns the distinct set of @event_id@s that lost at least one junction row.+The caller passes this set to @deleteOrphanedEventsStmt@ to remove event payloads+that no longer have any surviving junctions.++The previous single-CTE implementation tried to inline the orphan-event delete,+but PostgreSQL §7.8.2 specifies that data-modifying CTEs run against the same+snapshot, so the @NOT EXISTS@ subquery on stream_events saw the pre-delete state+and never deleted any events. Splitting into two statements within the same+hasql-transaction lets each statement see the previous statement's effects.+-}+deleteStreamJunctionsStmt :: Statement Int64 (Vector UUID)+deleteStreamJunctionsStmt =+    preparable+        """+        WITH deleted AS (+          DELETE FROM stream_events+          WHERE stream_id = $1+             OR original_stream_id = $1+          RETURNING event_id+        )+        SELECT DISTINCT event_id FROM deleted+        """+        (E.param (E.nonNullable E.int8))+        (D.rowVector (D.column (D.nonNullable D.uuid)))++{- | Delete event payloads from the @events@ table for the given event ids,+but only those whose junction rows have all been removed. Events that still+have any surviving @stream_events@ row are preserved (they remain visible from+their other homes).++Must be called after @deleteStreamJunctionsStmt@ within the same transaction+so the @NOT EXISTS@ subquery sees the post-delete state of @stream_events@.+-}+deleteOrphanedEventsStmt :: Statement (Vector UUID) ()+deleteOrphanedEventsStmt =+    preparable+        """+        DELETE FROM events+        WHERE event_id = ANY($1::uuid[])+          AND NOT EXISTS (+            SELECT 1 FROM stream_events+            WHERE stream_events.event_id = events.event_id+          )+        """+        (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+        D.noResult++{- | Delete the @streams@ row for the given stream id. Used as the final step+of hard-delete after junction rows and orphan events are cleared.+-}+deleteStreamRowStmt :: Statement Int64 ()+deleteStreamRowStmt =+    preparable+        "DELETE FROM streams WHERE stream_id = $1"+        (E.param (E.nonNullable E.int8))+        D.noResult++{- | Pre-acquire row locks on the named streams in deterministic (stream_id)+order. Used by AppendMultiStream to avoid row-lock deadlocks between+concurrent multi-stream transactions that touch overlapping streams in+different orders.++Streams that don't yet exist (NoStream variant on a fresh stream) are not+matched by the WHERE clause, so they aren't pre-locked here; concurrent+INSERTs of a fresh stream serialize on the unique index on @stream_name@.+\$all is intentionally NOT included in the pre-lock — its row lock is+acquired by each per-stream CTE inside the transaction, after the source+stream's row lock, so deadlocks between multi-stream and single-stream+transactions are avoided as long as both lock kinds in the same order+(source-first, then $all). See EP-1 F4.+-}+lockStreamsForMultiStmt :: Statement (Vector Text) ()+lockStreamsForMultiStmt =+    preparable+        """+        SELECT 1 FROM streams+        WHERE stream_name = ANY($1::text[])+        ORDER BY stream_id+        FOR UPDATE+        """+        (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+        D.noResult++-- ---------------------------------------------------------------------------+-- Lifecycle SQL Templates+-- ---------------------------------------------------------------------------++softDeleteStreamSQL :: Text+softDeleteStreamSQL =+    """+    UPDATE streams+    SET deleted_at = now()+    WHERE stream_name = $1+      AND deleted_at IS NULL+    RETURNING stream_id+    """++undeleteStreamSQL :: Text+undeleteStreamSQL =+    """+    UPDATE streams+    SET deleted_at = NULL+    WHERE stream_name = $1+      AND deleted_at IS NOT NULL+    RETURNING stream_id+    """++-- ---------------------------------------------------------------------------+-- Checkpoint Statements+-- ---------------------------------------------------------------------------++-- | Read the last-seen global position for a subscription.+getCheckpointStmt :: Statement Text (Maybe Int64)+getCheckpointStmt =+    preparable+        getCheckpointSQL+        (E.param (E.nonNullable E.text))+        (D.rowMaybe (D.column (D.nonNullable D.int8)))++-- | Upsert a checkpoint: insert or update the last-seen position.+saveCheckpointStmt :: Statement (Text, Int64) ()+saveCheckpointStmt =+    preparable+        saveCheckpointSQL+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int8))+        )+        D.noResult++getCheckpointSQL :: Text+getCheckpointSQL =+    """+    SELECT last_seen+    FROM subscriptions+    WHERE subscription_name = $1+    """++saveCheckpointSQL :: Text+saveCheckpointSQL =+    """+    INSERT INTO subscriptions (subscription_name, last_seen, updated_at)+    VALUES ($1, $2, now())+    ON CONFLICT (subscription_name, consumer_group_member)+    DO UPDATE SET last_seen = GREATEST(subscriptions.last_seen, EXCLUDED.last_seen), updated_at = now()+    """++-- | Read the last-seen position for one consumer-group member of a subscription.+getCheckpointMemberStmt :: Statement (Text, Int32) (Maybe Int64)+getCheckpointMemberStmt =+    preparable+        getCheckpointMemberSQL+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+        )+        (D.rowMaybe (D.column (D.nonNullable D.int8)))++{- | Upsert the last-seen position for one consumer-group member, keyed on the+composite @(subscription_name, consumer_group_member)@ unique index. Uses the+same @GREATEST(...)@ monotonicity as 'saveCheckpointStmt' so a save never moves+a member's checkpoint backward.+-}+saveCheckpointMemberStmt :: Statement (Text, Int32, Int64) ()+saveCheckpointMemberStmt =+    preparable+        saveCheckpointMemberSQL+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+            (E.param (E.nonNullable E.int8))+        )+        D.noResult++getCheckpointMemberSQL :: Text+getCheckpointMemberSQL =+    """+    SELECT last_seen+    FROM subscriptions+    WHERE subscription_name = $1+      AND consumer_group_member = $2+    """++saveCheckpointMemberSQL :: Text+saveCheckpointMemberSQL =+    """+    INSERT INTO subscriptions (subscription_name, consumer_group_member, last_seen, updated_at)+    VALUES ($1, $2, $3, now())+    ON CONFLICT (subscription_name, consumer_group_member)+    DO UPDATE SET last_seen = GREATEST(subscriptions.last_seen, EXCLUDED.last_seen), updated_at = now()+    """++-- ---------------------------------------------------------------------------+-- Dead-letter Statements+-- ---------------------------------------------------------------------------++-- | Parameters for 'insertDeadLetterAndCheckpointStmt'.+data DeadLetterParams = DeadLetterParams+    { dlSubscriptionName :: !Text+    , dlMember :: !Int32+    , dlGlobalPosition :: !Int64+    , dlEventId :: !UUID+    , dlReason :: !Value+    -- ^ structured JSONB reason (@reason@ column)+    , dlReasonSummary :: !Text+    -- ^ operator-facing summary (@reason_summary@ column)+    , dlAttemptCount :: !Int32+    }+    deriving stock (Show, Generic)++-- | A row of @kiroku.dead_letters@, returned by 'readDeadLettersStmt'.+data DeadLetterRecord = DeadLetterRecord+    { deadLetterGlobalPosition :: !Int64+    , deadLetterEventId :: !UUID+    , deadLetterReason :: !Value+    , deadLetterReasonSummary :: !Text+    , deadLetterAttemptCount :: !Int32+    , deadLetterCreatedAt :: !UTCTime+    }+    deriving stock (Show, Generic)++deadLetterParamsEncoder :: E.Params DeadLetterParams+deadLetterParamsEncoder =+    ((^. #dlSubscriptionName) >$< E.param (E.nonNullable E.text))+        <> ((^. #dlMember) >$< E.param (E.nonNullable E.int4))+        <> ((^. #dlGlobalPosition) >$< E.param (E.nonNullable E.int8))+        <> ((^. #dlEventId) >$< E.param (E.nonNullable E.uuid))+        <> ((^. #dlReason) >$< E.param (E.nonNullable E.jsonb))+        <> ((^. #dlReasonSummary) >$< E.param (E.nonNullable E.text))+        <> ((^. #dlAttemptCount) >$< E.param (E.nonNullable E.int4))++{- | Atomically record an event in @kiroku.dead_letters@ and advance the+subscription's checkpoint past it, in a single statement.++The dead-letter insert and the checkpoint upsert run in one round trip: a+data-modifying CTE performs the insert (idempotent via @ON CONFLICT DO NOTHING@+on the natural key), and the final statement upserts the checkpoint with the+same @GREATEST(...)@ monotonicity as 'saveCheckpointMemberStmt'. If the insert+fails the whole statement aborts and the checkpoint does not advance, satisfying+the dead-letter atomicity criterion. The checkpoint reuses @$1@/@$2@/@$3@+(name / member / global_position) from the dead-letter params.+-}+insertDeadLetterAndCheckpointStmt :: Statement DeadLetterParams ()+insertDeadLetterAndCheckpointStmt =+    preparable+        insertDeadLetterAndCheckpointSQL+        deadLetterParamsEncoder+        D.noResult++insertDeadLetterAndCheckpointSQL :: Text+insertDeadLetterAndCheckpointSQL =+    """+    WITH dl AS (+      INSERT INTO dead_letters+        (subscription_name, consumer_group_member, global_position, event_id, reason, reason_summary, attempt_count)+      VALUES ($1, $2, $3, $4, $5, $6, $7)+      ON CONFLICT (subscription_name, consumer_group_member, global_position, event_id) DO NOTHING+    )+    INSERT INTO subscriptions (subscription_name, consumer_group_member, last_seen, updated_at)+    VALUES ($1, $2, $3, now())+    ON CONFLICT (subscription_name, consumer_group_member)+    DO UPDATE SET last_seen = GREATEST(subscriptions.last_seen, EXCLUDED.last_seen), updated_at = now()+    """++-- | Read the dead letters recorded for one subscription member, newest first.+readDeadLettersStmt :: Statement (Text, Int32) (Vector DeadLetterRecord)+readDeadLettersStmt =+    preparable+        readDeadLettersSQL+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+        )+        (D.rowVector deadLetterRecordRow)++deadLetterRecordRow :: D.Row DeadLetterRecord+deadLetterRecordRow =+    DeadLetterRecord+        <$> D.column (D.nonNullable D.int8)+        <*> D.column (D.nonNullable D.uuid)+        <*> D.column (D.nonNullable D.jsonb)+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.int4)+        <*> D.column (D.nonNullable D.timestamptz)++readDeadLettersSQL :: Text+readDeadLettersSQL =+    """+    SELECT global_position, event_id, reason, reason_summary, attempt_count, created_at+    FROM dead_letters+    WHERE subscription_name = $1+      AND consumer_group_member = $2+    ORDER BY global_position DESC, dead_letter_id DESC+    """
+ src/Kiroku/Store/Settings.hs view
@@ -0,0 +1,97 @@+{- | Interpreter-level hooks applied to 'EventData' before encoding on+the append path and to 'RecordedEvent' after decoding on the read and+subscription paths.++The hook seam lives inside 'Kiroku.Store.Effect.runStorePool' (and the+subscription publisher\/worker) rather than at the SQL encoder\/decoder+layer so the hook sees the typed value — payload and metadata as+'Data.Aeson.Value', the event type, ids — and can branch on event type+or mutate structured JSON. Plumbing it at the encoder layer would force+hooks to operate on opaque bytes.++Both fields default to 'Nothing'. With the defaults, the helpers below+take a 'pure' fast path that allocates nothing extra; no traversal of+the events list or vector occurs.++A typical use case is enriching every appended event with an+OpenTelemetry trace context drawn from the calling thread:++@+storeSettings = 'defaultStoreSettings'+  { 'enrichEvent' = Just $ \\ed -> do+      ctx <- captureCurrentSpan        -- OpenTelemetry, OTLP, whatever+      pure (ed & #metadata %~ injectTraceContext ctx)+  , 'decodeHook' = Just $ \\re ->+      pure (re & #metadata %~ Just . redactPII)+  }+@++Wire the resulting 'StoreSettings' into+'Kiroku.Store.Connection.ConnectionSettings' via its @storeSettings@+field; 'Kiroku.Store.Connection.withStore' copies it onto the+'Kiroku.Store.Connection.KirokuStore' handle for the interpreter to+reach.++Direct callers of 'Kiroku.Store.Transaction.appendToStreamTx' bypass+'runStorePool' and therefore the 'enrichEvent' hook. Use+'Kiroku.Store.Transaction.enrichEventsIO' to opt in to enrichment+manually before constructing the prepared event list.+-}+module Kiroku.Store.Settings (+    StoreSettings (..),+    defaultStoreSettings,+    enrichEvents,+    decodeEvents,+) where++import Data.Vector (Vector)+import Data.Vector qualified as V+import GHC.Generics (Generic)+import Kiroku.Store.Types (EventData, RecordedEvent)++{- | Interpreter-level hooks for cross-cutting concerns at the+event-data boundary. All fields default to 'Nothing' (no-op).++* 'enrichEvent' fires on the append path before the SQL encoder runs,+  on the typed 'EventData' the caller supplied. Used to inject trace+  contexts, attach tenant ids, or encrypt payloads.++* 'decodeHook' fires on the read and subscription paths after the SQL+  decoder runs, on the typed 'RecordedEvent' about to be surfaced to+  the caller. Used to decrypt payloads, redact PII, or attach derived+  metadata.++When a field is 'Nothing', the interpreter takes a @pure@ fast path+that does not allocate or traverse.+-}+data StoreSettings = StoreSettings+    { enrichEvent :: !(Maybe (EventData -> IO EventData))+    -- ^ Append-path hook. Runs once per appended event before encoding.+    , decodeHook :: !(Maybe (RecordedEvent -> IO RecordedEvent))+    -- ^ Read- and subscription-path hook. Runs once per surfaced event.+    }+    deriving stock (Generic)++-- | Defaults to both hooks being 'Nothing' — semantically a no-op.+defaultStoreSettings :: StoreSettings+defaultStoreSettings =+    StoreSettings+        { enrichEvent = Nothing+        , decodeHook = Nothing+        }++{- | Apply 'enrichEvent' to a list of events. When the hook is+'Nothing', returns the list unchanged with no traversal.+-}+enrichEvents :: StoreSettings -> [EventData] -> IO [EventData]+enrichEvents ss xs = case enrichEvent ss of+    Nothing -> pure xs+    Just f -> traverse f xs++{- | Apply 'decodeHook' to a vector of events. When the hook is+'Nothing', returns the vector unchanged with no traversal.+-}+decodeEvents :: StoreSettings -> Vector RecordedEvent -> IO (Vector RecordedEvent)+decodeEvents ss xs = case decodeHook ss of+    Nothing -> pure xs+    Just f -> V.mapM f xs
+ src/Kiroku/Store/Subscription.hs view
@@ -0,0 +1,258 @@+module Kiroku.Store.Subscription (+    -- * Subscribe+    subscribe,+    withSubscription,++    -- * Observability+    subscriptionStates,+    SubscriptionStateView (..),++    -- * Types+    module Kiroku.Store.Subscription.Types,+) where++import Control.Concurrent.Async qualified as Async+import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVarIO)+import Control.Exception (bracket, finally, throwIO)+import Control.Lens ((^.))+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Data.Foldable (for_)+import Data.Generics.Labels ()+import Data.Int (Int32)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Unique (newUnique)+import GHC.Generics (Generic)+import Kiroku.Store.Connection (KirokuStore (..))+import Kiroku.Store.Notification qualified as Notifier+import Kiroku.Store.Subscription.EventPublisher qualified as Pub+import Kiroku.Store.Subscription.Fsm (SubscriptionState (..), stateCursor, stateName)+import Kiroku.Store.Subscription.Types+import Kiroku.Store.Subscription.Worker (configMember, runWorker)+import Kiroku.Store.Types (GlobalPosition (..))++{- | Start a subscription. Returns a handle for cancellation and waiting.++The subscription spawns a worker thread that:++1. Reads the checkpoint from the database (or starts from global position 0+   for a fresh subscription name).+2. Catches up by querying the database directly until it reaches the+   'Kiroku.Store.Subscription.EventPublisher.lastPublished' cursor.+3. Switches to live mode. For 'Kiroku.Store.Subscription.Types.AllStreams'+   subscriptions, the worker reads pre-broadcast events from the+   publisher's bounded per-subscriber queue. For+   'Kiroku.Store.Subscription.Types.Category' subscriptions, the worker+   bypasses the broadcast entirely and re-queries the database with the+   SQL category filter whenever 'lastPublished' advances.++The returned 'SubscriptionHandle' carries an implicit lifecycle contract:+the worker thread runs until 'cancel' is called or the handler returns 'Stop'.+Forgetting to cancel leaks the thread. Prefer 'withSubscription' for any+non-trivial code path; use the bare 'subscribe' only when the caller already+has a structured lifecycle (e.g., the Streamly 'subscriptionStream' bridge).++=== Delivery semantics++Events are delivered __at least once__. The store's checkpoint is advanced+__per batch__, not per event: when the handler returns 'Continue' for every+event in a batch the checkpoint is saved at the batch tail; when the handler+returns 'Stop' for some event the checkpoint is saved at that event. The+following events on the boundary therefore __replay__ on the next+subscription with the same 'Kiroku.Store.Subscription.Types.SubscriptionName':++* The handler returned 'Continue' but the worker was cancelled or the+  process crashed before 'saveCheckpoint' completed. The events processed+  by the handler are re-delivered.+* The handler was interrupted between events (cancellation, crash) inside+  one batch. The events already processed are re-delivered along with the+  not-yet-processed ones.+* The publisher could not reach the database for one cycle (transient+  pool error). The next cycle re-fetches and re-broadcasts; subscribers+  that had already exited catch-up may see those events delivered late+  with no checkpoint advance in between, so a subsequent restart replays+  them.++Handlers must therefore be idempotent — process a duplicate event without+producing a wrong-on-replay result — or be tolerant of duplicates by some+domain-specific check (e.g., a unique key on the projection table).++=== Failure modes++The 'Kiroku.Store.Subscription.Types.SubscriptionHandleM.wait' on the+returned handle resolves with one of:++* @Right ()@ — the handler returned 'Stop' for some event and the worker+  exited cleanly. The checkpoint is saved at that event.+* @Left e@ where @e@ is 'Control.Concurrent.Async.AsyncCancelled' — the+  caller invoked 'cancel'. No checkpoint advance is guaranteed; events+  in flight at cancellation time will replay.+* @Left e@ where @e@ is+  'Kiroku.Store.Subscription.Types.SubscriptionOverflowed' — the publisher+  marked this subscription overflowed under+  'Kiroku.Store.Subscription.Types.DropSubscription'. Investigate the+  slow handler and either fix the slowness, raise 'queueCapacity', or+  switch to 'Kiroku.Store.Subscription.Types.DropOldest' if the consumer+  can tolerate event loss.+* @Left e@ for any exception thrown by the handler — handler exceptions+  are not caught; the worker thread dies and the original exception+  propagates to the consumer. This is intentional: a handler that+  throws is signalling that the subscription cannot proceed safely.+-}+subscribe :: (MonadIO m) => KirokuStore -> SubscriptionConfig -> m SubscriptionHandle+subscribe store config = liftIO $ do+    -- Fail fast on a misconfigured group, before any thread is spawned. A bad+    -- (member, size) is a programmer error; throwing here keeps subscribe's+    -- non-Either signature intact for every existing caller (see EP-2 Decision Log).+    for_ (consumerGroup config) $ \(ConsumerGroup m n) ->+        when (n < 1 || m < 0 || m >= n) $+            throwIO (InvalidConsumerGroup m n)+    (queue, statusVar, unsubscribe) <-+        atomically $+            Pub.subscribePublisher+                (store ^. #publisher)+                (queueCapacity config)+                (overflowPolicy config)+    -- The worker writes its current FSM state here on every transition; the+    -- handle's 'currentState' reads it. Seeded with the catch-up entry state so+    -- a read before the worker's first transition is sensible.+    stateVar <- newTVarIO (CatchingUp (GlobalPosition 0) 0)+    let pubPosVar = Pub.lastPublished (store ^. #publisher)+        catGenVar = Notifier.categoryGenerations (store ^. #notifier)+    -- Register this worker's state cell into the store's central registry under+    -- (name, member). A fresh token identifies *this* worker so that an older+    -- worker's cleanup cannot delete a newer worker's replacement entry under+    -- the same key, and a held handle reads only the cell it registered.+    token <- newUnique+    let reg = store ^. #subscriptionRegistry+        key = (name config, configMember config)+        -- `finally unsubscribe` removes this subscription from the publisher's+        -- registry whenever the worker exits — gracefully on Stop, by+        -- cancellation, or on any exception (including SubscriptionOverflowed).+        -- Forgetting to unsubscribe would leave a registry entry with no+        -- reader, and the publisher would needlessly trigger this subscriber's+        -- overflow policy on the next batch. We extend the same `finally` to+        -- also deregister from the subscription-state registry on ANY exit, so+        -- the registry never leaks a stale entry. The delete is+        -- token-conditional so stale cleanup from an older duplicate-key worker+        -- cannot remove a newer worker's live entry.+        cleanup =+            unsubscribe+                >> atomically+                    ( modifyTVar' reg $+                        Map.update+                            ( \(tok', cell) ->+                                if tok' == token+                                    then Nothing+                                    else Just (tok', cell)+                            )+                            key+                    )+    -- Insert before forking so a caller that reads a snapshot immediately after+    -- `subscribe` returns already sees this subscription.+    atomically $ modifyTVar' reg (Map.insert key (token, stateVar))+    thread <-+        Async.async+            ( runWorker (store ^. #pool) queue statusVar stateVar pubPosVar catGenVar config (store ^. #eventHandler) (store ^. #storeSettings)+                `finally` cleanup+            )+    pure+        SubscriptionHandle+            { cancel = Async.cancel thread+            , wait = Async.waitCatch thread+            , currentState = do+                m <- readTVarIO reg+                case Map.lookup key m of+                    Just (tok, cell) | tok == token -> Just <$> readTVarIO cell+                    _ -> pure Nothing+            }++{- | Bracket-style subscription lifecycle.++Starts a subscription, runs the body, and ensures the underlying worker+thread is cancelled on either normal exit or an exception thrown inside+the body. This is the recommended way to use subscriptions: forgetting+to call 'cancel' on a 'SubscriptionHandle' leaks the worker thread for+the lifetime of the process.++Equivalent to:++    bracket (subscribe store config) cancel action++but lifted to any 'MonadUnliftIO' so it composes with effectful stacks+that already have an unlift in scope.+-}+withSubscription ::+    (MonadUnliftIO m) =>+    KirokuStore ->+    SubscriptionConfig ->+    (SubscriptionHandle -> m a) ->+    m a+withSubscription store config action = withRunInIO $ \runInIO ->+    bracket (subscribe store config) cancel (runInIO . action)++{- | A public, point-in-time view of one live subscription's state, as returned+by 'subscriptionStates'. This is the committed observability surface external+consumers (a future Prometheus exporter, an admin tool) read directly; it is+intentionally a flat view, not the internal 'SubscriptionState' cell type.++* 'subscriptionName' / 'member' identify the subscription (member 0 for a+  non-group subscription), matching the registry/checkpoint key.+* 'state' is the live 'SubscriptionState' read from the worker's registered cell.+* 'statePhase' is a stable, low-cardinality label (via+  'Kiroku.Store.Subscription.Fsm.stateName') suitable as a metric label value or+  admin column; it does not drift if a constructor's fields change.+* 'cursor' is the worker FSM cursor (via 'Kiroku.Store.Subscription.Fsm.stateCursor').+  It is the cheap live progress signal for observability, not a guaranteed+  durable checkpoint row.++Read fields via the codebase's @generic-lens@ convention, e.g. @view ^. #state@.+-}+data SubscriptionStateView = SubscriptionStateView+    { subscriptionName :: !SubscriptionName+    , member :: !Int32+    , state :: !SubscriptionState+    , statePhase :: !Text+    , cursor :: !GlobalPosition+    }+    deriving stock (Show, Generic)++{- | A near-instant snapshot of every live subscription as a public+'SubscriptionStateView', keyed by (subscription name, consumer-group member;+0 for non-group).++Snapshots the registry's outer map with 'readTVarIO', then reads each registered+state cell with 'readTVarIO' __outside__ STM. This is deliberately not one STM+transaction over all cells: a single transaction would put every subscription's+state cell in the reader's STM read set, and since each worker writes its cell+~once per batch, any such write would force the whole scan to re-run — a+reader-side cost that scales with subscription count. The named consumers (a+Prometheus scrape, an admin listing) read independent values and do not need a+globally atomic snapshot, so each entry is read as its own freshest value.++A subscription appears here from the moment 'subscribe' returns its handle until+its worker exits (stop, cancel, or crash), at which point its key is removed; a+stopped/cancelled/crashed subscription is represented by __absence__, never by a+@"stopped"@ phase (the FSM never writes 'Stopped' into the cell). This map of+view records is the committed surface the future Prometheus exporter and admin+tool consume.+-}+subscriptionStates :: KirokuStore -> IO (Map (SubscriptionName, Int32) SubscriptionStateView)+subscriptionStates store = do+    cells <- readTVarIO (store ^. #subscriptionRegistry)+    Map.traverseWithKey+        ( \(nm, mbr) (_tok, cell) -> do+            st <- readTVarIO cell+            pure+                SubscriptionStateView+                    { subscriptionName = nm+                    , member = mbr+                    , state = st+                    , statePhase = stateName st+                    , cursor = stateCursor st+                    }+        )+        cells
+ src/Kiroku/Store/Subscription/Effect.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE TypeFamilies #-}++module Kiroku.Store.Subscription.Effect (+    -- * The Subscription effect+    Subscription (..),++    -- * Convenience wrappers+    subscribe,+    withSubscription,++    -- * Interpreters+    runSubscription,+    runSubscriptionResource,+) where++import Control.Monad.IO.Class (liftIO)+import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..), (:>))+import Effectful.Dispatch.Dynamic (HasCallStack, interpret, localUnliftIO, send)+import Effectful.Exception (bracket)+import Kiroku.Store.Connection (KirokuStore)+import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore)+import Kiroku.Store.Subscription qualified as Sub+import Kiroku.Store.Subscription.Types (SubscriptionConfigM (..), SubscriptionHandle, SubscriptionHandleM (..))++-- ---------------------------------------------------------------------------+-- Subscription effect+-- ---------------------------------------------------------------------------++{- | The Subscription effect — subscribe to event streams.++This is a higher-order effect: the handler inside the config runs in the+caller's effect monad @m@, which is @Eff localEs@ at the call site.+-}+data Subscription :: Effect where+    Subscribe :: SubscriptionConfigM m -> Subscription m SubscriptionHandle++type instance DispatchOf Subscription = Dynamic++-- ---------------------------------------------------------------------------+-- Convenience wrapper+-- ---------------------------------------------------------------------------++{- | Subscribe to an event stream (effectful API).++The handler inside the config runs in @Eff es@, so it can use any effects+available in the caller's stack.++__Lifecycle note:__ The returned handle must be canceled before the effect+scope exits. The subscription thread captures the effect environment; if the+@Eff@ computation finishes while the thread is still running, the environment+becomes invalid. Prefer 'withSubscription' (also exported from this module)+which wraps subscribe/cancel in a @bracket@ and is exception-safe.++=== Delivery semantics++Identical to 'Kiroku.Store.Subscription.subscribe': events are delivered+__at least once__, the checkpoint is advanced __per batch__, and handlers+must be idempotent. See the Haddock on+'Kiroku.Store.Subscription.subscribe' for the full enumeration of replay+boundaries (cancel-after-Continue, mid-batch cancellation, transient+publisher pool errors) and the failure-mode table for+'Kiroku.Store.Subscription.Types.SubscriptionHandleM.wait'.++The effectful interpreter wraps the user's handler with the+@ConcUnlift Persistent (Limited 1)@ unlift strategy (see 'runSubscription').+This preserves the worker's single-threaded contract: only one handler+invocation is in flight at a time, and the effect environment outlives+all handler calls so 'Effectful.State.Static.Local.State' /+'Effectful.Reader.Static.Reader' contents remain consistent across the+subscription.+-}+subscribe :: (HasCallStack, Subscription :> es) => SubscriptionConfigM (Eff es) -> Eff es SubscriptionHandle+subscribe config = send (Subscribe config)++{- | Bracket-style subscription lifecycle for the effectful API.++Starts a subscription, runs the body, and cancels the worker on either+normal exit or an exception thrown inside the body. This is the+exception-safe form of 'subscribe' — the `Eff`-based 'subscribe' captures+the caller's effect environment in the worker thread, so a leaking thread+can refer to an environment that has already been torn down.++The body runs in @Eff es@; the underlying 'SubscriptionHandle' is IO-based,+so 'cancel' is invoked via 'liftIO'. 'Effectful.Exception.bracket' guarantees+the cancel runs even on async exceptions.+-}+withSubscription ::+    (HasCallStack, Subscription :> es, IOE :> es) =>+    SubscriptionConfigM (Eff es) ->+    (SubscriptionHandle -> Eff es a) ->+    Eff es a+withSubscription config = bracket (subscribe config) (liftIO . cancel)++-- ---------------------------------------------------------------------------+-- Interpreters+-- ---------------------------------------------------------------------------++{- | Interpret 'Subscription' by delegating to the @MonadIO@-based+'Kiroku.Store.Subscription.subscribe'.++The unlift strategy is @ConcUnlift Persistent (Limited 1)@:++* @Persistent@ — the effect environment must outlive each individual+  handler invocation. The worker thread calls the handler many times+  over its lifetime; an @Ephemeral@ unlift would reset the environment+  between calls and lose any 'Effectful.State.Static.Local.State' /+  'Effectful.Reader.Static.Reader' contents.+* @Limited 1@ — only one concurrent unlift is in flight at any time.+  The worker thread is single-threaded by construction (events are+  processed sequentially within a subscription), so a higher bound+  would be wasteful. A @Limited 0@ would prevent any unlift and break+  the handler entirely.++Do not relax these bounds without restructuring the worker.+-}+runSubscription ::+    (IOE :> es) =>+    KirokuStore ->+    Eff (Subscription : es) a ->+    Eff es a+runSubscription store = interpret $ \env -> \case+    Subscribe config ->+        localUnliftIO env (ConcUnlift Persistent (Limited 1)) $ \unlift -> do+            -- Record update intentionally: every field except 'handler' is preserved,+            -- including 'consumerGroup' and 'consumerGroupGuard' (added in EP-2). Do not+            -- switch to a full record literal here — that would silently reset new fields+            -- and drop a caller's consumer-group membership.+            let ioConfig = config{handler = \evt -> unlift (handler config evt)}+            Sub.subscribe store ioConfig++-- | Interpret Subscription by reading the store handle from 'KirokuStoreResource'.+runSubscriptionResource ::+    (IOE :> es, KirokuStoreResource :> es) =>+    Eff (Subscription : es) a ->+    Eff es a+runSubscriptionResource action = do+    store <- getKirokuStore+    runSubscription store action
+ src/Kiroku/Store/Subscription/EventPublisher.hs view
@@ -0,0 +1,291 @@+{- | The centralized @$all@ broadcaster shared by every all-stream subscription.++A single 'EventPublisher' reads new events from the global stream once and+fans them out to each registered 'Subscriber' through that subscriber's own+bounded 'Control.Concurrent.STM.TBQueue', rather than having every subscription+poll the database independently. 'startPublisher' launches the broadcast loop,+'subscribePublisher' registers a subscriber (returning its queue, a status+'TVar', and an unsubscribe action), 'publisherPosition' reports the last+broadcast cursor, and 'stopPublisher' tears the loop down.++When a subscriber's queue fills, the publisher applies that subscriber's+'Kiroku.Store.Subscription.Types.OverflowPolicy' by setting its+'SubscriberStatus': under the default @PauseAndResume@ it marks the subscriber+'Paused' and stops pushing (the worker drains and re-catches-up losslessly),+under @DropSubscription@ it marks it 'Overflowed', and under @DropOldest@ it+evicts the oldest batch. The publisher itself never blocks on a slow consumer.+-}+module Kiroku.Store.Subscription.EventPublisher (+    EventPublisher (..),+    Subscriber (..),+    SubscriberStatus (..),+    startPublisher,+    stopPublisher,+    subscribePublisher,+    publisherPosition,+) where++import Control.Concurrent.Async (Async)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.STM (+    STM,+    TBQueue,+    TChan,+    TVar,+    atomically,+    dupTChan,+    isFullTBQueue,+    modifyTVar',+    newTBQueue,+    newTVar,+    newTVarIO,+    readTChan,+    readTVar,+    readTVarIO,+    registerDelay,+    tryReadTBQueue,+    tryReadTChan,+    writeTBQueue,+    writeTVar,+ )+import Control.Concurrent.STM qualified as STM+import Control.Exception (throwIO)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Foldable (for_)+import Data.Int (Int32, Int64)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Vector (Vector)+import Data.Vector qualified as V+import Hasql.Pool (Pool)+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Kiroku.Store.Observability (KirokuEvent (..))+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Settings (StoreSettings, decodeEvents)+import Kiroku.Store.Subscription.Types (OverflowPolicy (..))+import Kiroku.Store.Types (GlobalPosition (..), RecordedEvent (..))+import Numeric.Natural (Natural)++{- | The centralized EventPublisher. Reads events from the database once per+notification and fans them out to a registry of bounded per-subscriber+queues. The registry replaces the prior unbounded broadcast 'TChan' so+that one slow subscriber cannot grow the publisher's fan-out memory+without limit (EP-3 F6).+-}+data EventPublisher = EventPublisher+    { subscribers :: !(TVar (IntMap Subscriber))+    -- ^ Active subscriber registry, keyed by an internal id.+    , nextSubscriberId :: !(TVar Int)+    , publisherThread :: !(Async ())+    , lastPublished :: !(TVar GlobalPosition)+    -- ^ Last-published position; workers read this to know when catch-up is done+    }++{- | A registered subscriber. The publisher owns one of these per+'Kiroku.Store.Subscription.subscribe' call. The worker reads from+'subQueue' under normal operation; on overflow under 'DropSubscription'+the publisher flips 'subStatus' to 'Overflowed' and the worker+terminates the subscription with 'SubscriptionOverflowed'.+-}+data Subscriber = Subscriber+    { subQueue :: !(TBQueue (Vector RecordedEvent))+    , subStatus :: !(TVar SubscriberStatus)+    , subPolicy :: !OverflowPolicy+    }++-- | Subscriber lifecycle status as observed by its worker.+data SubscriberStatus+    = -- | Healthy; worker reads from the queue normally.+      Active+    | {- | Recoverable backpressure under 'PauseAndResume': the queue was full+      so the publisher stopped pushing and set this flag. The worker observes+      it, drains the stale queue, clears the flag back to 'Active', and+      re-catches-up from its checkpoint to recover any skipped events.+      -}+      Paused+    | {- | Publisher signalled overflow under 'DropSubscription'; worker should+      surface a structured error.+      -}+      Overflowed+    deriving stock (Eq, Show)++{- | Publisher batch size — larger than subscriber batch size because the+Publisher serves all subscribers.+-}+publisherBatchSize :: Int32+publisherBatchSize = 1000++-- | Safety poll interval in microseconds (30 seconds).+safetyPollMicros :: Int+safetyPollMicros = 30_000_000++{- | Start the EventPublisher. Spawns a thread that waits for ticks from the+Notifier (or a 30-second safety poll timeout), queries the database for+new events, and delivers them to every active subscriber. Per-subscriber+overflow handling is determined by each subscription's+'OverflowPolicy'.++If an 'eventHandler' callback is supplied, the publisher emits+'Kiroku.Store.Observability.KirokuEventPublisherPoolError' when its read+query returns a 'Pool.UsageError'. The publisher continues to run on the+30-second safety poll regardless of the event firing; the event is the+operator's only structured signal that pool exhaustion or a server+error stalled the broadcast.+-}+startPublisher ::+    (MonadIO m) =>+    Pool ->+    TChan () ->+    -- | optional event handler for publisher-side observability+    Maybe (KirokuEvent -> IO ()) ->+    {- | interpreter-level event hooks; 'Kiroku.Store.Settings.decodeHook'+    runs once per fetched batch before fan-out to subscribers.+    -}+    StoreSettings ->+    m EventPublisher+startPublisher pool notifierChan mHandler stSettings = liftIO $ do+    subsVar <- newTVarIO IntMap.empty+    nextIdVar <- newTVarIO 0+    tailResult <- Pool.use pool (Session.statement () SQL.currentGlobalPositionStmt)+    tailPos <- either throwIO pure tailResult+    pos <- newTVarIO (GlobalPosition tailPos)+    -- Get a personal copy of the notifier's broadcast channel+    tickChan <- atomically (dupTChan notifierChan)+    thread <- Async.async (publisherLoop pool tickChan subsVar pos mHandler stSettings)+    pure+        EventPublisher+            { subscribers = subsVar+            , nextSubscriberId = nextIdVar+            , publisherThread = thread+            , lastPublished = pos+            }++-- | Stop the EventPublisher thread.+stopPublisher :: (MonadIO m) => EventPublisher -> m ()+stopPublisher pub = liftIO $ do+    Async.cancel (publisherThread pub)+    () <$ Async.waitCatch (publisherThread pub)++{- | Register a new subscriber with the given queue capacity and overflow+policy. Returns the bounded queue, the subscriber's status TVar, and an+@unsubscribe@ action that the caller must invoke when the subscription+ends (worker exits, cancellation). Failing to unsubscribe causes the+publisher to keep delivering to a queue with no reader, which will fill+and trigger the configured policy unnecessarily.+-}+subscribePublisher ::+    EventPublisher ->+    -- | Queue capacity (number of batches)+    Natural ->+    OverflowPolicy ->+    STM (TBQueue (Vector RecordedEvent), TVar SubscriberStatus, IO ())+subscribePublisher pub cap policy = do+    queue <- newTBQueue cap+    status <- newTVar Active+    sid <- readTVar (nextSubscriberId pub)+    writeTVar (nextSubscriberId pub) (sid + 1)+    let sub = Subscriber{subQueue = queue, subStatus = status, subPolicy = policy}+    modifyTVar' (subscribers pub) (IntMap.insert sid sub)+    let unsubscribe =+            atomically $+                modifyTVar' (subscribers pub) (IntMap.delete sid)+    pure (queue, status, unsubscribe)++-- | Read the last-published global position.+publisherPosition :: EventPublisher -> STM GlobalPosition+publisherPosition pub = readTVar (lastPublished pub)++-- Internal: the publisher loop.+publisherLoop ::+    Pool ->+    TChan () ->+    TVar (IntMap Subscriber) ->+    TVar GlobalPosition ->+    Maybe (KirokuEvent -> IO ()) ->+    StoreSettings ->+    IO ()+publisherLoop pool tickChan subsVar posVar mHandler stSettings = loop+  where+    loop = do+        -- Wait for a tick OR safety poll timeout+        waitForWakeup tickChan+        -- Drain all pending ticks (debouncing)+        drainTicks tickChan+        -- Fetch and broadcast+        fetchAndBroadcast+        loop++    fetchAndBroadcast = do+        GlobalPosition pos <- readTVarIO posVar+        result <- Pool.use pool (Session.statement (pos, publisherBatchSize) SQL.readAllForwardStmt)+        case result of+            Left err -> do+                -- Surface the pool error so operators see why broadcast+                -- has stalled; the 30-second safety poll will retry.+                for_ mHandler ($ KirokuEventPublisherPoolError err)+            Right rawEvents+                | V.null rawEvents -> pure ()+                | otherwise -> do+                    -- Apply the decodeHook once per batch — every subscriber+                    -- observes the same transformed view, and the cost is+                    -- paid in one place instead of per-subscriber.+                    events <- decodeEvents stSettings rawEvents+                    let lastEvent = V.last events+                        newPos = globalPosition lastEvent+                    -- Snapshot the current subscriber set, then deliver outside+                    -- the snapshot's STM transaction. Each delivery is its own+                    -- atomic step so a slow subscriber under DropSubscription+                    -- cannot rollback another's enqueue.+                    subs <- readTVarIO subsVar+                    for_ (IntMap.elems subs) (deliverBatch events)+                    -- Advance posVar after attempting delivery to all subscribers.+                    -- Subscribers under DropSubscription have already been marked+                    -- Overflowed; their workers will observe and exit. Subscribers+                    -- under DropOldest have lost the oldest batch but their queues+                    -- are not full anymore.+                    atomically (writeTVar posVar newPos)+                    -- If we got a full batch, there may be more — loop immediately+                    if V.length events >= fromIntegral publisherBatchSize+                        then fetchAndBroadcast+                        else pure ()++    deliverBatch events sub = atomically $ do+        full <- isFullTBQueue (subQueue sub)+        if not full+            then do+                -- There is space again: clear a prior 'PauseAndResume' pause so+                -- the worker (which also clears it on resume) is not left waiting.+                -- Never clear a terminal 'DropSubscription' overflow.+                status <- readTVar (subStatus sub)+                case status of+                    Paused -> writeTVar (subStatus sub) Active+                    Active -> pure ()+                    Overflowed -> pure ()+                writeTBQueue (subQueue sub) events+            else case subPolicy sub of+                -- Recoverable: signal the pause and stop pushing. Do not drop;+                -- the worker re-reads the skipped events from its checkpoint.+                PauseAndResume -> writeTVar (subStatus sub) Paused+                DropSubscription -> writeTVar (subStatus sub) Overflowed+                DropOldest -> do+                    _ <- tryReadTBQueue (subQueue sub)+                    writeTBQueue (subQueue sub) events++-- Wait for either a tick or a 30-second timeout (safety poll).+waitForWakeup :: TChan () -> IO ()+waitForWakeup tickChan = do+    timerVar <- registerDelay safetyPollMicros+    atomically $+        (readTChan tickChan)+            `STM.orElse` (readTVar timerVar >>= STM.check)++-- Drain all pending ticks from the channel (debouncing).+drainTicks :: TChan () -> IO ()+drainTicks tickChan = atomically go+  where+    go = do+        mTick <- tryReadTChan tickChan+        case mTick of+            Nothing -> pure ()+            Just () -> go
+ src/Kiroku/Store/Subscription/Fsm.hs view
@@ -0,0 +1,358 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++{- | The explicit finite state machine driving a subscription worker.++A subscription worker is, at every instant, in exactly one named+'SubscriptionState'. A single, exhaustively pattern-matched transition+function 'step' names every legal move: given the current state and an+'Input' (a thing that just happened — a batch arrived, a fetch failed, the+queue overflowed, …) it returns the next state and a list of 'Effect's the+/driver/ ('Kiroku.Store.Subscription.Worker.runWorker') must perform.++Keeping the transition table in one pure function has two payoffs:++  * It is the single, documented /extension seam/ for the sibling plan+    @docs\/plans\/40-...@ (per-event retry \/ dead-letter). When that plan adds+    a 'Kiroku.Store.Subscription.Types.SubscriptionResult' constructor it will+    also add a matching 'Input' constructor; because 'step' is exhaustively+    pattern-matched on 'Input' within each driving state and this module is+    compiled with @-Werror=incomplete-patterns@, that addition fails to+    compile until every relevant clause handles it, rather than falling+    through silently.+  * There is exactly one place to read the current state for observability+    (the worker mirrors it into a @TVar@ — see M4).++This module is deliberately a near-leaf in the dependency graph: it depends+only on 'Kiroku.Store.Types' and @hasql-pool@, never on+'Kiroku.Store.Subscription.Types' or 'Kiroku.Store.Observability'. That keeps+the graph acyclic once 'Kiroku.Store.Subscription.Types' grows a handle field+of type 'SubscriptionState'. The terminal-reason enumeration+'SubscriptionStopReason' lives here for the same reason and is re-exported by+'Kiroku.Store.Observability' so the public event API is unchanged.+-}+module Kiroku.Store.Subscription.Fsm (+    -- * State+    SubscriptionState (..),+    ResumeCondition (..),+    stateCursor,+    stateName,++    -- * Terminal reasons+    SubscriptionStopReason (..),++    -- * Per-event dispositions (retry / dead-letter)+    RetryDelay (..),+    retryDelayMicros,+    DeadLetterReason (..),+    deadLetterSummary,+    deadLetterReasonJson,++    -- * Driver alphabet+    Input (..),+    Effect (..),++    -- * Transition function+    step,+) where++import Control.Exception (SomeException)+import Data.Aeson (Value, object, (.=))+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time (NominalDiffTime)+import Data.Vector (Vector)+import Data.Vector qualified as V+import Hasql.Pool qualified as Pool+import Kiroku.Store.Types (GlobalPosition (..), RecordedEvent (..))++{- | Why a subscription's worker thread stopped.++Defined here (rather than in 'Kiroku.Store.Observability') so the FSM's+'Stopped' state can carry it without 'Kiroku.Store.Subscription.Fsm' having to+import the observability module — which would close a dependency cycle once+'Kiroku.Store.Subscription.Types' references 'SubscriptionState'.+'Kiroku.Store.Observability' re-exports this type, so the @KirokuEvent@ API is+unchanged.+-}+data SubscriptionStopReason+    = {- | The handler returned 'Kiroku.Store.Subscription.Types.Stop' for some+      event. The normal completion path; the checkpoint is saved at that event.+      -}+      StopHandlerRequested+    | {- | The caller invoked @cancel@. No checkpoint advance is guaranteed;+      in-flight events replay on the next restart.+      -}+      StopCancelled+    | {- | The publisher marked the subscription overflowed under+      'Kiroku.Store.Subscription.Types.DropSubscription' and the worker+      surfaced 'Kiroku.Store.Subscription.Types.SubscriptionOverflowed'.+      -}+      StopOverflowed+    | {- | The worker thread died from an uncaught exception (typically a handler+      exception). The 'SomeException' carries the cause.+      -}+      StopWorkerCrashed !SomeException+    deriving stock (Show)++{- | How long to wait before redelivering a retried event.++The handler's @Kiroku.Store.Subscription.Types.Retry@ disposition carries one of+these; the worker sleeps for it before the next redelivery. Mirrors Shibuya's+@Shibuya.Core.Ack.RetryDelay@ shape (a 'NominalDiffTime') so the+@shibuya-kiroku-adapter@ can translate @AckRetry@ without loss, but is a+Kiroku-owned type so @kiroku-store@ does not depend on @shibuya-core@.+-}+newtype RetryDelay = RetryDelay NominalDiffTime+    deriving stock (Eq, Show)++{- | The retry delay in microseconds, clamped at @0@, suitable for+'Control.Concurrent.threadDelay'. Fractional seconds are rounded.+-}+retryDelayMicros :: RetryDelay -> Int+retryDelayMicros (RetryDelay d) = max 0 (round (realToFrac d * 1_000_000 :: Double))++{- | Why an event was dead-lettered (recorded in @kiroku.dead_letters@ while the+subscription advances past it). Kiroku-owned so @kiroku-store@ stays independent+of @shibuya-core@; the adapter converts Shibuya's @DeadLetterReason@ into one of+these. 'deadLetterSummary' produces the @reason_summary@ text column and+'deadLetterReasonJson' the structured @reason@ JSONB column.+-}+data DeadLetterReason+    = -- | Permanently unprocessable; the 'Text' is operator-facing detail.+      DeadLetterPoison !Text+    | -- | The event payload failed validation/parsing; the 'Text' is the detail.+      DeadLetterInvalid !Text+    | -- | The bounded retry budget was exhausted after the given number of attempts.+      DeadLetterMaxAttempts !Int+    | -- | A custom reason: a summary plus structured JSON detail.+      DeadLetterOther !Text !Value+    deriving stock (Eq, Show)++-- | The short operator-facing summary stored in @dead_letters.reason_summary@.+deadLetterSummary :: DeadLetterReason -> Text+deadLetterSummary = \case+    DeadLetterPoison detail -> "poison: " <> detail+    DeadLetterInvalid detail -> "invalid payload: " <> detail+    DeadLetterMaxAttempts n -> "max retry attempts exceeded (" <> T.pack (show n) <> ")"+    DeadLetterOther summary _ -> summary++-- | The structured JSON detail stored in @dead_letters.reason@ (JSONB).+deadLetterReasonJson :: DeadLetterReason -> Value+deadLetterReasonJson = \case+    DeadLetterPoison detail -> object ["kind" .= ("poison" :: Text), "detail" .= detail]+    DeadLetterInvalid detail -> object ["kind" .= ("invalid_payload" :: Text), "detail" .= detail]+    DeadLetterMaxAttempts n -> object ["kind" .= ("max_attempts_exceeded" :: Text), "attempts" .= n]+    DeadLetterOther summary detail -> object ["kind" .= ("other" :: Text), "summary" .= summary, "detail" .= detail]++{- | What unblocks a 'Paused' worker.++In M1 there is one resume condition: the bounded queue has drained enough that+the publisher cleared the subscriber's @Paused@ flag. The constructor is named+rather than a bare unit so a future backpressure source (e.g. an explicit+resume signal) can be added without changing the 'SubscriptionState' shape.+-}+data ResumeCondition+    = -- | Resume once the consumer drains its bounded queue.+      ResumeOnDrain+    deriving stock (Eq, Show)++{- | The named state a subscription worker is in.++  * 'CatchingUp' — reading history directly from PostgreSQL in batches from+    @cursor@ until it reaches the publisher's last-published position.+    @attempt@ counts consecutive failed catch-up fetches and drives the+    capped exponential backoff; it resets to 0 on any successful fetch.+  * 'Live' — caught up; receiving new events (from the publisher's bounded+    queue for AllStreams, or by re-querying for Category / consumer-group+    members).+  * 'Paused' — recoverable backpressure: a slow consumer filled its bounded+    queue, so the worker stopped pulling and waits for 'resumeWhen' (added in+    M2; in M1 this state is defined but never entered).+  * 'Reconnecting' — recovering from a lost database connection while live;+    backs off and re-enters 'CatchingUp' from @cursor@ (added in M3; in M1+    defined but never entered).+  * 'Retrying' — a handler returned+    'Kiroku.Store.Subscription.Types.Retry' for the event at @cursor@; the+    worker is redelivering it (@attempt@ counts redeliveries so far) and has not+    advanced the checkpoint past it. Added by the sibling retry\/dead-letter plan+    (@docs\/plans\/40-...@). It is a /surfaced observability state/: the worker's+    delivery primitive writes it into the observable state @TVar@ while a+    redelivery is pending and restores the prior driving state afterward, so it is+    visible through @currentState@ but is never itself a driving state fed back to+    'step' (the @Retrying@ clause in 'step' is therefore defensive).+  * 'Stopped' — terminal, carrying the 'SubscriptionStopReason'.+-}+data SubscriptionState+    = CatchingUp {cursor :: !GlobalPosition, attempt :: !Int}+    | Live {cursor :: !GlobalPosition}+    | Paused {cursor :: !GlobalPosition, resumeWhen :: !ResumeCondition}+    | Reconnecting {cursor :: !GlobalPosition, attempt :: !Int}+    | Retrying {cursor :: !GlobalPosition, attempt :: !Int}+    | Stopped {reason :: !SubscriptionStopReason}+    deriving stock (Show)++{- | The cursor of a non-terminal state, or 'GlobalPosition' @0@ for 'Stopped'.+Used by the driver to attach the current position to emitted events.+-}+stateCursor :: SubscriptionState -> GlobalPosition+stateCursor = \case+    CatchingUp c _ -> c+    Live c -> c+    Paused c _ -> c+    Reconnecting c _ -> c+    Retrying c _ -> c+    Stopped _ -> GlobalPosition 0++{- | A stable, low-cardinality label for the state's /name/, independent of its+payload (cursor, attempt, reason). Suitable as a metric label value or an admin+column. The strings are fixed identifiers, not the derived 'Show' output, so+they will not drift if a constructor's fields change.+-}+stateName :: SubscriptionState -> Text+stateName = \case+    CatchingUp{} -> "catching_up"+    Live{} -> "live"+    Paused{} -> "paused"+    Reconnecting{} -> "reconnecting"+    Retrying{} -> "retrying"+    Stopped{} -> "stopped"++{- | A thing that just happened, fed to 'step' to compute the next state.++The set is closed in M1; the sibling retry\/dead-letter plan extends it. Adding+a constructor here forces a compile error in every driving-state clause of+'step' that does not yet handle it (this module is @-Werror=incomplete-patterns@).+-}+data Input+    = -- | A non-empty history\/live batch arrived.+      BatchFetched !(Vector RecordedEvent)+    | -- | A fetch returned no rows (catch-up is complete).+      FetchEmpty+    | -- | A fetch hit a database error.+      FetchFailed !Pool.UsageError+    | -- | The cursor reached the publisher position; switch to live.+      CaughtUp+    | -- | The handler returned 'Stop' at this position.+      HandlerStopped !GlobalPosition+    | {- | The bounded queue filled under the fail-fast 'DropSubscription' policy+      (terminal).+      -}+      QueueOverflowed+    | {- | The bounded queue filled under the recoverable 'PauseAndResume' policy:+      pause rather than terminate.+      -}+      QueueBackpressured+    | -- | The worker drained the stale queue and is ready to recover (re-catch-up).+      QueueDrained+    | -- | The worker lost its database pool while live.+      ConnectionLost !Pool.UsageError+    | -- | The caller cancelled the worker.+      Cancelled+    deriving stock (Show)++{- | A side effect the driver must perform after a transition.++Some constructors (e.g. 'FetchHistory', 'RunLive') describe work the driver+already performs by inspecting the next state; they exist so the effect list is+a complete description of the transition for future drivers and for readers.+-}+data Effect+    = -- | Read a catch-up batch from the given cursor.+      FetchHistory !GlobalPosition+    | -- | Obtain the next live batch via the active live strategy.+      RunLive+    | -- | Call the handler per event, checkpointing at the batch tail.+      DeliverBatch !(Vector RecordedEvent)+    | {- | Persist the checkpoint at this position. (Named 'Checkpoint' rather+      than @SaveCheckpoint@ to avoid clashing with the+      'Kiroku.Store.Observability.SubscriptionDbPhase' constructor of that name.)+      -}+      Checkpoint !GlobalPosition+    | -- | Block until the consumer drains the queue.+      WaitForDrain+    | -- | Sleep for the backoff schedule of this attempt number.+      Backoff !Int+    | -- | Emit @KirokuEventSubscriptionCaughtUp@.+      EmitCaughtUp+    | -- | Emit @KirokuEventSubscriptionPaused@ (M4).+      EmitPaused+    | -- | Emit @KirokuEventSubscriptionResumed@ (M4).+      EmitResumed+    | -- | Emit @KirokuEventSubscriptionReconnecting@ with this attempt (M4).+      EmitReconnecting !Int+    | -- | Terminal: stop the driver with this reason (return or rethrow).+      Halt !SubscriptionStopReason+    deriving stock (Show)++-- The last event's position in a batch, falling back to the given cursor when+-- the batch is empty (the driver never feeds 'step' an empty 'BatchFetched',+-- so the fallback is defensive).+lastPos :: GlobalPosition -> Vector RecordedEvent -> GlobalPosition+lastPos fallback evs+    | V.null evs = fallback+    | otherwise = globalPosition (V.last evs)++{- | The single transition function. Given the current state and an input,+return the next state and the effects to perform.++Exhaustively pattern-matched on 'Input' within the two /driving/ states+('CatchingUp', 'Live') so that extending 'Input' (the retry\/dead-letter+sibling plan) forces a compile error here. The recoverable states 'Paused' and+'Reconnecting' carry their M2\/M3 transitions plus defensive self-loops; the+terminal 'Stopped' state ignores further input.+-}+step :: SubscriptionState -> Input -> (SubscriptionState, [Effect])+step st input = case st of+    CatchingUp c n -> case input of+        BatchFetched evs -> (CatchingUp (lastPos c evs) 0, [DeliverBatch evs])+        FetchEmpty -> (Live c, [EmitCaughtUp])+        FetchFailed _ -> (CatchingUp c (n + 1), [Backoff n])+        CaughtUp -> (Live c, [EmitCaughtUp])+        HandlerStopped _ -> (Stopped StopHandlerRequested, [Halt StopHandlerRequested])+        QueueOverflowed -> (Stopped StopOverflowed, [Halt StopOverflowed])+        QueueBackpressured -> (CatchingUp c n, []) -- defensive: catch-up reads the DB, not the queue+        QueueDrained -> (CatchingUp c n, [])+        ConnectionLost _ -> (Reconnecting c 1, [EmitReconnecting 1, Backoff 1])+        Cancelled -> (Stopped StopCancelled, [Halt StopCancelled])+    Live c -> case input of+        BatchFetched evs -> (Live (lastPos c evs), [DeliverBatch evs])+        FetchEmpty -> (Live c, [RunLive])+        FetchFailed _ -> (Reconnecting c 1, [EmitReconnecting 1, Backoff 1])+        CaughtUp -> (Live c, [])+        HandlerStopped _ -> (Stopped StopHandlerRequested, [Halt StopHandlerRequested])+        QueueOverflowed -> (Stopped StopOverflowed, [Halt StopOverflowed])+        QueueBackpressured -> (Paused c ResumeOnDrain, [EmitPaused])+        QueueDrained -> (Live c, [RunLive])+        ConnectionLost _ -> (Reconnecting c 1, [EmitReconnecting 1, Backoff 1])+        Cancelled -> (Stopped StopCancelled, [Halt StopCancelled])+    Paused c rc -> case input of+        -- The worker drained the stale queue and cleared the pause flag; recover+        -- by re-catching-up from the checkpoint so any events the publisher+        -- skipped while full are re-read from the database. No loss; the live+        -- queue's stale filter drops the now-superseded queued entries on return.+        QueueDrained -> (CatchingUp c 0, [EmitResumed])+        Cancelled -> (Stopped StopCancelled, [Halt StopCancelled])+        HandlerStopped _ -> (Stopped StopHandlerRequested, [Halt StopHandlerRequested])+        _ -> (Paused c rc, [])+    Reconnecting c n -> case input of+        BatchFetched evs -> (CatchingUp (lastPos c evs) 0, [DeliverBatch evs])+        FetchEmpty -> (Live c, [])+        FetchFailed _ -> (Reconnecting c (n + 1), [EmitReconnecting (n + 1), Backoff (n + 1)])+        ConnectionLost _ -> (Reconnecting c (n + 1), [EmitReconnecting (n + 1), Backoff (n + 1)])+        CaughtUp -> (CatchingUp c 0, [])+        HandlerStopped _ -> (Stopped StopHandlerRequested, [Halt StopHandlerRequested])+        Cancelled -> (Stopped StopCancelled, [Halt StopCancelled])+        QueueOverflowed -> (Reconnecting c n, [])+        QueueBackpressured -> (Reconnecting c n, [])+        QueueDrained -> (Reconnecting c n, [])+    -- 'Retrying' is a surfaced observability state managed inside the worker's+    -- delivery primitive (it sets the observable @TVar@ to 'Retrying' while a+    -- redelivery is pending and restores the prior driving state afterward); it+    -- is never a driving state fed back to 'step'. This clause is therefore+    -- defensive — only cancellation / a handler stop could plausibly race in, and+    -- both terminate; anything else returns to 'Live' at the same cursor.+    Retrying c _ -> case input of+        Cancelled -> (Stopped StopCancelled, [Halt StopCancelled])+        HandlerStopped _ -> (Stopped StopHandlerRequested, [Halt StopHandlerRequested])+        _ -> (Live c, [])+    Stopped r -> (Stopped r, [])
+ src/Kiroku/Store/Subscription/Stream.hs view
@@ -0,0 +1,174 @@+{- | Streamly bridges that turn a push-based subscription into a pull-based+@Stream IO@, with a bounded 'Control.Concurrent.STM.TBQueue' providing+backpressure between the Kiroku worker and a downstream stream consumer.++Two bridges are provided:++  * 'subscriptionStream' — the plain bridge. The bridge handler enqueues each+    event and immediately returns 'Continue', so the worker checkpoints at the+    batch tail independently of whether the downstream consumer has processed+    the event. Use it when the stream is an in-process handoff and per-event+    acknowledgement is not required.+  * 'subscriptionAckStream' — the __ack-coupled__ bridge. Each emitted 'AckItem'+    carries a one-shot reply variable; the bridge handler blocks until the+    consumer replies with a 'SubscriptionResult', and only then does the worker+    checkpoint \/ retry \/ dead-letter. This is the path the+    @shibuya-kiroku-adapter@ builds on so a Shibuya @AckRetry@\/@AckDeadLetter@+    drives a real Kiroku disposition before the checkpoint advances.++Both honour the subscription's worker-side filters+('Kiroku.Store.Subscription.Types.eventTypeFilter' and+'Kiroku.Store.Subscription.Types.selector'): a filtered-out event never reaches+either bridge.+-}+module Kiroku.Store.Subscription.Stream (+    -- * Plain pull stream+    subscriptionStream,++    -- * Ack-coupled pull stream+    AckItem (..),+    subscriptionAckStream,+)+where++import Control.Concurrent.STM (+    TBQueue,+    TMVar,+    atomically,+    newEmptyTMVarIO,+    newTBQueueIO,+    putTMVar,+    readTBQueue,+    takeTMVar,+    writeTBQueue,+ )+import Data.IORef (atomicModifyIORef', newIORef)+import Kiroku.Store.Connection (KirokuStore)+import Kiroku.Store.Subscription (subscribe)+import Kiroku.Store.Subscription.Types (+    SubscriptionConfig,+    SubscriptionConfigM (..),+    SubscriptionHandleM (..),+    SubscriptionResult (..),+ )+import Kiroku.Store.Types (EventId, RecordedEvent (..))+import Numeric.Natural (Natural)+import Streamly.Data.Stream (Stream)+import Streamly.Data.Stream qualified as Stream++{- | One ack-coupled item emitted by 'subscriptionAckStream'.++The Kiroku subscription worker enqueues an 'AckItem' for each delivered event and+then __blocks__ until the consumer writes a 'SubscriptionResult' into 'ackReply'.+Only then does the worker act on it (checkpoint on 'Continue'\/'Stop', redeliver+on 'Retry', record-and-advance on 'DeadLetter'). This is what lets a downstream+consumer (the @shibuya-kiroku-adapter@) drive Kiroku's per-event disposition from+its own acknowledgement decision.+-}+data AckItem = AckItem+    { ackEvent :: !RecordedEvent+    -- ^ the delivered event+    , ackAttempt :: !Word+    {- ^ zero-based redelivery count for this event: @0@ on first delivery, @1@+    on the first redelivery after a 'Retry', and so on. Tracked by the bridge+    (the worker redelivers the same event consecutively while retrying).+    -}+    , ackReply :: !(TMVar SubscriptionResult)+    -- ^ one-shot reply the consumer must fill exactly once+    }++{- | Create a pull-based 'Stream' from a kiroku subscription.++A bounded 'TBQueue' sits between kiroku's push-based handler and the+returned Streamly stream. The stream terminates when the underlying+subscription ends or the returned cancel action runs.++The @handler@ field in the provided 'SubscriptionConfig' is ignored —+the bridge provides its own handler.++This is the plain, non-acknowledging bridge: every event is replied 'Continue'+as soon as the consumer pulls it, preserving the original semantics. It is+implemented in terms of 'subscriptionAckStream'; consumers that need to drive+retry\/dead-letter dispositions should use 'subscriptionAckStream' directly.++The config's+'Kiroku.Store.Subscription.Types.eventTypeFilter' is honored: the worker+applies it before the bridge handler runs, so the stream yields only matching+events while the checkpoint still advances past filtered-out ones. The stream's+element type is unchanged ('RecordedEvent') — filtering only removes elements,+it does not reshape them.++The returned cancel action cancels the underlying subscription and+writes the sentinel so any blocked reader wakes up and terminates.+-}+subscriptionStream ::+    KirokuStore ->+    SubscriptionConfig ->+    -- | TBQueue capacity (buffer size for backpressure)+    Natural ->+    IO (Stream IO RecordedEvent, IO ())+subscriptionStream store config bufferSize = do+    (ackStream, cancelAction) <- subscriptionAckStream store config bufferSize+    let stream =+            Stream.mapM+                ( \item -> do+                    atomically (putTMVar (ackReply item) Continue)+                    pure (ackEvent item)+                )+                ackStream+    pure (stream, cancelAction)++{- | Create an ack-coupled pull 'Stream' from a kiroku subscription.++Each emitted 'AckItem' carries a one-shot reply variable; the underlying Kiroku+worker blocks in its handler until the consumer fills 'ackReply' with a+'SubscriptionResult'. The worker then checkpoints, redelivers, dead-letters, or+stops accordingly — so the consumer controls Kiroku checkpointing per event. The+@handler@ field in the provided 'SubscriptionConfig' is ignored; the bridge+installs its own.++The returned cancel action cancels the underlying subscription (interrupting any+worker blocked waiting for a reply) and writes the @Nothing@ sentinel so a+blocked reader wakes up and the stream terminates.+-}+subscriptionAckStream ::+    KirokuStore ->+    SubscriptionConfig ->+    -- | TBQueue capacity (buffer size for backpressure)+    Natural ->+    IO (Stream IO AckItem, IO ())+subscriptionAckStream store config bufferSize = do+    queue <- newTBQueueIO bufferSize+    -- Tracks the previous (eventId, attempt) so a consecutive redelivery of the+    -- same event (the worker's bounded retry) is reported with an incremented+    -- attempt. The worker delivers events one at a time and blocks on the reply,+    -- so there is no concurrent access to this ref.+    attemptRef <- newIORef (Nothing :: Maybe (EventId, Word))++    let bridgeHandler :: RecordedEvent -> IO SubscriptionResult+        bridgeHandler event = do+            attempt <- atomicModifyIORef' attemptRef $ \mPrev ->+                case mPrev of+                    Just (eid, n)+                        | eid == eventId event -> (Just (eid, n + 1), n + 1)+                    _ -> (Just (eventId event, 0), 0)+            reply <- newEmptyTMVarIO+            atomically (writeTBQueue queue (Just (AckItem event attempt reply)))+            atomically (takeTMVar reply)++    let bridgeConfig = config{handler = bridgeHandler}++    subHandle <- subscribe store bridgeConfig++    let cancelAction = do+            cancel subHandle+            atomically (writeTBQueue queue Nothing)++    let step :: () -> IO (Maybe (AckItem, ()))+        step () = do+            mItem <- atomically (readTBQueue queue)+            case mItem of+                Just item -> pure (Just (item, ()))+                Nothing -> pure Nothing++    pure (Stream.unfoldrM step (), cancelAction)
+ src/Kiroku/Store/Subscription/Types.hs view
@@ -0,0 +1,408 @@+{- | Core configuration and result types for subscriptions.++This module defines the user-facing vocabulary for starting a subscription and+controlling it per event:++  * 'SubscriptionConfigM' (built with 'defaultSubscriptionConfig') — the+    declarative config: target, handler, batch size, overflow policy+    ('OverflowPolicy'), consumer-group membership, retry policy, and the two+    delivery filters ('EventTypeFilter' plus the opaque 'selector').+  * 'SubscriptionResult' — what the handler returns per event: 'Continue',+    'Stop', or the per-event dispositions 'Retry' and 'DeadLetter'.+  * 'SubscriptionHandleM' — the lifecycle handle ('cancel', 'wait', and the+    observable 'currentState').++The worker's state machine lives in "Kiroku.Store.Subscription.Fsm" (from which+'SubscriptionState', 'RetryDelay', and 'DeadLetterReason' are re-exported here);+this module is the configuration/result surface that drives it.+-}+module Kiroku.Store.Subscription.Types (+    SubscriptionName (..),+    SubscriptionTarget (..),+    SubscriptionResult (..),+    OverflowPolicy (..),+    SubscriptionOverflowed (..),+    EventHandlerM,+    EventHandler,+    SubscriptionConfigM (..),+    SubscriptionConfig,+    defaultSubscriptionConfig,+    SubscriptionHandleM (..),+    SubscriptionHandle,++    -- * Event-type filtering+    EventTypeFilter (..),+    eventTypeMatches,+    shouldDeliver,++    -- * Per-event dispositions (retry / dead-letter)+    RetryDelay (..),+    retryDelayMicros,+    DeadLetterReason (..),+    deadLetterSummary,+    deadLetterReasonJson,+    RetryPolicy (..),+    defaultRetryPolicy,++    -- * Consumer groups+    ConsumerGroup (..),+    InvalidConsumerGroup (..),+    ConsumerGroupGuardConflict (..),+) where++import Control.Exception (Exception, SomeException)+import Data.Int (Int32)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Kiroku.Store.Subscription.Fsm (+    DeadLetterReason (..),+    RetryDelay (..),+    SubscriptionState,+    deadLetterReasonJson,+    deadLetterSummary,+    retryDelayMicros,+ )+import Kiroku.Store.Types (CategoryName, EventType, RecordedEvent (..))+import Numeric.Natural (Natural)++{- | A declarative, closed filter over event types for a subscription.++'AllEventTypes' (the default) delivers every event. @'OnlyEventTypes' s@+delivers only events whose 'eventType' is in @s@; all other events are+skipped (the handler is not called) but the subscription checkpoint still+advances past them, so a highly selective subscription never stalls on a long+run of filtered-out events.++=== Why this is a closed sum and not @RecordedEvent -> Bool@++EventStore's subscription @selector@ is an opaque @RecordedEvent -> Bool@.+Kiroku deliberately models the /common/ case — \"deliver only these event+types\" — as a closed, first-order value instead, and keeps the opaque+predicate as a separate, optional escape hatch ('selector' on+'SubscriptionConfigM'). The closed sum is preferred for the steady-state filter+because it:++  * stays __introspectable__ — an operator or a metrics endpoint can read which+    types a subscription delivers (you cannot inspect a closure);+  * is __'Eq'\/'Show'-able__ for tests and diagnostics; and+  * leaves the door open to __SQL pushdown__ on fetching subscriptions+    (@Category@ / consumer-group), where @event_type = ANY(...)@ can be lowered+    into the catch-up read so the worker stops fetching-and-discarding. A+    @RecordedEvent -> Bool@ can never be pushed down.++Reach for 'selector' only when you need a predicate the type set cannot express+(e.g. filtering on metadata during a one-off catch-up reprocess while+investigating a problem). The two compose: an event is delivered only when it+passes /both/ (see 'shouldDeliver').++This is unrelated to 'Kiroku.Store.Types.EventFilter', which filters+correlation\/causation /queries/.+-}+data EventTypeFilter+    = -- | Deliver every event (the no-op default).+      AllEventTypes+    | -- | Deliver only events whose 'eventType' is in this set.+      OnlyEventTypes !(Set EventType)+    deriving stock (Eq, Show)++{- | 'True' when an event passes the declarative type filter.+The worker applies this /before/ calling the handler, so a non-matching event+never reaches the handler (or the ack-coupled bridge) and is never retried or+dead-lettered.+-}+eventTypeMatches :: EventTypeFilter -> RecordedEvent -> Bool+eventTypeMatches AllEventTypes _ = True+eventTypeMatches (OnlyEventTypes s) RecordedEvent{eventType = t} = Set.member t s++{- | The complete per-event delivery predicate for a subscription: an event is+delivered to the handler only when it passes __both__ the declarative+'eventTypeFilter' and the optional opaque 'selector' (an absent selector always+passes). The two compose as a logical AND — the type filter narrows by+'eventType', the selector narrows further by any predicate over the whole+'RecordedEvent'.++The worker applies this /before/ calling the handler, so an event rejected by+either filter never reaches the handler or the ack-coupled bridge (it is never+retried or dead-lettered), yet the checkpoint still advances past it — the+no-stall invariant holds for the selector exactly as it does for the type+filter.+-}+shouldDeliver :: EventTypeFilter -> Maybe (RecordedEvent -> Bool) -> RecordedEvent -> Bool+shouldDeliver etf sel event =+    eventTypeMatches etf event && maybe True ($ event) sel++-- | Unique name for a subscription (e.g., @"inventory-projection"@).+newtype SubscriptionName = SubscriptionName Text+    deriving newtype (Eq, Ord, Show)++-- | Which stream to subscribe to.+data SubscriptionTarget+    = -- | Subscribe to all events in global position order.+      AllStreams+    | -- | Subscribe to events from streams matching a category prefix.+      Category !CategoryName+    deriving stock (Eq, Show)++-- | What the handler returns to control the subscription lifecycle.+data SubscriptionResult+    = -- | Continue processing events.+      Continue+    | -- | Stop the subscription gracefully.+      Stop+    | {- | Redeliver /this same event/ after the given delay before the checkpoint+      advances past it. Redelivery is bounded by the subscription's+      'RetryPolicy' ('retryMaxAttempts'); once the bound is reached the worker+      dead-letters the event with 'DeadLetterMaxAttempts' and advances to the+      next event. The adapter maps Shibuya's @AckRetry@ to this.+      -}+      Retry !RetryDelay+    | {- | Record this event in @kiroku.dead_letters@ with the given reason and+      atomically advance the checkpoint past it, then continue with the next+      event. The adapter maps Shibuya's @AckDeadLetter@ to this.+      -}+      DeadLetter !DeadLetterReason+    deriving stock (Eq, Show)++{- | Bounds on how many times a single event is redelivered before it is+dead-lettered. The per-redelivery delay is carried by each+'Retry' result (mirroring Shibuya's per-decision @AckRetry RetryDelay@), so the+policy only carries the attempt bound.+-}+newtype RetryPolicy = RetryPolicy+    { retryMaxAttempts :: Int+    {- ^ Maximum redeliveries of one event before dead-lettering it. A value+    @<= 1@ means the first 'Retry' immediately dead-letters (no redelivery).+    -}+    }+    deriving stock (Eq, Show)++{- | The default 'RetryPolicy': up to five redeliveries of a single event before+it is dead-lettered with 'DeadLetterMaxAttempts'. Handlers that never return+'Retry' are unaffected by this default.+-}+defaultRetryPolicy :: RetryPolicy+defaultRetryPolicy = RetryPolicy{retryMaxAttempts = 5}++{- | What the publisher does when a subscriber's bounded queue is full.++The default 'PauseAndResume' is recoverable and lossless: the publisher+stops pushing to the full subscriber (and signals it), and the worker —+once its slow handler catches up — drains the stale queue and re-reads the+events it missed directly from the database from its checkpoint, so no+event is lost and the checkpoint still advances monotonically. The+fail-fast 'DropSubscription' (terminate with 'SubscriptionOverflowed') and+the lossy 'DropOldest' remain available for consumers that prefer a hard+error or best-effort delivery respectively.+-}+data OverflowPolicy+    = {- | Recoverable backpressure (the default). When the queue is full the+      publisher marks the subscriber 'Kiroku.Store.Subscription.EventPublisher.Paused'+      and stops pushing (it does not drop). The worker observes the pause,+      drains the stale queue, clears the flag, and re-catches-up from its+      checkpoint so every skipped event is delivered. No loss; monotonic+      checkpoint; other subscribers unaffected.+      -}+      PauseAndResume+    | {- | Mark the subscription as overflowed; the worker observes this on+      its next iteration and surfaces 'SubscriptionOverflowed' through+      'wait'. The slow subscriber is terminated; other subscribers are+      unaffected.+      -}+      DropSubscription+    | {- | Drop the oldest queued batch and enqueue the new one. The+      subscription continues but loses events. Choose only when at-least-once+      semantics are not required for this consumer.+      -}+      DropOldest+    deriving stock (Eq, Show)++{- | Raised on a 'SubscriptionHandleM' wait when the publisher dropped the+subscription because its bounded queue overflowed (overflow policy+'DropSubscription'). The 'subscriptionName' identifies the subscription+that overflowed; the consumer is expected to investigate the slow handler+and either fix the slowness or switch to 'DropOldest'.+-}+newtype SubscriptionOverflowed = SubscriptionOverflowed+    { subscriptionName :: SubscriptionName+    }+    deriving stock (Show)+    deriving anyclass (Exception)++-- | Handler callback invoked for each event, parameterized by monad.+type EventHandlerM m = RecordedEvent -> m SubscriptionResult++-- | Handler callback defaulting to 'IO'.+type EventHandler = EventHandlerM IO++-- | Configuration for starting a subscription, parameterized by monad.+data SubscriptionConfigM m = SubscriptionConfig+    { name :: !SubscriptionName+    , target :: !SubscriptionTarget+    , handler :: !(EventHandlerM m)+    , batchSize :: !Int32+    -- ^ Number of events to fetch per batch during catch-up (default: 100)+    , queueCapacity :: !Natural+    {- ^ Maximum number of /batches/ the publisher may enqueue for this+    subscriber before applying 'overflowPolicy'. Each batch is up to+    'EventPublisher.publisherBatchSize' events, so the effective event+    capacity is @queueCapacity * publisherBatchSize@. Default: 16+    batches (~16,000 events at the default publisher batch size).+    -}+    , overflowPolicy :: !OverflowPolicy+    {- ^ What the publisher does when this subscriber's queue is full.+    Default: 'PauseAndResume' — a slow subscriber is paused and then+    recovers losslessly (re-reading missed events from its checkpoint)+    rather than being terminated or silently growing the publisher's+    fan-out memory.+    -}+    , consumerGroup :: !(Maybe ConsumerGroup)+    {- ^ 'Nothing' (the default) = ordinary single-consumer subscription.+    'Just cg' = this worker is member 'member cg' of a group of size+    'size cg'. The invariant @size >= 1@ and @0 <= member < size@ is+    enforced once at 'Kiroku.Store.Subscription.subscribe' time, which+    throws 'InvalidConsumerGroup' on violation.+    -}+    , consumerGroupGuard :: !Bool+    {- ^ When 'True' (default 'False'), the worker performs a one-shot+    PostgreSQL advisory-lock conflict check at startup so two processes+    cannot both run the same @(name, member)@ at once. See the worker's+    @guardMember@ for the exact semantics and its documented limitation+    (a startup detection probe, not a lifetime-held lock). Ignored when+    'consumerGroup' is 'Nothing'.+    -}+    , retryPolicy :: !RetryPolicy+    {- ^ Bounds redelivery of an event for which the handler returned+    'Retry' before the worker dead-letters it. Default: 'defaultRetryPolicy'+    (five attempts). Handlers that only return 'Continue' / 'Stop' are+    unaffected.+    -}+    , eventTypeFilter :: !EventTypeFilter+    {- ^ Which event types this subscription delivers. Default+    'AllEventTypes' (deliver everything). When 'OnlyEventTypes', the worker+    skips the handler for non-matching events but still advances the+    checkpoint past them, so the subscription never stalls on a long run of+    filtered-out events. Applied worker-side before the handler/bridge, so a+    filtered-out event is never retried or dead-lettered. Composed with+    'selector' (an event must pass both — see 'shouldDeliver').+    -}+    , selector :: !(Maybe (RecordedEvent -> Bool))+    {- ^ Optional opaque per-event predicate, the escape hatch for filtering+    that 'eventTypeFilter' cannot express (e.g. on metadata, stream name, or+    correlation\/causation ids). Default 'Nothing' (no extra filtering).++    This is EventStore's @RecordedEvent -> Bool@ @selector@. It is intentionally+    /separate/ from 'eventTypeFilter' rather than replacing it: because a+    closure is not introspectable, not 'Eq'\/'Show'-able, and not SQL-pushable,+    'eventTypeFilter' remains the preferred steady-state type filter (see its+    note), and 'selector' is reserved for ad-hoc\/operational filtering — most+    often a one-off catch-up reprocess that narrows by metadata while+    investigating a problem.++    Composes with 'eventTypeFilter' as a logical AND ('shouldDeliver'): an event+    is delivered only when it passes both. Applied worker-side before the+    handler\/bridge, so a rejected event is never retried or dead-lettered, yet+    the checkpoint still advances past it (no stall).+    -}+    }++-- | Configuration defaulting to 'IO'.+type SubscriptionConfig = SubscriptionConfigM IO++{- | Build a 'SubscriptionConfig' with the recommended defaults.++The catch-up batch size defaults to 100 events per database fetch — large+enough to amortise round-trip overhead on typical projection workloads,+small enough that a single slow handler call does not stall the worker+for long. Override the 'batchSize' field on the returned record if a+different value suits the workload.++@+let cfg = defaultSubscriptionConfig "my-projection" AllStreams handler+withSubscription store cfg $ \\h -> wait h+@+-}+defaultSubscriptionConfig ::+    SubscriptionName ->+    SubscriptionTarget ->+    EventHandlerM m ->+    SubscriptionConfigM m+defaultSubscriptionConfig name' target' handler' =+    SubscriptionConfig+        { name = name'+        , target = target'+        , handler = handler'+        , batchSize = 100+        , queueCapacity = 16+        , overflowPolicy = PauseAndResume+        , consumerGroup = Nothing+        , consumerGroupGuard = False+        , retryPolicy = defaultRetryPolicy+        , eventTypeFilter = AllEventTypes+        , selector = Nothing+        }++-- | Handle returned to the caller for lifecycle management, parameterized by monad.+data SubscriptionHandleM m = SubscriptionHandle+    { cancel :: !(m ())+    -- ^ Cancel the subscription gracefully+    , wait :: !(m (Either SomeException ()))+    -- ^ Block until the subscription completes or fails+    , currentState :: !(m (Maybe SubscriptionState))+    {- ^ Read the worker's current FSM state+    ('Kiroku.Store.Subscription.Fsm.SubscriptionState') as of this instant,+    resolved through the store's central subscription-state registry.++    @Just s@ means the worker is live and still owns its registry entry, in state+    @s@ — one of @CatchingUp@, @Live@, @Paused@ (recoverable backpressure),+    @Reconnecting@, or @Retrying@. @Nothing@ means the subscription is __not+    currently live__: it has stopped, been cancelled, crashed (its registry key+    was removed in the worker's @finally@ cleanup), was never started, or has+    been superseded by a newer worker registered under the same @(name, member)@+    key.++    Note the invariant that a @Stopped@ state never appears here: the FSM never+    writes @Stopped@ into the cell, so a not-live subscription is represented by+    @Nothing@ — never by a @Just (Stopped …)@. This unifies one rule, "stopped =+    absent", across 'currentState' and+    'Kiroku.Store.Subscription.subscriptionStates'. For the stream of past+    transitions (including the terminal stop reason) use the @KirokuEvent@+    lifecycle events instead.+    -}+    }++-- | Handle defaulting to 'IO'.+type SubscriptionHandle = SubscriptionHandleM IO++-- | Static consumer-group membership for a subscription.+data ConsumerGroup = ConsumerGroup+    { member :: !Int32+    -- ^ 0-based member index; must satisfy @0 <= member < size@.+    , size :: !Int32+    -- ^ total members in the group; must be @>= 1@.+    }+    deriving stock (Eq, Show)++{- | Thrown by 'Kiroku.Store.Subscription.subscribe' when a 'ConsumerGroup'+violates @size >= 1@ or @0 <= member < size@. Carries the offending values for+diagnostics.+-}+data InvalidConsumerGroup = InvalidConsumerGroup+    { invalidMember :: !Int32+    , invalidSize :: !Int32+    }+    deriving stock (Show)+    deriving anyclass (Exception)++{- | Thrown at subscription startup when 'consumerGroupGuard' is 'True' and+another holder currently holds the advisory lock for this @(name, member)@.+Indicates two processes are configured as the same group member. This is a+startup /detection/ probe, not a lifetime-held lock — see the worker's+@guardMember@.+-}+data ConsumerGroupGuardConflict = ConsumerGroupGuardConflict+    { conflictName :: !SubscriptionName+    , conflictMember :: !Int32+    }+    deriving stock (Show)+    deriving anyclass (Exception)
+ src/Kiroku/Store/Subscription/Worker.hs view
@@ -0,0 +1,721 @@+{- | The subscription worker: the impure driver behind a running subscription.++'runWorker' is the long-lived loop spawned by+'Kiroku.Store.Subscription.subscribe'. It is the interpreter for the pure state+machine in "Kiroku.Store.Subscription.Fsm": it supplies inputs (a batch was+fetched, the queue overflowed, the pool errored, the handler returned a+disposition) and carries out the resulting effects (deliver a batch, save the+checkpoint, back off, emit a @KirokuEvent@, halt). The worker walks the named+states — @CatchingUp@, @Live@, @Paused@ (recoverable backpressure),+@Reconnecting@ (re-catch-up after a live fetch loses the pool), @Retrying@, and+@Stopped@ — and writes each transition to the @TVar@ exposed through+'Kiroku.Store.Subscription.Types.currentState'.++Per-event delivery (including the worker-side+'Kiroku.Store.Subscription.Types.eventTypeFilter' \/+'Kiroku.Store.Subscription.Types.selector' check applied /before/ the handler,+and the bounded-retry \/ dead-letter disposition mechanics) is concentrated in+the single delivery primitive shared by every live path, so behaviour is+identical for @AllStreams@, @Category@, and consumer-group subscriptions.++'withFetchBatchHookForTest' is a test-only seam for injecting fetch failures.+-}+module Kiroku.Store.Subscription.Worker (+    runWorker,+    configMember,+    withFetchBatchHookForTest,+) where++import Contravariant.Extras (contrazip2)+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.STM (TBQueue, TVar, atomically, check, orElse, readTBQueue, readTVar, registerDelay, tryReadTBQueue, writeTVar)+import Control.Exception (SomeException, bracket, fromException, throwIO, try)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Foldable (for_)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Int (Int32, Int64)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Vector qualified as V+import Data.Word (Word64)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool (Pool)+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Kiroku.Store.Observability (+    KirokuEvent (..),+    SubscriptionDbPhase (..),+    SubscriptionDeliveryPhase (..),+    SubscriptionGroupContext (..),+    SubscriptionStopReason (..),+ )+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Settings (StoreSettings, decodeEvents)+import Kiroku.Store.Subscription.EventPublisher (SubscriberStatus)+import Kiroku.Store.Subscription.EventPublisher qualified as Pub+import Kiroku.Store.Subscription.Fsm (+    Effect (..),+    Input (..),+    SubscriptionState (..),+    stateCursor,+    step,+ )+import Kiroku.Store.Subscription.Types+import Kiroku.Store.Types (CategoryName (..), EventId (..), GlobalPosition (..), RecordedEvent (..))+import System.IO.Unsafe (unsafePerformIO)++-- Mirror 'Kiroku.Store.Subscription.EventPublisher.safetyPollMicros': an idle+-- category re-checks at most this often, reconciling NOTIFYs lost while the+-- listener connection was reconnecting. An idle category therefore costs at most+-- one empty fetch per safety interval, not per global publisher tick.+categorySafetyPollMicros :: Int+categorySafetyPollMicros = 30_000_000++type FetchBatchHook =+    SubscriptionConfig ->+    GlobalPosition ->+    IO (Maybe (Either Pool.UsageError (Vector RecordedEvent)))++{-# NOINLINE fetchBatchHookRef #-}+fetchBatchHookRef :: IORef (Maybe FetchBatchHook)+fetchBatchHookRef = unsafePerformIO (newIORef Nothing)++{- | Install a process-local fetch hook for tests that need deterministic+subscription-worker fault injection. Production code leaves the hook unset.+-}+withFetchBatchHookForTest :: FetchBatchHook -> IO a -> IO a+withFetchBatchHookForTest hook action =+    bracket+        ( do+            previous <- readIORef fetchBatchHookRef+            writeIORef fetchBatchHookRef (Just hook)+            pure previous+        )+        (writeIORef fetchBatchHookRef)+        (const action)++fetchRetryDelayMicros :: Int -> Int+fetchRetryDelayMicros attempt =+    min categorySafetyPollMicros (100_000 * (2 ^ min attempt 9 :: Int))++{- | Run the subscription worker loop. Two phases:++Phase 1 (catch-up): queries database directly until reaching publisherPosition.+Phase 2 (live): for AllStreams, reads from the bounded TBQueue the publisher+delivers to; for Category, re-queries the database whenever the publisher+advances (the broadcast TBQueue is unused for category subscriptions).++Runs until the handler returns 'Stop', the thread is cancelled, or the+publisher signals overflow on the subscriber's status TVar (in which+case 'Kiroku.Store.Subscription.Types.SubscriptionOverflowed' is thrown+and surfaces through 'Async.waitCatch').++If an 'eventHandler' callback is supplied, the worker emits:++* 'Kiroku.Store.Observability.KirokuEventSubscriptionStarted' once at+  startup, after the checkpoint has been read.+* 'Kiroku.Store.Observability.KirokuEventSubscriptionCaughtUp' when+  catch-up completes and the worker switches to live mode.+* 'Kiroku.Store.Observability.KirokuEventSubscriptionDbError' in the+  subscription database phases: 'loadCheckpoint', 'fetchBatch', and+  'saveCheckpoint'. 'fetchBatch' errors are retried at the same cursor;+  the event is the operator's structured signal.+* 'Kiroku.Store.Observability.KirokuEventSubscriptionStopped' when the+  worker exits, with a reason discriminating handler-stop, cancel,+  overflow, and worker-crash.+-}+runWorker ::+    (MonadIO m) =>+    Pool ->+    TBQueue (Vector RecordedEvent) ->+    TVar SubscriberStatus ->+    {- | the worker's current FSM state, written on every transition so callers+    can read it through 'Kiroku.Store.Subscription.Types.currentState'.+    -}+    TVar SubscriptionState ->+    TVar GlobalPosition ->+    {- | per-category wake counter from the Notifier; the @Category@ live loop+    blocks on this category's entry rather than busy-polling the global position.+    -}+    TVar (Map Text Word64) ->+    SubscriptionConfig ->+    -- | optional event handler for subscription observability+    Maybe (KirokuEvent -> IO ()) ->+    {- | interpreter-level event hooks; 'Kiroku.Store.Settings.decodeHook'+    runs on the catch-up fetch path, mirroring the publisher's+    application in live mode.+    -}+    StoreSettings ->+    m ()+runWorker pool liveQueue statusVar stateVar pubPosVar catGenVar config mHandler stSettings = liftIO $ do+    let emit evt = for_ mHandler ($ evt)+        subName = name config+        groupCtx = groupCtxOf config+    posRef <- newIORef (GlobalPosition 0)++    let body = do+            -- Optional startup guardrail: when consumerGroupGuard is on, fail fast+            -- if another holder currently holds this (name, member)'s advisory lock.+            case (consumerGroupGuard config, consumerGroup config) of+                (True, Just (ConsumerGroup m _)) -> guardMember pool subName m+                _ -> pure ()+            checkpoint <- loadCheckpoint pool config emit+            writeIORef posRef checkpoint+            emit (KirokuEventSubscriptionStarted subName checkpoint groupCtx)+            -- Drive the explicit FSM from the catch-up state. The pure 'step'+            -- (Kiroku.Store.Subscription.Fsm) decides every lifecycle transition;+            -- this driver supplies the inputs (what just happened) and interprets+            -- the effects (deliver a batch, emit an event, back off, halt). The+            -- three live strategies remain the *mechanism* for obtaining the next+            -- batch within the 'Live' state; the FSM governs the lifecycle.+            loop (CatchingUp checkpoint 0)++        -- One driver iteration: publish the current state for observability+        -- ('currentState'), discover the next 'Input' by performing the state's+        -- natural (possibly blocking) action, then hand it to 'feed'. Recording+        -- the state at loop entry means the value read while the worker blocks in+        -- 'nextInput' (e.g. waiting on the live queue) is the state it is blocked in.+        loop :: SubscriptionState -> IO ()+        loop st = do+            atomically (writeTVar stateVar st)+            nextInput st >>= feed st++        -- Apply 'step' to the (state, input) pair, interpret the resulting+        -- effects, and continue. An effect (delivery, a gate) may itself produce+        -- a follow-up 'Input' (e.g. the handler returned 'Stop'); that is fed back+        -- to 'step' immediately. Otherwise: stop when the new state is terminal,+        -- else loop on the new state.+        feed :: SubscriptionState -> Input -> IO ()+        feed st inp = do+            let (st', effs) = step st inp+            follow <- runEffects st' effs+            case follow of+                Just fInp -> feed st' fInp+                Nothing -> case st' of+                    Stopped _ -> pure ()+                    _ -> loop st'++        -- Produce the next 'Input' for a state by performing its blocking action.+        --   * CatchingUp: if caught up, 'CaughtUp'; else fetch one history batch,+        --     mapping the result to 'BatchFetched' / 'FetchEmpty' (caught up) /+        --     'FetchFailed' (the catch-up retry, escalated by the state's attempt).+        --   * Live (AllStreams, non-group): read the publisher's bounded queue;+        --     'QueueOverflowed' when the publisher signalled overflow, else the+        --     stale-filtered batch ('FetchEmpty' if all stale).+        --   * Live (Category / consumer-group): run the existing live loop to its+        --     natural termination (handler 'Stop'), then report 'HandlerStopped'.+        --     These loops retain their own NOTIFY-generation / global-position+        --     gates and per-fetch retry, exactly as before.+        nextInput :: SubscriptionState -> IO Input+        nextInput = \case+            CatchingUp c _ -> do+                writeIORef posRef c+                pubPos <- atomically (readTVar pubPosVar)+                if c >= pubPos+                    then pure CaughtUp+                    else do+                        fetchResult <- fetchBatch pool config c emit stSettings+                        case fetchResult of+                            Left err -> pure (FetchFailed err)+                            Right events+                                | V.null events -> pure CaughtUp+                                | otherwise -> pure (BatchFetched events)+            Live c -> case (consumerGroup config, target config) of+                (Nothing, AllStreams) -> do+                    writeIORef posRef c+                    atomically $ do+                        status <- readTVar statusVar+                        case status of+                            Pub.Overflowed -> pure QueueOverflowed+                            Pub.Paused -> pure QueueBackpressured+                            Pub.Active -> do+                                -- A subscription registers its live queue before+                                -- catch-up begins, so events appended during+                                -- catch-up may be both fetched from SQL and waiting+                                -- in the queue. Drop those stale entries so live+                                -- mode cannot replay them or rewind the checkpoint.+                                events <- readTBQueue liveQueue+                                let fresh = V.filter ((> c) . globalPosition) events+                                pure (if V.null fresh then FetchEmpty else BatchFetched fresh)+                (Nothing, Category (CategoryName cat)) ->+                    liveExitToInput =<< liveLoopCategoryNotify pool config stateVar catGenVar cat emit posRef c stSettings+                (Just _, _) ->+                    liveExitToInput =<< liveLoopDbDriven pool config stateVar pubPosVar emit posRef c stSettings+            -- Recoverable backpressure: the publisher set 'Paused' because this+            -- subscriber's bounded queue filled. Drain the stale queue (those+            -- events are re-read from the database by the re-catch-up that+            -- 'QueueDrained' triggers) and clear the flag back to 'Active' so the+            -- publisher resumes pushing and the worker is not left waiting. The+            -- AllStreams live path's @> cursor@ filter drops any superseded queued+            -- entries once the worker is live again.+            Paused{} -> do+                atomically $ do+                    drainQueue liveQueue+                    writeTVar statusVar Pub.Active+                pure QueueDrained+            -- Reconnecting: re-probe the database from the checkpoint. A success+            -- re-enters catch-up (delivering everything after the cursor); a+            -- failure stays in 'Reconnecting' for another backed-off attempt; an+            -- empty result means there is nothing new, so return to live.+            Reconnecting c _ -> do+                writeIORef posRef c+                fetchResult <- fetchBatch pool config c emit stSettings+                case fetchResult of+                    Left err -> pure (FetchFailed err)+                    Right events+                        | V.null events -> pure FetchEmpty+                        | otherwise -> pure (BatchFetched events)+            Stopped{} -> pure Cancelled++        -- Interpret a transition's effects against the *new* state. Returns a+        -- follow-up 'Input' when an effect produces one (only 'DeliverBatch', when+        -- the handler returns 'Stop'); 'Nothing' otherwise. 'Halt' terminates the+        -- driver: a handler-requested stop returns cleanly (the outer handler+        -- emits the Stopped event), overflow/crash rethrow so the outer 'try'+        -- classifies and re-emits — preserving today's exact event sequence.+        runEffects :: SubscriptionState -> [Effect] -> IO (Maybe Input)+        runEffects st' = go+          where+            go [] = pure Nothing+            go (e : es) = case e of+                EmitCaughtUp -> do+                    emit (KirokuEventSubscriptionCaughtUp subName (stateCursor st') groupCtx)+                    go es+                EmitPaused -> do+                    emit (KirokuEventSubscriptionPaused subName (stateCursor st') groupCtx)+                    go es+                EmitResumed -> do+                    emit (KirokuEventSubscriptionResumed subName (stateCursor st') groupCtx)+                    go es+                EmitReconnecting n -> do+                    emit (KirokuEventSubscriptionReconnecting subName n groupCtx)+                    go es+                Backoff n -> threadDelay (fetchRetryDelayMicros n) >> go es+                WaitForDrain -> go es+                Checkpoint p -> saveCheckpoint pool config p emit >> go es+                FetchHistory _ -> go es+                RunLive -> go es+                DeliverBatch events -> do+                    result <- processEvents pool config stateVar events emit posRef+                    case result of+                        Nothing -> pure (Just (HandlerStopped (lastPosOf events)))+                        Just _ -> go es+                Halt reason -> case reason of+                    StopHandlerRequested -> pure Nothing+                    StopOverflowed -> throwIO (SubscriptionOverflowed subName)+                    StopCancelled -> throwIO Async.AsyncCancelled+                    StopWorkerCrashed ex -> throwIO ex++        lastPosOf events = globalPosition (V.last events)++        -- Map a DB-driven live loop's exit onto the next FSM input: a clean stop+        -- becomes 'HandlerStopped' (at the last processed position); a fetch error+        -- becomes 'ConnectionLost', driving the FSM into 'Reconnecting'.+        liveExitToInput = \case+            LiveHandlerStopped -> HandlerStopped <$> readIORef posRef+            LiveFetchError err -> pure (ConnectionLost err)++        -- Read and discard every batch currently in the live queue (non-blocking).+        -- Used when resuming from 'Paused': the discarded events are re-read from+        -- the database by the subsequent re-catch-up, so nothing is lost.+        drainQueue q = do+            m <- tryReadTBQueue q+            case m of+                Nothing -> pure ()+                Just _ -> drainQueue q++    result <- try body+    pos <- readIORef posRef+    case result of+        Right () -> emit (KirokuEventSubscriptionStopped subName pos StopHandlerRequested groupCtx)+        Left (e :: SomeException) -> do+            emit (KirokuEventSubscriptionStopped subName pos (classifyStopReason e) groupCtx)+            throwIO e++-- The consumer-group context for this config's lifecycle events: 'NonGroup' for+-- an ordinary subscription, @GroupMember member size@ for a group member.+groupCtxOf :: SubscriptionConfig -> SubscriptionGroupContext+groupCtxOf config = maybe NonGroup (\(ConsumerGroup m n) -> GroupMember m n) (consumerGroup config)++{- Startup-only conflict probe for the consumer-group guardrail. Uses a+transaction-scoped advisory lock ('pg_try_advisory_xact_lock') which auto-releases+at transaction end, so it only detects a /concurrent/ holder at this instant. The+key is a stable bigint hash of the @name:member@ pair computed in SQL so all+processes agree. NOTE: this does NOT hold the lock for the worker's lifetime; full+mutual exclusion would need a session-level lock on a dedicated connection (the+'Kiroku.Store.Notification.Notifier' pattern), recorded as follow-up in EP-2's+Decision Log. On a database error the probe degrades open (treats it as "no+conflict") so a transient pool error cannot wedge startup. -}+guardMember :: Pool -> SubscriptionName -> Int32 -> IO ()+guardMember pool subName@(SubscriptionName n) mem = do+    let probe :: Statement (Text, Int32) Bool+        probe =+            preparable+                "SELECT pg_try_advisory_xact_lock(hashtextextended($1 || ':' || $2::text, 0))"+                ( contrazip2+                    (E.param (E.nonNullable E.text))+                    (E.param (E.nonNullable E.int4))+                )+                (D.singleRow (D.column (D.nonNullable D.bool)))+    result <- Pool.use pool (Session.statement (n, mem) probe)+    case result of+        Right True -> pure () -- got the lock; no concurrent holder right now+        Right False -> throwIO (ConsumerGroupGuardConflict subName mem)+        Left _ -> pure () -- DB error: degrade open (do not block startup)++-- Map an exception to the 'SubscriptionStopReason' the operator should see.+classifyStopReason :: SomeException -> SubscriptionStopReason+classifyStopReason e+    | Just (_ :: SubscriptionOverflowed) <- fromException e = StopOverflowed+    | Just (_ :: Async.AsyncCancelled) <- fromException e = StopCancelled+    | otherwise = StopWorkerCrashed e++-- The consumer-group member index for this config, or 0 for a non-group+-- subscription. We always route checkpoints through the member-aware+-- statements with member 0 for the non-group case, so there is a single code+-- path: EP-1's schema guarantees pre-existing rows are consumer_group_member = 0,+-- so a non-group worker reads and writes the same (name, 0) row it always did.+configMember :: SubscriptionConfig -> Int32+configMember config = maybe 0 member (consumerGroup config)++-- Load the checkpoint from the database, defaulting to 0.+-- Surfaces a database error through the event handler before falling+-- back to the safe default; without the event the operator has no signal+-- that a transient pool error caused a silent re-process from position 0.+-- Keyed by (subscription_name, member) so each group member resumes from its+-- own saved position.+loadCheckpoint ::+    Pool ->+    SubscriptionConfig ->+    (KirokuEvent -> IO ()) ->+    IO GlobalPosition+loadCheckpoint pool config emit = do+    let subName@(SubscriptionName name') = name config+        mem = configMember config+    result <- Pool.use pool (Session.statement (name', mem) SQL.getCheckpointMemberStmt)+    case result of+        Left err -> do+            emit (KirokuEventSubscriptionDbError subName LoadCheckpoint err (groupCtxOf config))+            pure (GlobalPosition 0)+        Right Nothing -> pure (GlobalPosition 0)+        Right (Just pos) -> pure (GlobalPosition pos)++-- How a DB-driven live loop ('liveLoopCategoryNotify' / 'liveLoopDbDriven')+-- exited. The driver maps these onto FSM inputs: a clean handler stop becomes+-- 'HandlerStopped'; a fetch error becomes 'ConnectionLost', which drives the FSM+-- into 'Reconnecting' (backoff + re-catch-up from the checkpoint) rather than the+-- old in-loop retry. AllStreams live has no entry here because it reads the+-- publisher's queue and never fetches — its reconnect is the publisher's concern.+data LiveExit+    = -- | The handler returned 'Stop'; the loop exited cleanly.+      LiveHandlerStopped+    | -- | A live-mode database fetch failed; the worker should reconnect.+      LiveFetchError !Pool.UsageError++-- Phase 2: live (Category, NOTIFY-driven). Blocks on this category's generation+-- counter, which the Notifier bumps on every NOTIFY for a stream in the category,+-- so an idle category does ZERO DB work while other categories receive traffic.+-- The generation is snapshotted BEFORE an unconditional drain so a notification+-- that arrives during the drain is never missed (it leaves gen > gen0 and the loop+-- drains again on the next iteration). A safety timeout (matching the publisher's+-- 30s safety poll) reconciles notifications lost while the listener connection is+-- reconnecting, preserving at-least-once delivery with bounded latency.+--+-- This loop serves only non-group `Category` subscriptions. Consumer-group members+-- cannot use the per-category signal: their interest is+-- `hashtextextended(stream_id) % size = member`, a Postgres hash the worker cannot+-- cheaply replicate from the payload, so they stay on `liveLoopDbDriven`.+liveLoopCategoryNotify ::+    Pool ->+    SubscriptionConfig ->+    TVar SubscriptionState ->+    TVar (Map Text Word64) ->+    -- | this subscription's category+    Text ->+    (KirokuEvent -> IO ()) ->+    IORef GlobalPosition ->+    GlobalPosition ->+    StoreSettings ->+    IO LiveExit+liveLoopCategoryNotify pool config stateVar catGenVar cat emit posRef startPos stSettings = go startPos+  where+    readGen = Map.findWithDefault 0 cat <$> readTVar catGenVar+    go cursor = do+        writeIORef posRef cursor+        -- Snapshot the generation BEFORE draining so a NOTIFY landing mid-drain+        -- is not lost: it leaves gen > gen0 and the gate below re-opens at once.+        gen0 <- atomically readGen+        drainResult <- drainTo cursor+        case drainResult of+            Left err -> pure (LiveFetchError err) -- reconnect: driver re-catches-up+            Right Nothing -> pure LiveHandlerStopped -- handler said Stop+            Right (Just c) -> do+                -- Block until this category is notified again OR the safety timer+                -- fires (reconciling NOTIFYs lost across a listener reconnect).+                timer <- registerDelay categorySafetyPollMicros+                atomically $+                    (readGen >>= \g -> check (g > gen0))+                        `orElse` (readTVar timer >>= check)+                go c+      where+        -- A fetch error bubbles out (no in-loop retry); the FSM's 'Reconnecting'+        -- state owns the backoff and re-catch-up. On success drain to empty.+        drainTo c = do+            fetchResult <- fetchBatch pool config c emit stSettings+            case fetchResult of+                Left err -> pure (Left err)+                Right events -> do+                    emit (KirokuEventSubscriptionFetched (name config) (V.length events) (groupCtxOf config))+                    if V.null events+                        then pure (Right (Just c))+                        else do+                            result <- processEvents pool config stateVar events emit posRef+                            case result of+                                Nothing -> pure (Right Nothing) -- handler said Stop+                                Just newPos -> drainTo newPos++-- Phase 2: live (DB-driven, consumer-group members only). Bypasses the broadcast+-- and re-queries the database when the publisher's GLOBAL position advances,+-- letting `fetchBatch` apply the partition predicate baked into the consumer-group+-- SQL. A partitioned member cannot read the broadcast `liveQueue` because it+-- carries unfiltered $all events and there is no in-process stream-id -> member map+-- to filter them with. See EP-3 F18 / EP-2 Decision Log for the rationale versus+-- extending RecordedEvent or maintaining an in-process cache.+--+-- The gate waits for the publisher to advance past the LAST OBSERVED global+-- position (not past `cursor`). A member's partition cursor only moves on events in+-- its slice, but `pubPosVar` moves on every append; gating on the cursor busy-loops+-- whenever another partition is ahead (the original defect). Gating on the last+-- observed `pubPos` blocks until genuinely new global work exists. After the gate+-- opens we drain the partition to empty (not stopping at `pubPos`), which+-- guarantees no lost wakeup: the $all position is strictly monotonic, so any later+-- partition event lands at a position strictly greater than the observed `pubPos`+-- and re-opens the gate.+liveLoopDbDriven ::+    Pool ->+    SubscriptionConfig ->+    TVar SubscriptionState ->+    TVar GlobalPosition ->+    (KirokuEvent -> IO ()) ->+    IORef GlobalPosition ->+    GlobalPosition ->+    StoreSettings ->+    IO LiveExit+liveLoopDbDriven pool config stateVar pubPosVar emit posRef startPos stSettings =+    go startPos (GlobalPosition 0)+  where+    go cursor waitFrom = do+        writeIORef posRef cursor+        pubPos <- atomically $ do+            p <- readTVar pubPosVar+            check (p > waitFrom)+            pure p+        -- A fetch error bubbles out (no in-loop retry); the FSM's 'Reconnecting'+        -- state owns the backoff and re-catch-up. On success drain to empty.+        let drainTo c = do+                fetchResult <- fetchBatch pool config c emit stSettings+                case fetchResult of+                    Left err -> pure (Left err)+                    Right events -> do+                        emit (KirokuEventSubscriptionFetched (name config) (V.length events) (groupCtxOf config))+                        if V.null events+                            then pure (Right (Just c))+                            else do+                                result <- processEvents pool config stateVar events emit posRef+                                case result of+                                    Nothing -> pure (Right Nothing) -- handler said Stop+                                    Just newPos -> drainTo newPos+        drainResult <- drainTo cursor+        case drainResult of+            Left err -> pure (LiveFetchError err)+            Right Nothing -> pure LiveHandlerStopped+            Right (Just c) -> go c pubPos++-- Fetch a batch of events from the database based on subscription target.+-- Surfaces a database error through the event handler and returns the error to+-- the caller so catch-up and DB-driven live loops can retry the same cursor.+fetchBatch ::+    Pool ->+    SubscriptionConfig ->+    GlobalPosition ->+    (KirokuEvent -> IO ()) ->+    StoreSettings ->+    IO (Either Pool.UsageError (Vector RecordedEvent))+fetchBatch pool config cursor@(GlobalPosition pos) emit stSettings = do+    mHook <- readIORef fetchBatchHookRef+    injected <- maybe (pure Nothing) (\hook -> hook config cursor) mHook+    case injected of+        Just result -> handle result+        Nothing ->+            case (consumerGroup config, target config) of+                (Nothing, AllStreams) -> do+                    result <- Pool.use pool (Session.statement (pos, batchSize config) SQL.readAllForwardStmt)+                    handle result+                (Nothing, Category (CategoryName cat)) -> do+                    result <- Pool.use pool (Session.statement (pos, cat, batchSize config) SQL.readCategoryForwardStmt)+                    handle result+                (Just (ConsumerGroup m n), AllStreams) -> do+                    result <- Pool.use pool (Session.statement (pos, m, n, batchSize config) SQL.readAllForwardConsumerGroupStmt)+                    handle result+                (Just (ConsumerGroup m n), Category (CategoryName cat)) -> do+                    result <- Pool.use pool (Session.statement (pos, cat, m, n, batchSize config) SQL.readCategoryForwardConsumerGroupStmt)+                    handle result+  where+    handle = \case+        Left err -> do+            emit (KirokuEventSubscriptionDbError (name config) FetchBatch err (groupCtxOf config))+            pure (Left err)+        -- Apply decodeHook on the catch-up path so catch-up batches are+        -- transformed identically to live batches (which the publisher+        -- transforms once before fan-out).+        Right events -> Right <$> decodeEvents stSettings events++-- Process a batch of events through the handler, resolving each event's+-- disposition. Returns the new cursor position if the batch was fully consumed+-- (every event resolved to 'Continue', 'DeadLetter', or an exhausted 'Retry'),+-- or 'Nothing' if the handler returned 'Stop'.+--+-- This is the single delivery primitive shared by the FSM 'DeliverBatch' effect+-- (catch-up for every target; AllStreams live) and the two DB-driven live loops,+-- so the four dispositions behave identically on every path (EP-2 / MasterPlan 6+-- Decision Log). Checkpointing keeps the existing per-batch model: 'Continue'+-- events advance the checkpoint only at the batch tail; 'Stop' checkpoints at the+-- stopping event; 'DeadLetter' (and exhausted 'Retry') atomically record the+-- event and advance the checkpoint past it via+-- 'SQL.insertDeadLetterAndCheckpointStmt'.+--+-- 'Retry' redelivers the same event after its 'RetryDelay', bounded by the+-- config's 'retryMaxAttempts'; while a redelivery is pending the worker's+-- observable state @TVar@ shows 'Retrying' (restored to the driving state — the+-- value the driver wrote before this batch — once the event resolves).+processEvents ::+    Pool ->+    SubscriptionConfig ->+    TVar SubscriptionState ->+    Vector RecordedEvent ->+    (KirokuEvent -> IO ()) ->+    IORef GlobalPosition ->+    IO (Maybe GlobalPosition)+processEvents pool config stateVar events emit posRef = do+    -- The state the driver wrote for this batch (CatchingUp / Live); restored+    -- after each retry so the observable state does not stick on 'Retrying'.+    driving <- atomically (readTVar stateVar)+    -- Emit one centralized per-batch delivery event for *every* target and both+    -- phases. This is the single delivery primitive, so this one emit uniformly+    -- covers catch-up for every target, AllStreams live, and the DB-driven live+    -- loops (which still also emit KirokuEventSubscriptionFetched per fetch).+    let phase = case driving of+            CatchingUp{} -> DeliveredCatchUp+            _ -> DeliveredLive+    emit (KirokuEventSubscriptionDelivered subName (V.length events) phase groupCtx)+    go driving 0+  where+    subName = name config+    groupCtx = groupCtxOf config+    maxAttempts = retryMaxAttempts (retryPolicy config)++    go driving i+        | i >= V.length events = do+            let lastEvent = V.last events+                newPos = globalPosition lastEvent+            writeIORef posRef newPos+            saveCheckpoint pool config newPos emit+            pure (Just newPos)+        | otherwise = do+            let event = events V.! i+                evtPos = globalPosition event+            writeIORef posRef evtPos+            if shouldDeliver (eventTypeFilter config) (selector config) event+                then deliver driving i event evtPos 1+                else -- Filtered out by the type filter or the selector: skip the+                -- handler entirely (so a non-matching event never reaches the+                -- bridge and is never retried or dead-lettered), but keep walking+                -- the batch so the batch-tail checkpoint advances the cursor past+                -- it. The subscription never stalls on a long run of filtered-out+                -- events.+                    go driving (i + 1)++    -- Deliver one event; @attempt@ is the 1-based delivery attempt (1 = first).+    deliver driving i event evtPos attempt = do+        result <- handler config event+        case result of+            Continue -> go driving (i + 1)+            Stop -> do+                -- Save checkpoint up to the event we just processed+                saveCheckpoint pool config evtPos emit+                pure Nothing+            DeadLetter reason -> do+                writeDeadLetter pool config evtPos event reason attempt emit+                go driving (i + 1)+            Retry delay+                -- Exhausted the retry budget: dead-letter and advance past it.+                | attempt >= maxAttempts -> do+                    writeDeadLetter pool config evtPos event (DeadLetterMaxAttempts attempt) attempt emit+                    go driving (i + 1)+                -- Redeliver the same event after the requested delay.+                | otherwise -> do+                    atomically (writeTVar stateVar (Retrying evtPos attempt))+                    emit (KirokuEventSubscriptionRetrying subName evtPos attempt groupCtx)+                    threadDelay (retryDelayMicros delay)+                    atomically (writeTVar stateVar driving)+                    deliver driving i event evtPos (attempt + 1)++-- Atomically record an event in @kiroku.dead_letters@ and advance the+-- subscription's checkpoint past it (one statement; the checkpoint does not+-- advance if the insert fails). On a database error the worker surfaces a+-- 'KirokuEventSubscriptionDbError' and rethrows, so the event is neither lost+-- nor silently skipped — it replays from the unadvanced checkpoint on restart.+writeDeadLetter ::+    Pool ->+    SubscriptionConfig ->+    GlobalPosition ->+    RecordedEvent ->+    DeadLetterReason ->+    -- | attempt count to record+    Int ->+    (KirokuEvent -> IO ()) ->+    IO ()+writeDeadLetter pool config gp@(GlobalPosition pos) event reason attempt emit = do+    let subName@(SubscriptionName name') = name config+        mem = configMember config+        EventId uuid = eventId event+        params =+            SQL.DeadLetterParams+                { SQL.dlSubscriptionName = name'+                , SQL.dlMember = mem+                , SQL.dlGlobalPosition = pos+                , SQL.dlEventId = uuid+                , SQL.dlReason = deadLetterReasonJson reason+                , SQL.dlReasonSummary = deadLetterSummary reason+                , SQL.dlAttemptCount = fromIntegral attempt+                }+    result <- Pool.use pool (Session.statement params SQL.insertDeadLetterAndCheckpointStmt)+    case result of+        Left err -> do+            emit (KirokuEventSubscriptionDbError subName SaveCheckpoint err (groupCtxOf config))+            throwIO err+        Right () -> emit (KirokuEventSubscriptionDeadLettered subName gp reason (groupCtxOf config))++-- Save a checkpoint to the database. Surfaces a database error through+-- the event handler; the worker continues running but the next restart+-- with the same name re-processes events the handler has already seen.+-- Keyed by (subscription_name, member) so each group member persists its own+-- position; non-group subscriptions use member 0 (see 'configMember').+saveCheckpoint ::+    Pool ->+    SubscriptionConfig ->+    GlobalPosition ->+    (KirokuEvent -> IO ()) ->+    IO ()+saveCheckpoint pool config (GlobalPosition pos) emit = do+    let subName@(SubscriptionName name') = name config+        mem = configMember config+    result <- Pool.use pool (Session.statement (name', mem, pos) SQL.saveCheckpointMemberStmt)+    case result of+        Left err -> emit (KirokuEventSubscriptionDbError subName SaveCheckpoint err (groupCtxOf config))+        Right () -> pure ()
+ src/Kiroku/Store/Transaction.hs view
@@ -0,0 +1,320 @@+{- | Transactional combinators that compose a Kiroku event-store+operation with arbitrary additional @hasql-transaction@ work in a+single ACID transaction.++This module is the entry point for callers — most prominently the+@keiro@ projection layer — that need to atomically write to their own+SQL tables in the same transaction as an event append. Three ergonomic+levels are provided:++* 'runTransaction' / 'runTransactionNoRetry' — bare escape hatch: run+  an opaque 'Tx.Transaction' against the store's connection pool.++* 'appendToStreamTx' — a 'Tx.Transaction'-flavored single-stream+  append. Useful inside a 'runTransaction' block when the caller+  wants full control over conflict handling.++* 'runTransactionAppending' / 'runTransactionAppendingNoRetry' — the+  recommended high-level wrapper that combines a single-stream append+  with the caller's 'Tx.Transaction' continuation in one atomic+  transaction. This is the primary API for @keiro@-style projection+  consumers.++The @-NoRetry@ variants use+'Hasql.Transaction.Sessions.transactionNoRetry' under the hood; the+default variants use 'Hasql.Transaction.Sessions.transaction', which+automatically retries the body on PostgreSQL serialization conflicts.+The retry runs the entire 'Tx.Transaction' value more than once. This+is safe for pure-SQL bodies (each retry's prior partial work rolls back+inside Postgres before the next attempt begins) but should be+considered when the caller reasons about external observability.++Mocking: a mock 'Kiroku.Store.Effect.Store' interpreter cannot+meaningfully execute an opaque 'Tx.Transaction' against in-memory state+and is expected to reject 'Kiroku.Store.Effect.RunTransaction' /+'Kiroku.Store.Effect.RunTransactionNoRetry' at runtime.+-}+module Kiroku.Store.Transaction (+    -- * Bare escape hatch+    runTransaction,+    runTransactionNoRetry,++    -- * Tx-flavored append building block+    appendToStreamTx,+    PreparedEvent,+    prepareEventsIO,++    -- * Convenience wrapper for the keiro use case+    runTransactionAppending,+    runTransactionAppendingNoRetry,+    runTransactionAppendingResource,+    runTransactionAppendingResourceNoRetry,++    -- * Manual enrichment for direct 'appendToStreamTx' callers+    enrichEventsIO,++    -- * Append-precondition conflicts+    AppendConflict (..),+    appendConflictToStoreError,+) where++import Control.Lens ((^.))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Functor (($>))+import Data.Generics.Labels ()+import Data.Time.Clock (UTCTime, getCurrentTime)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Hasql.Transaction qualified as Tx+import Kiroku.Store.Connection (KirokuStore)+import Kiroku.Store.Effect (PreparedEvent, Store (..), appendDispatchTx, buildAppendParams, prepareEvents)+import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore)+import Kiroku.Store.Error (AppendConflict (..), StoreError (..), appendConflictToStoreError, emptyResultConflict)+import Kiroku.Store.Settings qualified as Settings+import Kiroku.Store.Types++{- | Run an arbitrary 'Tx.Transaction' against the store's connection+pool inside a 'BEGIN'/'COMMIT' block.++The body may run /more than once/ if PostgreSQL raises a serialization+conflict — automatic retry is the default behavior of+'Hasql.Transaction.Sessions.transaction'. Use 'runTransactionNoRetry'+when retry is unacceptable (for example, the caller has been promised+exactly-once semantics that an outside observer of intermediate state+could break).++The body executes at 'Hasql.Transaction.Sessions.ReadCommitted'+isolation in 'Hasql.Transaction.Sessions.Write' mode, mirroring the+existing transactional sites in 'Kiroku.Store.Append.appendMultiStream'+and the hard-delete path.++Errors: a hasql 'Hasql.Pool.UsageError' is translated to+'Kiroku.Store.Error.ConnectionError'. Calling 'Tx.condemn' inside the+body marks the transaction for rollback at commit; the call returns the+final value the body produced, but no SQL writes from this transaction+will be visible. Mock interpreters of 'Store' reject this constructor.+-}+runTransaction ::+    (HasCallStack, Store :> es) =>+    Tx.Transaction a ->+    Eff es a+runTransaction tx = send (RunTransaction tx)++{- | Like 'runTransaction' but uses+'Hasql.Transaction.Sessions.transactionNoRetry' — the body is executed+exactly once even on PostgreSQL serialization conflicts. A conflict+surfaces as 'Kiroku.Store.Error.ConnectionError' carrying the underlying+'Hasql.Pool.UsageError'.+-}+runTransactionNoRetry ::+    (HasCallStack, Store :> es) =>+    Tx.Transaction a ->+    Eff es a+runTransactionNoRetry tx = send (RunTransactionNoRetry tx)++-- ---------------------------------------------------------------------------+-- Tx-flavored append+-- ---------------------------------------------------------------------------++{- | Generate UUIDv7s for any 'EventData' lacking a caller-supplied+'eventId' and return the prepared list, ready to feed into+'appendToStreamTx' inside a 'Tx.Transaction'.++'Tx.Transaction' has no 'MonadIO' instance, so UUID generation must+happen /before/ the transaction body runs. This helper is the IO-side+preparation step paired with 'appendToStreamTx'.+-}+prepareEventsIO :: (MonadIO m) => [EventData] -> m [PreparedEvent]+prepareEventsIO = prepareEvents++{- | Append a batch of events to a single stream as part of a larger+'Tx.Transaction'.++The 'Tx.Transaction'-flavored counterpart to+'Kiroku.Store.Append.appendToStream'. It does /not/ enforce the @$all@+reserved-stream check — callers should validate the stream name before+entering the transaction body, or use 'runTransactionAppending', which+performs the rejection up front.++The combinator returns 'Either' instead of throwing because+'Tx.Transaction' has no exception channel. On 'Left' the caller decides+whether to call 'Tx.condemn' to roll back the transaction, branch+around the conflict, or commit (which would persist the rest of the+transaction body without the append).++The events list must be pre-prepared via 'prepareEventsIO' (which+generates UUIDv7s) and the @createdAt@ timestamp must be captured by+the caller prior to entering the transaction body.++Empty event lists are a programming mistake — see+'Kiroku.Store.Append.appendToStream' for the rationale.+-}+appendToStreamTx ::+    StreamName ->+    ExpectedVersion ->+    [PreparedEvent] ->+    UTCTime ->+    Tx.Transaction (Either AppendConflict AppendResult)+appendToStreamTx sn@(StreamName name) expected prepared now = do+    let params = buildAppendParams name now prepared+    mResult <- appendDispatchTx expected params+    pure $ case mResult of+        Just r -> Right r+        Nothing -> Left (emptyResultConflict sn expected)++-- ---------------------------------------------------------------------------+-- Convenience wrapper+-- ---------------------------------------------------------------------------++{- | Append events to a single stream and run an arbitrary+'Tx.Transaction' continuation in one ACID transaction.++This is the recommended API for callers who want to combine an event+append with their own SQL writes (canonical example: a projection row+that must land iff the append commits).++Behavior:++* If the target stream is the reserved @$all@, the call rejects with+  @'Left' ('ReservedStreamName' …)@ /before/ opening any transaction;+  the continuation is not invoked.+* UUIDv7 ids are generated for events with a 'Nothing' 'eventId', and+  the current time is captured, before the transaction begins+  ('Tx.Transaction' has no 'MonadIO' so this prep cannot happen+  inside).+* Inside the transaction, 'appendToStreamTx' is called. On 'Left'+  (version conflict, missing stream, etc.), the transaction is+  'Tx.condemn'-ed, the continuation is /not/ run, and the call returns+  @'Left' storeErr@.+* On 'Right' the continuation runs with the resulting 'AppendResult'.+  If the continuation calls 'Tx.condemn', the transaction rolls back+  at commit time and no writes — including the event append — are+  visible.+* The transaction body may execute more than once if PostgreSQL raises+  a serialization conflict; use 'runTransactionAppendingNoRetry' to+  disable retry.++Connection-level failures from the @hasql-pool@ layer surface through+the surrounding @'Effectful.Error.Static.Error' 'StoreError'@ effect+('Kiroku.Store.Error.ConnectionError', 'ConnectionLost', etc.), not+through the returned 'Either' — that 'Either' is reserved for semantic+append-precondition conflicts (and the up-front reserved-stream+rejection).++This wrapper does /not/ apply the+'Kiroku.Store.Settings.enrichEvent' hook, because resolving the+'StoreSettings' requires reaching the live 'KirokuStore' handle and the+constraint set here is intentionally minimal. Callers running on a+'Kiroku.Store.Effect.Resource.KirokuStoreResource'-flavored stack and+wanting the hook should use 'runTransactionAppendingResource'; callers+on a bare stack can call 'enrichEventsIO' explicitly before invoking+this wrapper.+-}+runTransactionAppending ::+    (HasCallStack, IOE :> es, Store :> es) =>+    StreamName ->+    ExpectedVersion ->+    [EventData] ->+    (AppendResult -> Tx.Transaction a) ->+    Eff es (Either StoreError a)+runTransactionAppending = runTransactionAppendingWith RunTransaction++{- | Like 'runTransactionAppending' but uses+'Hasql.Transaction.Sessions.transactionNoRetry' under the hood — the+transaction body runs exactly once even on PostgreSQL serialization+conflicts.++Like 'runTransactionAppending', this wrapper bypasses the+'Kiroku.Store.Settings.enrichEvent' hook; see that function's+Haddock for guidance on hooking under different stacks.+-}+runTransactionAppendingNoRetry ::+    (HasCallStack, IOE :> es, Store :> es) =>+    StreamName ->+    ExpectedVersion ->+    [EventData] ->+    (AppendResult -> Tx.Transaction a) ->+    Eff es (Either StoreError a)+runTransactionAppendingNoRetry = runTransactionAppendingWith RunTransactionNoRetry++{- | Hook-aware variant of 'runTransactionAppending' for callers running+under a 'Kiroku.Store.Effect.Resource.KirokuStoreResource' effect.++Behaves exactly like 'runTransactionAppending' except that the+'Kiroku.Store.Settings.enrichEvent' hook (if any) is applied to every+'EventData' before the transaction body opens. The hook fires in+'IO', /outside/ the transaction; subsequent retries of a serialization+conflict do not re-invoke it (the enriched events are already prepared).++This is the recommended path for callers — most prominently the+@keiro@ projection layer — that want trace-context or PII-injection+hooks to fire uniformly across both direct @'appendToStream'@ calls+and transactional append+projection sites.+-}+runTransactionAppendingResource ::+    (HasCallStack, IOE :> es, KirokuStoreResource :> es, Store :> es) =>+    StreamName ->+    ExpectedVersion ->+    [EventData] ->+    (AppendResult -> Tx.Transaction a) ->+    Eff es (Either StoreError a)+runTransactionAppendingResource sn expected events k = do+    store <- getKirokuStore+    events' <- liftIO $ enrichEventsIO store events+    runTransactionAppendingWith RunTransaction sn expected events' k++{- | Like 'runTransactionAppendingResource' but uses+'Hasql.Transaction.Sessions.transactionNoRetry' under the hood.+-}+runTransactionAppendingResourceNoRetry ::+    (HasCallStack, IOE :> es, KirokuStoreResource :> es, Store :> es) =>+    StreamName ->+    ExpectedVersion ->+    [EventData] ->+    (AppendResult -> Tx.Transaction a) ->+    Eff es (Either StoreError a)+runTransactionAppendingResourceNoRetry sn expected events k = do+    store <- getKirokuStore+    events' <- liftIO $ enrichEventsIO store events+    runTransactionAppendingWith RunTransactionNoRetry sn expected events' k++{- | Apply the store's 'Kiroku.Store.Settings.enrichEvent' hook (if any)+to a list of 'EventData' values.++Use this when calling 'appendToStreamTx' directly — that lower-level+API does not see the interpreter and therefore does not run the hook+on its own. Calling 'enrichEventsIO' yourself before+'prepareEventsIO' restores hook coverage for that path.++When 'Kiroku.Store.Settings.enrichEvent' is 'Nothing' the function+returns the input list unchanged with no traversal.+-}+enrichEventsIO :: KirokuStore -> [EventData] -> IO [EventData]+enrichEventsIO store = Settings.enrichEvents (store ^. #storeSettings)++{- | Shared implementation for 'runTransactionAppending' and+'runTransactionAppendingNoRetry'. The only difference between the+two wrappers is which 'Store' constructor is sent.+-}+runTransactionAppendingWith ::+    (IOE :> es, Store :> es) =>+    (forall x. Tx.Transaction x -> Store (Eff es) x) ->+    StreamName ->+    ExpectedVersion ->+    [EventData] ->+    (AppendResult -> Tx.Transaction a) ->+    Eff es (Either StoreError a)+runTransactionAppendingWith ctor sn@(StreamName name) expected events k+    | name == "$all" = pure (Left (ReservedStreamName sn))+    | otherwise = do+        prepared <- prepareEventsIO events+        now <- liftIO getCurrentTime+        let body = do+                outcome <- appendToStreamTx sn expected prepared now+                case outcome of+                    Left conflict ->+                        Tx.condemn $> Left (appendConflictToStoreError conflict)+                    Right ar ->+                        Right <$> k ar+        send (ctor body)
+ src/Kiroku/Store/Types.hs view
@@ -0,0 +1,290 @@+module Kiroku.Store.Types (+    StreamName (..),+    StreamId (..),+    EventId (..),+    EventType (..),+    StreamVersion (..),+    GlobalPosition (..),+    ExpectedVersion (..),+    EventData (..),+    RecordedEvent (..),+    StreamInfo (..),+    AppendResult (..),+    LinkResult (..),+    CategoryName (..),+    EventFilter (..),+) where++import Data.Aeson (Value)+import Data.Int (Int64)+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.UUID (UUID)+import GHC.Generics (Generic)++-- Stream identification++{- | The human-readable name of a stream (e.g. @"orders-1"@). Stream names+are unique per store; the substring before the first @-@ is the+stream's category, used by 'CategoryName'-targeted reads and+subscriptions.++All names except @$all@ are ordinary application stream names. Names+such as @"invoice-payment"@, @"$invoice-payment"@, names containing+commas, and names without a dash are accepted by the store. The exact+name @$all@ is reserved for the global read stream and mutating APIs+reject it with 'Kiroku.Store.Error.ReservedStreamName'; use+'Kiroku.Store.Read.readAllForward' or+'Kiroku.Store.Read.readAllBackward' to read the global sequence.+-}+newtype StreamName = StreamName Text+    deriving stock (Eq, Ord, Show, Generic)++{- | The database surrogate id of a stream. Stable for the lifetime of+the stream row; reused by 'hardDeleteStream' followed by re-creation+only at the database's discretion. Not generally used by application+code — prefer 'StreamName' for identification.+-}+newtype StreamId = StreamId Int64+    deriving stock (Eq, Ord, Show, Generic)++-- Event identification++{- | The store's identifier for an event. Generated by the store as a+UUIDv7 unless the caller supplies one in 'EventData.eventId' (used for+idempotent retries — see 'appendToStream').++The 'Ord' instance compares by raw UUID byte order, /not/ by+generation time. UUIDv7 is timestamp-prefixed in its high bytes, so+byte order roughly matches generation order, but two ids generated in+the same millisecond can compare in either direction. For+time-ordering use 'RecordedEvent.globalPosition'.+-}+newtype EventId = EventId UUID+    deriving stock (Eq, Ord, Show, Generic)++{- | The application-level discriminator for an event payload (e.g.+@"OrderCreated"@). Free-form text; the store does not interpret it.+-}+newtype EventType = EventType Text+    deriving stock (Eq, Ord, Show, Generic)++-- Positions++{- | Monotonic per-stream version counter. Starts at 0 for a freshly+created empty stream and increments by one per appended event. After+@N@ events, the stream's version is @N@; the @i@-th event has+@streamVersion = i@ (one-indexed within a stream).+-}+newtype StreamVersion = StreamVersion Int64+    deriving stock (Eq, Ord, Show, Generic)++{- | Monotonic global position counter, shared across all streams.+Strictly increasing per successful append; gap-free under all four+'ExpectedVersion' paths (see EP-1's audit). Used by the @$all@ read+path and by subscriptions as the cursor key.+-}+newtype GlobalPosition = GlobalPosition Int64+    deriving stock (Eq, Ord, Show, Generic)++{- | Version expectations for appends.++The store enforces optimistic concurrency at the stream level: each+'appendToStream' call carries an 'ExpectedVersion' that the+@stream_version@ row must satisfy at commit time. A mismatch produces+'Kiroku.Store.Error.WrongExpectedVersion' or+'Kiroku.Store.Error.StreamAlreadyExists' depending on the constructor.+-}+data ExpectedVersion+    = {- | The stream must not exist yet. Creates the stream and appends+      the events. Fails with+      'Kiroku.Store.Error.StreamAlreadyExists' if the stream is+      already present, including soft-deleted streams. Use this for+      aggregate creation.+      -}+      NoStream+    | {- | The stream must already exist (and not be soft-deleted), but+      its current version does not matter. Fails with+      'Kiroku.Store.Error.StreamNotFound' if the stream is missing+      or soft-deleted.+      -}+      StreamExists+    | {- | The stream's current version must match exactly. Use this+      when the caller has read the stream and wants to append only+      if no concurrent writer has advanced it. Fails with+      'Kiroku.Store.Error.WrongExpectedVersion' on mismatch.+      -}+      ExactVersion !StreamVersion+    | {- | Upsert: create the stream if missing, append otherwise. Does+      not check the existing version. Maps to a single+      @INSERT ... ON CONFLICT DO UPDATE@ at the SQL layer. The name+      is historical — \"create-or-append\" is the working+      description.+      -}+      AnyVersion+    deriving stock (Eq, Show, Generic)++{- | What the caller provides when appending events.++Field accessors are intended to be used through @generic-lens@ labels+(@event ^. #eventType@); the cabal common stanza enables+@DuplicateRecordFields@ and @OverloadedLabels@ so the same field names+can appear on both 'EventData' and 'RecordedEvent'.+-}+data EventData = EventData+    { eventId :: !(Maybe EventId)+    {- ^ 'Nothing' lets the store generate a UUIDv7 at append time. 'Just'+    lets the caller supply an id, primarily to make appends idempotent+    across transient failures: a retry with the same id either succeeds+    (because the previous attempt did not commit) or surfaces as+    'Kiroku.Store.Error.DuplicateEvent' (because it did).+    -}+    , eventType :: !EventType+    {- ^ Application-level discriminator. Free-form; the store does not+    interpret it but it is indexed for queries.+    -}+    , payload :: !Value+    -- ^ The event's JSONB payload.+    , metadata :: !(Maybe Value)+    {- ^ Optional JSONB metadata. Often used for tenant ids, trace+    contexts, and correlation data.+    -}+    , causationId :: !(Maybe UUID)+    {- ^ Optional id of the event that caused this one (the immediate+    cause). Used to reconstruct chains.+    -}+    , correlationId :: !(Maybe UUID)+    {- ^ Optional correlation id (the saga / transaction this event+    belongs to). Distinct from @causationId@.+    -}+    }+    deriving stock (Show, Generic)++{- | Stream metadata returned by 'getStream'.++The 'id' field shadows 'Prelude.id' under 'DuplicateRecordFields'; access+it via @info ^. #id@ to disambiguate. 'Prelude.id' remains available as+@Data.Function.id@ if needed.+-}+data StreamInfo = StreamInfo+    { id :: !StreamId+    {- ^ The stream's database surrogate id. Stable for the row's+    lifetime.+    -}+    , name :: !StreamName+    -- ^ The stream's human-readable name as supplied at creation.+    , version :: !StreamVersion+    -- ^ The stream's current version (count of appended events).+    , createdAt :: !UTCTime+    -- ^ When the stream row was first inserted.+    , deletedAt :: !(Maybe UTCTime)+    {- ^ 'Just' the soft-delete timestamp if the stream has been+    soft-deleted, 'Nothing' otherwise. Hard-deleted streams do not+    appear in 'getStream' at all.+    -}+    }+    deriving stock (Eq, Show, Generic)++{- | What comes back from reading events.++For events read from their /source/ stream, @streamVersion@ and+@originalVersion@ agree, and @originalStreamId@ matches the stream being+read. For events read from a /linked/ target stream (one populated by+'linkToStream'), @streamVersion@ is the target's version (the position+of the link in the target stream) while @originalVersion@ is the+source's version (where the event lived when first appended) and+@originalStreamId@ is the source's id. Subscriptions and category reads+return events at their source positions.+-}+data RecordedEvent = RecordedEvent+    { eventId :: !EventId+    -- ^ The event's stable id (UUIDv7 by default).+    , eventType :: !EventType+    -- ^ The application-level type discriminator.+    , streamVersion :: !StreamVersion+    {- ^ Position in the stream being read. For source-stream reads this+    equals @originalVersion@; for linked-target reads it is the+    link's position in the target.+    -}+    , globalPosition :: !GlobalPosition+    {- ^ Position in the global @$all@ sequence at original-append time.+    Stable across links; used as the subscription cursor.+    -}+    , originalStreamId :: !StreamId+    {- ^ The surrogate id of the stream the event was first appended to. For+    fan-in reads (@$all@, categories, causation\/correlation queries,+    subscriptions) this is the only stream identifier on the event; resolve a+    batch of these to human-readable 'StreamName's with+    'Kiroku.Store.Read.lookupStreamNames'.+    -}+    , originalVersion :: !StreamVersion+    -- ^ The position the event was assigned in its source stream.+    , payload :: !Value+    , metadata :: !(Maybe Value)+    , causationId :: !(Maybe UUID)+    , correlationId :: !(Maybe UUID)+    , createdAt :: !UTCTime+    }+    deriving stock (Eq, Show, Generic)++-- | Result of a successful 'appendToStream' or 'appendMultiStream' call.+data AppendResult = AppendResult+    { streamId :: !StreamId+    {- ^ The id of the stream that was appended to (created if it did+    not exist).+    -}+    , streamVersion :: !StreamVersion+    {- ^ The stream's version after the append (the position of the+    /last/ event in the batch).+    -}+    , globalPosition :: !GlobalPosition+    -- ^ The global position assigned to the /last/ event in the batch.+    }+    deriving stock (Eq, Show, Generic)++{- | Result of a successful 'linkToStream' call.++There is no @globalPosition@ field because linking does not advance the+global counter — the linked events keep their original+'globalPosition'. To enumerate the new positions of linked events, read+the target stream after the call.+-}+data LinkResult = LinkResult+    { streamId :: !StreamId+    -- ^ The id of the link target (created if it did not exist).+    , streamVersion :: !StreamVersion+    {- ^ The target's version after the link (position of the /last/+    linked event in the target).+    -}+    }+    deriving stock (Eq, Show, Generic)++{- | The category prefix of a stream name (the part before the first+@-@). E.g., @StreamName "orders-1"@ has @CategoryName "orders"@. Used by+'readCategory' and category-targeted subscriptions to fan-in events from+many streams that share a prefix.+-}+newtype CategoryName = CategoryName Text+    deriving stock (Eq, Ord, Show, Generic)++{- | Filter passed to the 'Kiroku.Store.Effect.FindEvents' constructor and the+public smart constructors in "Kiroku.Store.Causation". Each constructor maps+to one SQL statement in "Kiroku.Store.SQL".++The sum is closed: mock interpreters that implement 'Kiroku.Store.Effect.Store'+can pattern-match exhaustively. Adding a new filter is a breaking change for+downstream interpreters and is captured by GHC's exhaustiveness check.+-}+data EventFilter+    = -- | Match every event whose @correlation_id@ equals the supplied UUID.+      FilterCorrelation !UUID+    | {- | Match the seed event and every event whose @causation_id@ chain+      walks back to it. The seed event itself is included as the depth-0+      row when it exists.+      -}+      FilterCausationDescendants !EventId+    | {- | Match the seed event and every event reachable by walking+      @causation_id@ upward from the seed. The seed itself is included.+      -}+      FilterCausationAncestors !EventId+    deriving stock (Eq, Show, Generic)
+ test/Main.hs view
@@ -0,0 +1,1870 @@+module Main where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM (atomically, check, newTVarIO, readTVar, writeTVar)+import Control.Exception (SomeException)+import Control.Exception qualified+import Control.Lens ((&), (.~), (^.))+import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Data.Aeson (Value (..))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int64)+import Data.Text qualified as T+import Data.UUID qualified as UUID+import Data.Vector qualified as V+import Effectful (Eff, IOE, runEff, (:>))+import Effectful.Error.Static (runErrorNoCallStack)+import Kiroku.Store+import Kiroku.Store.Error (extractStreamNameFromDetail)+import Kiroku.Store.Subscription.Effect qualified as SubEff+import Kiroku.Store.Subscription.EventPublisher (publisherPosition)+import Kiroku.Store.Subscription.Types (OverflowPolicy (..), SubscriptionConfigM (..), SubscriptionOverflowed (..))+import Kiroku.Test.Postgres (withMigratedTestDatabase)+import Test.CatchupDbErrorNoPrematureSwitch qualified as CatchupDbErrorNoPrematureSwitch+import Test.CategoryIdleNoSpin qualified as CategoryIdleNoSpin+import Test.Causation qualified as Causation+import Test.Concurrency qualified as Concurrency+import Test.ConsumerGroup qualified as ConsumerGroup+import Test.ConsumerGroupEffect qualified as ConsumerGroupEffect+import Test.ConsumerGroupSql qualified as ConsumerGroupSql+import Test.EventTypeFilter qualified as EventTypeFilter+import Test.FailureInjection qualified as FailureInjection+import Test.Helpers+import Test.Hspec+import Test.InterpreterHooks qualified as InterpreterHooks+import Test.Properties qualified as Properties+import Test.PublisherRestartNoRebroadcast qualified as PublisherRestartNoRebroadcast+import Test.ReadStream qualified as ReadStream+import Test.StreamNameLookup qualified as StreamNameLookup+import Test.SubscriptionPauseResume qualified as SubscriptionPauseResume+import Test.SubscriptionReconnect qualified as SubscriptionReconnect+import Test.SubscriptionRegistry qualified as SubscriptionRegistry+import Test.SubscriptionRetryDeadLetter qualified as SubscriptionRetryDeadLetter+import Test.SubscriptionState qualified as SubscriptionState+import Test.Transaction qualified as Transaction++main :: IO ()+main = withSharedMigratedPostgres $ hspec $ do+    Properties.spec+    Concurrency.spec+    FailureInjection.spec+    Transaction.spec+    ReadStream.spec+    StreamNameLookup.spec+    InterpreterHooks.spec+    Causation.spec+    ConsumerGroupSql.spec+    ConsumerGroup.spec+    ConsumerGroupEffect.spec+    CategoryIdleNoSpin.spec+    PublisherRestartNoRebroadcast.spec+    CatchupDbErrorNoPrematureSwitch.spec+    SubscriptionPauseResume.spec+    SubscriptionReconnect.spec+    SubscriptionState.spec+    SubscriptionRegistry.spec+    SubscriptionRetryDeadLetter.spec+    EventTypeFilter.spec+    around withTestStore $ do+        describe "schema migrations" $ do+            it "installs every Kiroku table under the kiroku schema" $ \store -> do+                let tables = ["streams", "events", "stream_events", "subscriptions"]+                results <- mapM (\t -> tableExists store ("kiroku." <> t)) tables+                results `shouldBe` replicate (length tables) True++            it "leaves the public schema free of Kiroku tables" $ \store -> do+                let tables = ["streams", "events", "stream_events", "subscriptions"]+                results <- mapM (\t -> tableExists store ("public." <> t)) tables+                results `shouldBe` replicate (length tables) False++            it "provides a UUIDv7 database default for direct event inserts" $ \store -> do+                eventIdText <- insertEventUsingDefaultId store+                version <- serverVersionNum store+                let isV7 = T.length eventIdText > 14 && T.index eventIdText 14 == '7'+                unless isV7 $+                    expectationFailure+                        ( "expected database-generated event_id to be UUIDv7 on PostgreSQL "+                            <> T.unpack version+                            <> ", got "+                            <> T.unpack eventIdText+                        )++        describe "appendToStream" $ do+            describe "NoStream" $ do+                it "creates a new stream and appends events" $ \store -> do+                    let event = makeEvent "OrderCreated" (Aeson.object [("orderId", Aeson.String "123")])+                    result <- runStoreIO store $ appendToStream (StreamName "order-123") NoStream [event]+                    case result of+                        Left err -> expectationFailure ("Expected success, got: " <> show err)+                        Right r -> do+                            (r ^. #streamVersion) `shouldBe` StreamVersion 1+                            (r ^. #globalPosition) `shouldBe` GlobalPosition 1++                it "fails when stream already exists" $ \store -> do+                    _ <- runStoreIO store $ appendToStream (StreamName "order-456") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+                    result <- runStoreIO store $ appendToStream (StreamName "order-456") NoStream [makeEvent "OrderUpdated" (Aeson.object [])]+                    case result of+                        Left (StreamAlreadyExists _) -> pure ()+                        other -> expectationFailure ("Expected StreamAlreadyExists, got: " <> show other)++            describe "ExactVersion" $ do+                it "appends when version matches" $ \store -> do+                    Right r1 <- runStoreIO store $ appendToStream (StreamName "order-789") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+                    (r1 ^. #streamVersion) `shouldBe` StreamVersion 1++                    result <- runStoreIO store $ appendToStream (StreamName "order-789") (ExactVersion (StreamVersion 1)) [makeEvent "OrderUpdated" (Aeson.object [])]+                    case result of+                        Left err -> expectationFailure ("Expected success, got: " <> show err)+                        Right r -> do+                            (r ^. #streamVersion) `shouldBe` StreamVersion 2+                            (r ^. #globalPosition) `shouldBe` GlobalPosition 2++                it "fails on version conflict" $ \store -> do+                    _ <- runStoreIO store $ appendToStream (StreamName "order-conflict") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+                    result <- runStoreIO store $ appendToStream (StreamName "order-conflict") (ExactVersion (StreamVersion 0)) [makeEvent "OrderUpdated" (Aeson.object [])]+                    case result of+                        Left (WrongExpectedVersion _ _ _) -> pure ()+                        other -> expectationFailure ("Expected WrongExpectedVersion, got: " <> show other)++            describe "StreamExists" $ do+                it "appends to an existing stream" $ \store -> do+                    _ <- runStoreIO store $ appendToStream (StreamName "stream-exists-test") NoStream [makeEvent "Created" (Aeson.object [])]+                    result <- runStoreIO store $ appendToStream (StreamName "stream-exists-test") StreamExists [makeEvent "Updated" (Aeson.object [])]+                    case result of+                        Left err -> expectationFailure ("Expected success, got: " <> show err)+                        Right r -> (r ^. #streamVersion) `shouldBe` StreamVersion 2++                it "fails when stream does not exist" $ \store -> do+                    result <- runStoreIO store $ appendToStream (StreamName "nonexistent-stream") StreamExists [makeEvent "Created" (Aeson.object [])]+                    case result of+                        Left (StreamNotFound _) -> pure ()+                        other -> expectationFailure ("Expected StreamNotFound, got: " <> show other)++            describe "AnyVersion" $ do+                it "creates a new stream" $ \store -> do+                    result <- runStoreIO store $ appendToStream (StreamName "any-new") AnyVersion [makeEvent "Created" (Aeson.object [])]+                    case result of+                        Left err -> expectationFailure ("Expected success, got: " <> show err)+                        Right r -> (r ^. #streamVersion) `shouldBe` StreamVersion 1++                it "appends to an existing stream" $ \store -> do+                    _ <- runStoreIO store $ appendToStream (StreamName "any-existing") AnyVersion [makeEvent "Created" (Aeson.object [])]+                    result <- runStoreIO store $ appendToStream (StreamName "any-existing") AnyVersion [makeEvent "Updated" (Aeson.object [])]+                    case result of+                        Left err -> expectationFailure ("Expected success, got: " <> show err)+                        Right r -> (r ^. #streamVersion) `shouldBe` StreamVersion 2++            describe "batch append" $ do+                it "appends multiple events with sequential versions" $ \store -> do+                    let events =+                            [ makeEvent "Event1" (Aeson.object [("n", Aeson.Number 1)])+                            , makeEvent "Event2" (Aeson.object [("n", Aeson.Number 2)])+                            , makeEvent "Event3" (Aeson.object [("n", Aeson.Number 3)])+                            ]+                    result <- runStoreIO store $ appendToStream (StreamName "batch-test") NoStream events+                    case result of+                        Left err -> expectationFailure ("Expected success, got: " <> show err)+                        Right r -> do+                            (r ^. #streamVersion) `shouldBe` StreamVersion 3+                            (r ^. #globalPosition) `shouldBe` GlobalPosition 3++            describe "global position contiguity" $ do+                it "assigns contiguous global positions across streams" $ \store -> do+                    Right r1 <- runStoreIO store $ appendToStream (StreamName "stream-a") NoStream [makeEvent "A" (Aeson.object [])]+                    (r1 ^. #globalPosition) `shouldBe` GlobalPosition 1++                    Right r2 <- runStoreIO store $ appendToStream (StreamName "stream-b") NoStream [makeEvent "B" (Aeson.object [])]+                    (r2 ^. #globalPosition) `shouldBe` GlobalPosition 2++                    Right r3 <- runStoreIO store $ appendToStream (StreamName "stream-c") NoStream [makeEvent "C" (Aeson.object [])]+                    (r3 ^. #globalPosition) `shouldBe` GlobalPosition 3++            describe "duplicate event ID" $ do+                it "rejects duplicate event IDs" $ \store -> do+                    let eid = EventId (case UUID.fromString "01234567-89ab-7def-8012-34567890abcd" of Just u -> u; Nothing -> error "bad uuid")+                    let event1 =+                            EventData+                                { eventId = Just eid+                                , eventType = EventType "Created"+                                , payload = Aeson.object []+                                , metadata = Nothing+                                , causationId = Nothing+                                , correlationId = Nothing+                                }+                    Right _ <- runStoreIO store $ appendToStream (StreamName "dup-test-1") NoStream [event1]++                    let event2 =+                            EventData+                                { eventId = Just eid+                                , eventType = EventType "Created"+                                , payload = Aeson.object []+                                , metadata = Nothing+                                , causationId = Nothing+                                , correlationId = Nothing+                                }+                    result <- runStoreIO store $ appendToStream (StreamName "dup-test-2") NoStream [event2]+                    case result of+                        Left (DuplicateEvent _) -> pure ()+                        other -> expectationFailure ("Expected DuplicateEvent, got: " <> show other)++            describe "stream-name contract" $ do+                it "treats system-looking names other than $all as ordinary streams" $ \store -> do+                    let names =+                            [ StreamName "invoice-payment"+                            , StreamName "$invoice-payment"+                            , StreamName "invoice,payment"+                            , StreamName "invoicepayment"+                            ]+                    mapM_+                        ( \name -> do+                            Right r <- runStoreIO store $ appendToStream name NoStream [makeEvent "StreamNameContract" (Aeson.object [])]+                            (r ^. #streamVersion) `shouldBe` StreamVersion 1+                            Right events <- runStoreIO store $ readStreamForward name (StreamVersion 0) 10+                            V.length events `shouldBe` 1+                        )+                        names++                it "rejects $all as an application append target" $ \store -> do+                    result <- runStoreIO store $ appendToStream (StreamName "$all") AnyVersion [makeEvent "BadAllAppend" (Aeson.object [])]+                    case result of+                        Left (ReservedStreamName (StreamName "$all")) -> pure ()+                        other -> expectationFailure ("Expected ReservedStreamName for $all append, got: " <> show other)+                    Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 10+                    V.length allEvents `shouldBe` 0++                it "rejects $all as a multi-stream append target without partial commit" $ \store -> do+                    result <-+                        runStoreIO store $+                            appendMultiStream+                                [ (StreamName "multi-reserved-ok", NoStream, [makeEvent "ShouldRollback" (Aeson.object [])])+                                , (StreamName "$all", AnyVersion, [makeEvent "BadAllMulti" (Aeson.object [])])+                                ]+                    case result of+                        Left (ReservedStreamName (StreamName "$all")) -> pure ()+                        other -> expectationFailure ("Expected ReservedStreamName for $all multi-stream append, got: " <> show other)+                    Right info <- runStoreIO store $ getStream (StreamName "multi-reserved-ok")+                    info `shouldBe` Nothing++                it "rejects $all as a link target" $ \store -> do+                    Right _ <- runStoreIO store $ appendToStream (StreamName "reserved-link-source") NoStream [makeEvent "Source" (Aeson.object [])]+                    Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "reserved-link-source") (StreamVersion 0) 10+                    let eid = V.head srcEvents ^. #eventId+                    result <- runStoreIO store $ linkToStream (StreamName "$all") [eid]+                    case result of+                        Left (ReservedStreamName (StreamName "$all")) -> pure ()+                        other -> expectationFailure ("Expected ReservedStreamName for $all link, got: " <> show other)+                    Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 10+                    V.length allEvents `shouldBe` 1++                it "rejects lifecycle operations against $all" $ \store -> do+                    soft <- runStoreIO store $ softDeleteStream (StreamName "$all")+                    hard <- runStoreIO store $ hardDeleteStream (StreamName "$all")+                    undel <- runStoreIO store $ undeleteStream (StreamName "$all")+                    let shouldBeReserved label result =+                            case result of+                                Left (ReservedStreamName (StreamName "$all")) -> pure ()+                                other -> expectationFailure ("Expected ReservedStreamName for " <> label <> ", got: " <> show other)+                    shouldBeReserved "softDeleteStream $all" soft+                    shouldBeReserved "hardDeleteStream $all" hard+                    shouldBeReserved "undeleteStream $all" undel+                    Right info <- runStoreIO store $ getStream (StreamName "$all")+                    case info of+                        Just si -> (si ^. #deletedAt) `shouldBe` Nothing+                        Nothing -> expectationFailure "Expected reserved $all stream row to remain present"++        describe "readStreamForward" $ do+            it "reads events in forward order (read-your-own-writes)" $ \store -> do+                let events =+                        [ makeEvent "A" (Aeson.object [("n", Aeson.Number 1)])+                        , makeEvent "B" (Aeson.object [("n", Aeson.Number 2)])+                        , makeEvent "C" (Aeson.object [("n", Aeson.Number 3)])+                        ]+                Right _ <- runStoreIO store $ appendToStream (StreamName "read-fwd") NoStream events+                Right result <- runStoreIO store $ readStreamForward (StreamName "read-fwd") (StreamVersion 0) 100+                V.length result `shouldBe` 3+                (V.head result ^. #eventType) `shouldBe` EventType "A"+                (result V.! 1 ^. #eventType) `shouldBe` EventType "B"+                (result V.! 2 ^. #eventType) `shouldBe` EventType "C"+                (V.head result ^. #streamVersion) `shouldBe` StreamVersion 1+                (result V.! 1 ^. #streamVersion) `shouldBe` StreamVersion 2+                (result V.! 2 ^. #streamVersion) `shouldBe` StreamVersion 3++        describe "readStreamBackward" $ do+            it "reads events in backward order" $ \store -> do+                let events =+                        [ makeEvent "A" (Aeson.object [])+                        , makeEvent "B" (Aeson.object [])+                        , makeEvent "C" (Aeson.object [])+                        ]+                Right _ <- runStoreIO store $ appendToStream (StreamName "read-bwd") NoStream events+                Right result <- runStoreIO store $ readStreamBackward (StreamName "read-bwd") (StreamVersion 0) 100+                V.length result `shouldBe` 3+                (V.head result ^. #eventType) `shouldBe` EventType "C"+                (result V.! 1 ^. #eventType) `shouldBe` EventType "B"+                (result V.! 2 ^. #eventType) `shouldBe` EventType "A"+                (V.head result ^. #streamVersion) `shouldBe` StreamVersion 3+                (result V.! 1 ^. #streamVersion) `shouldBe` StreamVersion 2+                (result V.! 2 ^. #streamVersion) `shouldBe` StreamVersion 1++        describe "cursor-based pagination" $ do+            it "paginates using stream version as cursor" $ \store -> do+                let events = map (\i -> makeEvent ("E" <> T.pack (show i)) (Aeson.object [])) [1 .. 5 :: Int]+                Right _ <- runStoreIO store $ appendToStream (StreamName "read-page") NoStream events+                -- Read first page of 2+                Right page1 <- runStoreIO store $ readStreamForward (StreamName "read-page") (StreamVersion 0) 2+                V.length page1 `shouldBe` 2+                let cursor1 = page1 V.! 1 ^. #streamVersion+                cursor1 `shouldBe` StreamVersion 2+                -- Read second page from cursor+                Right page2 <- runStoreIO store $ readStreamForward (StreamName "read-page") cursor1 2+                V.length page2 `shouldBe` 2+                (V.head page2 ^. #streamVersion) `shouldBe` StreamVersion 3+                -- Read third page — only 1 event left+                let cursor2 = page2 V.! 1 ^. #streamVersion+                Right page3 <- runStoreIO store $ readStreamForward (StreamName "read-page") cursor2 2+                V.length page3 `shouldBe` 1+                -- Read past end — empty+                let cursor3 = V.head page3 ^. #streamVersion+                Right page4 <- runStoreIO store $ readStreamForward (StreamName "read-page") cursor3 2+                V.length page4 `shouldBe` 0++        describe "readAllForward" $ do+            it "reads events from $all in global order" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "all-s1") NoStream [makeEvent "X" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "all-s2") NoStream [makeEvent "Y" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "all-s3") NoStream [makeEvent "Z" (Aeson.object [])]+                Right result <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+                V.length result `shouldBe` 3+                (V.head result ^. #eventType) `shouldBe` EventType "X"+                (result V.! 1 ^. #eventType) `shouldBe` EventType "Y"+                (result V.! 2 ^. #eventType) `shouldBe` EventType "Z"+                -- Global positions should be contiguous+                (V.head result ^. #globalPosition) `shouldBe` GlobalPosition 1+                (result V.! 1 ^. #globalPosition) `shouldBe` GlobalPosition 2+                (result V.! 2 ^. #globalPosition) `shouldBe` GlobalPosition 3++        describe "readAllBackward" $ do+            it "reads events from $all in reverse order" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "allb-s1") NoStream [makeEvent "X" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "allb-s2") NoStream [makeEvent "Y" (Aeson.object [])]+                Right result <- runStoreIO store $ readAllBackward (GlobalPosition 0) 100+                V.length result `shouldBe` 2+                (V.head result ^. #eventType) `shouldBe` EventType "Y"+                (result V.! 1 ^. #eventType) `shouldBe` EventType "X"++        describe "read empty/nonexistent stream" $ do+            it "returns empty Vector for nonexistent stream" $ \store -> do+                Right result <- runStoreIO store $ readStreamForward (StreamName "no-such-stream") (StreamVersion 0) 100+                V.length result `shouldBe` 0++        describe "getStream" $ do+            it "returns metadata for existing stream" $ \store -> do+                Right _ <-+                    runStoreIO store $+                        appendToStream+                            (StreamName "meta-test")+                            NoStream+                            [ makeEvent "A" (Aeson.object [])+                            , makeEvent "B" (Aeson.object [])+                            ]+                Right info <- runStoreIO store $ getStream (StreamName "meta-test")+                case info of+                    Just si -> do+                        (si ^. #name) `shouldBe` StreamName "meta-test"+                        (si ^. #version) `shouldBe` StreamVersion 2+                    Nothing -> expectationFailure "Expected Just StreamInfo, got Nothing"++            it "returns Nothing for nonexistent stream" $ \store -> do+                Right info <- runStoreIO store $ getStream (StreamName "no-such-stream")+                info `shouldBe` Nothing++        describe "lookupStreamId" $ do+            it "returns the same id as getStream for a live stream" $ \store -> do+                Right _ <-+                    runStoreIO store $+                        appendToStream+                            (StreamName "lookup-live")+                            NoStream+                            [makeEvent "A" (Aeson.object [])]+                Right mInfo <- runStoreIO store $ getStream (StreamName "lookup-live")+                Right mSid <- runStoreIO store $ lookupStreamId (StreamName "lookup-live")+                case (mInfo, mSid) of+                    (Just info, Just sid) ->+                        (info ^. #id) `shouldBe` sid+                    _ ->+                        expectationFailure "Expected both getStream and lookupStreamId to return Just"++            it "returns Nothing for a stream that has never been created" $ \store -> do+                Right mSid <- runStoreIO store $ lookupStreamId (StreamName "lookup-missing")+                mSid `shouldBe` Nothing++            it "returns Just the same id for a soft-deleted stream" $ \store -> do+                Right _ <-+                    runStoreIO store $+                        appendToStream+                            (StreamName "lookup-soft")+                            NoStream+                            [makeEvent "A" (Aeson.object [])]+                Right mSidBefore <- runStoreIO store $ lookupStreamId (StreamName "lookup-soft")+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "lookup-soft")+                Right mSidAfter <- runStoreIO store $ lookupStreamId (StreamName "lookup-soft")+                mSidAfter `shouldBe` mSidBefore+                Right mInfo <- runStoreIO store $ getStream (StreamName "lookup-soft")+                case (mInfo, mSidAfter) of+                    (Just info, Just sid) -> (info ^. #id) `shouldBe` sid+                    _ -> expectationFailure "Expected Just on a soft-deleted stream"++        describe "integration: full lifecycle through withStore" $ do+            it "append, read forward, read $all, getStream — all through public API" $ \store -> do+                -- Append events to two streams+                Right _ <-+                    runStoreIO store $+                        appendToStream+                            (StreamName "integ-orders")+                            NoStream+                            [ makeEvent "OrderCreated" (Aeson.object [("id", Aeson.String "1")])+                            , makeEvent "OrderShipped" (Aeson.object [("id", Aeson.String "1")])+                            ]+                Right _ <-+                    runStoreIO store $+                        appendToStream+                            (StreamName "integ-users")+                            NoStream+                            [ makeEvent "UserRegistered" (Aeson.object [("name", Aeson.String "alice")])+                            ]++                -- Read from a named stream+                Right orders <- runStoreIO store $ readStreamForward (StreamName "integ-orders") (StreamVersion 0) 100+                V.length orders `shouldBe` 2+                (V.head orders ^. #eventType) `shouldBe` EventType "OrderCreated"+                (orders V.! 1 ^. #eventType) `shouldBe` EventType "OrderShipped"++                -- Read from $all — should see all 3 events in global order+                Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+                V.length allEvents `shouldBe` 3+                (V.head allEvents ^. #globalPosition) `shouldBe` GlobalPosition 1+                (allEvents V.! 2 ^. #globalPosition) `shouldBe` GlobalPosition 3++                -- Query stream metadata+                Right orderInfo <- runStoreIO store $ getStream (StreamName "integ-orders")+                case orderInfo of+                    Just si -> (si ^. #version) `shouldBe` StreamVersion 2+                    Nothing -> expectationFailure "Expected stream info"++                Right noInfo <- runStoreIO store $ getStream (StreamName "nonexistent")+                noInfo `shouldBe` Nothing++        -- =================================================================+        -- Link tests (M5.8)+        -- =================================================================+        describe "linkToStream" $ do+            it "links a single event to a new stream" $ \store -> do+                let event = makeEvent "OrderCreated" (Aeson.object [("id", Aeson.String "1")])+                Right appendR <- runStoreIO store $ appendToStream (StreamName "source-1") NoStream [event]+                -- Read back to get the event ID+                Right events <- runStoreIO store $ readStreamForward (StreamName "source-1") (StreamVersion 0) 100+                let eid = V.head events ^. #eventId+                -- Link it+                Right linkR <- runStoreIO store $ linkToStream (StreamName "linked-1") [eid]+                (linkR ^. #streamVersion) `shouldBe` StreamVersion 1+                -- Read the linked stream+                Right linked <- runStoreIO store $ readStreamForward (StreamName "linked-1") (StreamVersion 0) 100+                V.length linked `shouldBe` 1+                (V.head linked ^. #eventId) `shouldBe` eid+                (V.head linked ^. #originalStreamId) `shouldBe` (appendR ^. #streamId)+                (V.head linked ^. #originalVersion) `shouldBe` StreamVersion 1++            it "links multiple events with sequential versions" $ \store -> do+                let events =+                        [ makeEvent "A" (Aeson.object [])+                        , makeEvent "B" (Aeson.object [])+                        , makeEvent "C" (Aeson.object [])+                        ]+                Right _ <- runStoreIO store $ appendToStream (StreamName "source-multi") NoStream events+                Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "source-multi") (StreamVersion 0) 100+                let eids = V.toList (V.map (^. #eventId) srcEvents)+                Right linkR <- runStoreIO store $ linkToStream (StreamName "linked-multi") eids+                (linkR ^. #streamVersion) `shouldBe` StreamVersion 3+                Right linked <- runStoreIO store $ readStreamForward (StreamName "linked-multi") (StreamVersion 0) 100+                V.length linked `shouldBe` 3+                (V.head linked ^. #streamVersion) `shouldBe` StreamVersion 1+                (linked V.! 1 ^. #streamVersion) `shouldBe` StreamVersion 2+                (linked V.! 2 ^. #streamVersion) `shouldBe` StreamVersion 3++            it "links events to an existing stream and bumps version" $ \store -> do+                let events1 = [makeEvent "A" (Aeson.object [])]+                    events2 = [makeEvent "B" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "src-a") NoStream events1+                Right _ <- runStoreIO store $ appendToStream (StreamName "src-b") NoStream events2+                Right evA <- runStoreIO store $ readStreamForward (StreamName "src-a") (StreamVersion 0) 100+                Right evB <- runStoreIO store $ readStreamForward (StreamName "src-b") (StreamVersion 0) 100+                let eidA = V.head evA ^. #eventId+                    eidB = V.head evB ^. #eventId+                -- Link first event+                Right r1 <- runStoreIO store $ linkToStream (StreamName "linked-existing") [eidA]+                (r1 ^. #streamVersion) `shouldBe` StreamVersion 1+                -- Link second event to same stream+                Right r2 <- runStoreIO store $ linkToStream (StreamName "linked-existing") [eidB]+                (r2 ^. #streamVersion) `shouldBe` StreamVersion 2+                -- Read all linked events+                Right linked <- runStoreIO store $ readStreamForward (StreamName "linked-existing") (StreamVersion 0) 100+                V.length linked `shouldBe` 2++            it "linked events still appear in $all at original global positions" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "orig-all") NoStream [makeEvent "X" (Aeson.object [])]+                Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "orig-all") (StreamVersion 0) 100+                let eid = V.head srcEvents ^. #eventId+                _ <- runStoreIO store $ linkToStream (StreamName "linked-all") [eid]+                -- Read $all — should have exactly 1 event (not duplicated)+                Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+                let matchingEvents = V.filter (\e -> (e ^. #eventId) == eid) allEvents+                V.length matchingEvents `shouldBe` 1++            it "rejects linking the same event to the same stream twice" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "src-dup") NoStream [makeEvent "X" (Aeson.object [])]+                Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "src-dup") (StreamVersion 0) 100+                let eid = V.head srcEvents ^. #eventId+                Right _ <- runStoreIO store $ linkToStream (StreamName "linked-dup") [eid]+                result <- runStoreIO store $ linkToStream (StreamName "linked-dup") [eid]+                case result of+                    Left _ -> pure () -- Expected: some error (PK violation)+                    Right _ -> expectationFailure "Expected error for duplicate link"++            -- F3 regression — silent version gap when source events do not exist.+            -- Before the fix, the CTE's `JOIN LATERAL` silently dropped link rows for+            -- event_ids that had no `stream_events` row (e.g. never existed, or were+            -- hard-deleted). The `stream_upsert` had already bumped `stream_version`,+            -- so the stream advanced by N but only some link rows were inserted.+            it "rejects link when the source event does not exist" $ \store -> do+                let bogus = EventId (case UUID.fromString "11111111-1111-7111-8111-111111111111" of Just u -> u; Nothing -> error "bad uuid")+                result <- runStoreIO store $ linkToStream (StreamName "f3-bogus") [bogus]+                case result of+                    Left _ -> pure ()+                    Right r -> expectationFailure ("Expected error for missing event, got: " <> show r)+                -- Target stream must not have been left in a half-created state.+                Right info <- runStoreIO store $ getStream (StreamName "f3-bogus")+                info `shouldBe` Nothing++            it "rejects link with a mix of valid and missing events (no partial commit)" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "f3-mixed-src") NoStream [makeEvent "Real" (Aeson.object [])]+                Right realEvents <- runStoreIO store $ readStreamForward (StreamName "f3-mixed-src") (StreamVersion 0) 100+                let realId = V.head realEvents ^. #eventId+                let bogus = EventId (case UUID.fromString "22222222-2222-7222-8222-222222222222" of Just u -> u; Nothing -> error "bad uuid")+                result <- runStoreIO store $ linkToStream (StreamName "f3-mixed-tgt") [realId, bogus]+                case result of+                    Left _ -> pure ()+                    Right r -> expectationFailure ("Expected error for partial-missing batch, got: " <> show r)+                Right info <- runStoreIO store $ getStream (StreamName "f3-mixed-tgt")+                info `shouldBe` Nothing++            -- F5 regression — linkToStream against a soft-deleted target stream.+            -- Symmetric with the appendAnyVersion soft-delete check from F2: the+            -- DO UPDATE clause's WHERE filters on deleted_at IS NULL, so the+            -- upsert returns no row and the interpreter maps that to StreamNotFound.+            it "rejects link to a soft-deleted target stream" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "f5-src") NoStream [makeEvent "X" (Aeson.object [])]+                Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "f5-src") (StreamVersion 0) 100+                let eid = V.head srcEvents ^. #eventId+                Right _ <- runStoreIO store $ appendToStream (StreamName "f5-target") NoStream [makeEvent "Init" (Aeson.object [])]+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "f5-target")+                result <- runStoreIO store $ linkToStream (StreamName "f5-target") [eid]+                case result of+                    Left (StreamNotFound _) -> pure ()+                    other -> expectationFailure ("Expected StreamNotFound for soft-deleted target, got: " <> show other)+                -- Soft-deleted target's version must not have advanced.+                Right info <- runStoreIO store $ getStream (StreamName "f5-target")+                case info of+                    Just si -> (si ^. #version) `shouldBe` StreamVersion 1+                    Nothing -> expectationFailure "soft-deleted stream row should still exist"++        -- =================================================================+        -- Category read tests (M5.8)+        -- =================================================================+        describe "readCategory" $ do+            it "reads events from matching category streams in global position order" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "order-1") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "order-2") NoStream [makeEvent "OrderShipped" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "user-1") NoStream [makeEvent "UserRegistered" (Aeson.object [])]+                Right result <- runStoreIO store $ readCategory (CategoryName "order") (GlobalPosition 0) 100+                V.length result `shouldBe` 2+                (V.head result ^. #eventType) `shouldBe` EventType "OrderCreated"+                (result V.! 1 ^. #eventType) `shouldBe` EventType "OrderShipped"+                -- Verify global positions are ascending+                (V.head result ^. #globalPosition) `shouldSatisfy` (< (result V.! 1 ^. #globalPosition))++            it "supports pagination with start position and limit" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "cat-1") NoStream [makeEvent "A" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "cat-2") NoStream [makeEvent "B" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "cat-3") NoStream [makeEvent "C" (Aeson.object [])]+                -- Read first 2+                Right page1 <- runStoreIO store $ readCategory (CategoryName "cat") (GlobalPosition 0) 2+                V.length page1 `shouldBe` 2+                -- Read from cursor+                let cursor = page1 V.! 1 ^. #globalPosition+                Right page2 <- runStoreIO store $ readCategory (CategoryName "cat") cursor 100+                V.length page2 `shouldBe` 1++            it "returns empty for nonexistent category" $ \store -> do+                Right result <- runStoreIO store $ readCategory (CategoryName "nope") (GlobalPosition 0) 100+                V.length result `shouldBe` 0++            it "includes linked events that originate from category streams" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "evt-1") NoStream [makeEvent "EventA" (Aeson.object [])]+                Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "evt-1") (StreamVersion 0) 100+                let eid = V.head srcEvents ^. #eventId+                -- Link into a different-category stream+                Right _ <- runStoreIO store $ linkToStream (StreamName "projection-1") [eid]+                -- Category "evt" should still return the event (it originates from evt-1)+                Right result <- runStoreIO store $ readCategory (CategoryName "evt") (GlobalPosition 0) 100+                V.length result `shouldBe` 1+                (V.head result ^. #eventType) `shouldBe` EventType "EventA"++        -- =================================================================+        -- Multi-stream transaction tests (M5.8)+        -- =================================================================+        describe "appendMultiStream" $ do+            it "atomically appends to two streams" $ \store -> do+                let ops =+                        [ (StreamName "multi-a", NoStream, [makeEvent "A" (Aeson.object [])])+                        , (StreamName "multi-b", NoStream, [makeEvent "B" (Aeson.object [])])+                        ]+                Right results <- runStoreIO store $ appendMultiStream ops+                length results `shouldBe` 2+                ((results !! 0) ^. #streamVersion) `shouldBe` StreamVersion 1+                ((results !! 1) ^. #streamVersion) `shouldBe` StreamVersion 1++            it "rolls back all streams on version conflict" $ \store -> do+                -- Create stream multi-c+                Right _ <- runStoreIO store $ appendToStream (StreamName "multi-c") NoStream [makeEvent "C" (Aeson.object [])]+                let ops =+                        [ (StreamName "multi-d", NoStream, [makeEvent "D" (Aeson.object [])])+                        , (StreamName "multi-c", NoStream, [makeEvent "C2" (Aeson.object [])]) -- conflict: already exists+                        ]+                result <- runStoreIO store $ appendMultiStream ops+                case result of+                    Left _ -> do+                        -- Verify multi-d was NOT created (rollback)+                        Right info <- runStoreIO store $ getStream (StreamName "multi-d")+                        info `shouldBe` Nothing+                    Right _ -> expectationFailure "Expected error for version conflict"++            it "appends to three streams with different expected versions" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "tri-1") NoStream [makeEvent "X" (Aeson.object [])]+                let ops =+                        [ (StreamName "tri-1", ExactVersion (StreamVersion 1), [makeEvent "X2" (Aeson.object [])])+                        , (StreamName "tri-2", NoStream, [makeEvent "Y" (Aeson.object [])])+                        , (StreamName "tri-3", AnyVersion, [makeEvent "Z" (Aeson.object [])])+                        ]+                Right results <- runStoreIO store $ appendMultiStream ops+                length results `shouldBe` 3+                ((results !! 0) ^. #streamVersion) `shouldBe` StreamVersion 2+                ((results !! 1) ^. #streamVersion) `shouldBe` StreamVersion 1+                ((results !! 2) ^. #streamVersion) `shouldBe` StreamVersion 1++            -- F4 regression — pre-lock pass over named streams in stream_id order.+            -- The deterministic deadlock-prevention scenario (two concurrent calls+            -- touching the same streams in opposite orders) is covered by EP-6's+            -- planned concurrency-test harness; this test verifies that the+            -- pre-lock does not change user-visible ordering of global positions+            -- within a single multi-stream call.+            it "preserves user-supplied ordering of global positions" $ \store -> do+                let ops =+                        [ (StreamName "f4-zzz", NoStream, [makeEvent "Z" (Aeson.object [])])+                        , (StreamName "f4-mmm", NoStream, [makeEvent "M" (Aeson.object [])])+                        , (StreamName "f4-aaa", NoStream, [makeEvent "A" (Aeson.object [])])+                        ]+                Right results <- runStoreIO store $ appendMultiStream ops+                length results `shouldBe` 3+                let p0 = (results !! 0) ^. #globalPosition+                    p1 = (results !! 1) ^. #globalPosition+                    p2 = (results !! 2) ^. #globalPosition+                p0 `shouldSatisfy` (< p1)+                p1 `shouldSatisfy` (< p2)+                -- Read $all and confirm the events appear in user-supplied order.+                Right allEvts <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+                let names = V.toList (V.map (^. #eventType) allEvts)+                names `shouldBe` [EventType "Z", EventType "M", EventType "A"]++        -- =================================================================+        -- Soft delete tests (M6.8)+        -- =================================================================+        describe "softDeleteStream" $ do+            it "soft-deletes a stream and getStream shows deletedAt" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "del-1") NoStream [makeEvent "A" (Aeson.object [])]+                Right mId <- runStoreIO store $ softDeleteStream (StreamName "del-1")+                mId `shouldSatisfy` (/= Nothing)+                Right info <- runStoreIO store $ getStream (StreamName "del-1")+                case info of+                    Just si -> (si ^. #deletedAt) `shouldSatisfy` (/= Nothing)+                    Nothing -> expectationFailure "Expected stream info with deletedAt set"++            it "returns empty for reads from a soft-deleted stream" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "del-read") NoStream [makeEvent "A" (Aeson.object [])]+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "del-read")+                Right fwd <- runStoreIO store $ readStreamForward (StreamName "del-read") (StreamVersion 0) 100+                V.length fwd `shouldBe` 0+                Right bwd <- runStoreIO store $ readStreamBackward (StreamName "del-read") (StreamVersion 0) 100+                V.length bwd `shouldBe` 0++            it "rejects appends to a soft-deleted stream" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "del-append") NoStream [makeEvent "A" (Aeson.object [])]+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "del-append")+                result <- runStoreIO store $ appendToStream (StreamName "del-append") StreamExists [makeEvent "B" (Aeson.object [])]+                case result of+                    Left (StreamNotFound _) -> pure ()+                    other -> expectationFailure ("Expected StreamNotFound, got: " <> show other)++            it "returns Nothing for nonexistent stream" $ \store -> do+                Right mId <- runStoreIO store $ softDeleteStream (StreamName "no-such")+                mId `shouldBe` Nothing++            it "returns Nothing for already-deleted stream" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "del-twice") NoStream [makeEvent "A" (Aeson.object [])]+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "del-twice")+                Right mId <- runStoreIO store $ softDeleteStream (StreamName "del-twice")+                mId `shouldBe` Nothing++            it "events from soft-deleted stream still appear in $all" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "del-all") NoStream [makeEvent "KeepInAll" (Aeson.object [])]+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "del-all")+                Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+                let matching = V.filter (\e -> (e ^. #eventType) == EventType "KeepInAll") allEvents+                V.length matching `shouldBe` 1++            -- F2 regression — the protection against writes to a soft-deleted stream is+            -- enforced by a `deleted_at IS NULL` filter inside each append CTE, not by a+            -- pre-check that races concurrent soft-deletes. These tests exercise every+            -- append variant so a reader can see at a glance which constructor maps to+            -- which error after a soft-delete.+            it "ExactVersion append rejected against soft-deleted stream" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "f2-cte-exv") NoStream [makeEvent "Init" (Aeson.object [])]+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "f2-cte-exv")+                result <- runStoreIO store $ appendToStream (StreamName "f2-cte-exv") (ExactVersion (StreamVersion 1)) [makeEvent "X" (Aeson.object [])]+                case result of+                    Left (WrongExpectedVersion _ _ _) -> pure ()+                    Left (StreamNotFound _) -> pure ()+                    other -> expectationFailure ("Expected WrongExpectedVersion or StreamNotFound, got: " <> show other)++            it "AnyVersion append rejected against soft-deleted stream" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "f2-cte-any") NoStream [makeEvent "Init" (Aeson.object [])]+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "f2-cte-any")+                result <- runStoreIO store $ appendToStream (StreamName "f2-cte-any") AnyVersion [makeEvent "X" (Aeson.object [])]+                case result of+                    Left (StreamNotFound _) -> pure ()+                    other -> expectationFailure ("Expected StreamNotFound, got: " <> show other)++            it "NoStream append rejected against soft-deleted stream" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "f2-cte-no") NoStream [makeEvent "Init" (Aeson.object [])]+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "f2-cte-no")+                result <- runStoreIO store $ appendToStream (StreamName "f2-cte-no") NoStream [makeEvent "X" (Aeson.object [])]+                case result of+                    Left (StreamAlreadyExists _) -> pure ()+                    other -> expectationFailure ("Expected StreamAlreadyExists, got: " <> show other)++        -- =================================================================+        -- Undelete tests (M6.8)+        -- =================================================================+        describe "undeleteStream" $ do+            it "restores a soft-deleted stream" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "undel-1") NoStream [makeEvent "A" (Aeson.object [])]+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "undel-1")+                Right mId <- runStoreIO store $ undeleteStream (StreamName "undel-1")+                mId `shouldSatisfy` (/= Nothing)+                Right info <- runStoreIO store $ getStream (StreamName "undel-1")+                case info of+                    Just si -> (si ^. #deletedAt) `shouldBe` Nothing+                    Nothing -> expectationFailure "Expected stream info"++            it "reads work after undelete" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "undel-read") NoStream [makeEvent "A" (Aeson.object [])]+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "undel-read")+                Right _ <- runStoreIO store $ undeleteStream (StreamName "undel-read")+                Right events <- runStoreIO store $ readStreamForward (StreamName "undel-read") (StreamVersion 0) 100+                V.length events `shouldBe` 1++            it "appends work after undelete" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "undel-append") NoStream [makeEvent "A" (Aeson.object [])]+                Right _ <- runStoreIO store $ softDeleteStream (StreamName "undel-append")+                Right _ <- runStoreIO store $ undeleteStream (StreamName "undel-append")+                Right r <- runStoreIO store $ appendToStream (StreamName "undel-append") StreamExists [makeEvent "B" (Aeson.object [])]+                (r ^. #streamVersion) `shouldBe` StreamVersion 2++            it "returns Nothing for non-deleted stream" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "undel-noop") NoStream [makeEvent "A" (Aeson.object [])]+                Right mId <- runStoreIO store $ undeleteStream (StreamName "undel-noop")+                mId `shouldBe` Nothing++        -- =================================================================+        -- Hard delete tests (M6.8)+        -- =================================================================+        describe "hardDeleteStream" $ do+            it "hard-deletes a stream completely" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "hard-1") NoStream [makeEvent "A" (Aeson.object [])]+                Right mId <- runStoreIO store $ hardDeleteStream (StreamName "hard-1")+                mId `shouldSatisfy` (/= Nothing)+                Right info <- runStoreIO store $ getStream (StreamName "hard-1")+                info `shouldBe` Nothing++            it "events from hard-deleted stream no longer appear in $all" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "hard-all") NoStream [makeEvent "HardDelEvent" (Aeson.object [])]+                Right _ <- runStoreIO store $ hardDeleteStream (StreamName "hard-all")+                Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+                let matching = V.filter (\e -> (e ^. #eventType) == EventType "HardDelEvent") allEvents+                V.length matching `shouldBe` 0++            it "returns Nothing for nonexistent stream" $ \store -> do+                Right mId <- runStoreIO store $ hardDeleteStream (StreamName "hard-no-such")+                mId `shouldBe` Nothing++            -- F6 regression — TRUNCATE on protected tables must be gated by the+            -- same GUC as DELETE. Without the BEFORE TRUNCATE triggers added in+            -- EP-1 F6, an operator could TRUNCATE events / stream_events / streams+            -- without setting kiroku.enable_hard_deletes, bypassing the row-level+            -- protect_deletion check.+            it "TRUNCATE on events is rejected without the GUC" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "f6-truncate") NoStream [makeEvent "X" (Aeson.object [])]+                rejected <- truncateRejected store "events"+                rejected `shouldBe` True++            it "TRUNCATE on stream_events is rejected without the GUC" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "f6-truncate-se") NoStream [makeEvent "X" (Aeson.object [])]+                rejected <- truncateRejected store "stream_events"+                rejected `shouldBe` True++            it "TRUNCATE on streams is rejected without the GUC" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "f6-truncate-s") NoStream [makeEvent "X" (Aeson.object [])]+                rejected <- truncateRejected store "streams"+                rejected `shouldBe` True++            -- F1 regression — events orphaned in `events` table after hard-delete.+            it "removes orphan event payloads from the events table" $ \store -> do+                let evts = map (\i -> makeEvent ("F1Orphan" <> T.pack (show i)) (Aeson.object [])) [1 .. 3 :: Int]+                Right _ <- runStoreIO store $ appendToStream (StreamName "f1-orphan") NoStream evts+                before <- countEvents store+                Right _ <- runStoreIO store $ hardDeleteStream (StreamName "f1-orphan")+                after <- countEvents store+                (before - after) `shouldBe` 3++            -- F1 regression — events that are linked to other streams must survive+            -- hard-delete of their source stream's owner if any non-target junctions remain.+            it "preserves events still linked to non-target streams" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "f1-keep-src") NoStream [makeEvent "Keep" (Aeson.object [])]+                Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "f1-keep-src") (StreamVersion 0) 100+                let eid = V.head srcEvents ^. #eventId+                -- Append another stream that gets a different event so we can hard-delete keep-src+                -- without touching the linked stream's source. Then link f1-keep-src's event to a+                -- third stream we will leave alone.+                Right _ <- runStoreIO store $ appendToStream (StreamName "f1-other") NoStream [makeEvent "Other" (Aeson.object [])]+                -- Link via appendToStream + linkToStream to a different stream+                _ <- runStoreIO store $ linkToStream (StreamName "f1-keep-link") [eid]+                -- Hard-deleting f1-keep-src removes the source's events even though the link+                -- referenced them: link rows have original_stream_id = f1-keep-src's id, so they+                -- match the junction-delete WHERE clause. The contract is documented in F1's fix+                -- commit: hard-delete cascades through link junctions of the deleted stream's+                -- original events. (See SQL.hs hard-delete documentation.)+                Right _ <- runStoreIO store $ hardDeleteStream (StreamName "f1-keep-src")+                -- f1-other's event must still exist (not affected at all).+                Right otherEvents <- runStoreIO store $ readStreamForward (StreamName "f1-other") (StreamVersion 0) 100+                V.length otherEvents `shouldBe` 1++        -- =================================================================+        -- Subscription tests (M7.7)+        -- =================================================================+        describe "subscribe" $ do+            it "catches up from position 0 on a store with existing events" $ \store -> do+                -- Append 10 events+                let events = map (\i -> makeEvent ("E" <> T.pack (show i)) (Aeson.object [])) [1 .. 10 :: Int]+                Right _ <- runStoreIO store $ appendToStream (StreamName "catchup-1") NoStream events+                -- Wait until the EventPublisher has ingested all 10 events.+                waitForPublisher store (GlobalPosition 10)+                -- Subscribe from position 0+                ref <- newIORef ([] :: [RecordedEvent])+                countRef <- newTVarIO (0 :: Int)+                let handler' evt = do+                        modifyIORef' ref (evt :)+                        n <- atomically $ do+                            c <- readTVar countRef+                            let c' = c + 1+                            writeTVar countRef c'+                            pure c'+                        if n >= 10+                            then pure Stop+                            else pure Continue+                let cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "catchup-test"+                            , target = AllStreams+                            , handler = handler'+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                handle <- subscribe store cfg+                result <- waitWithTimeout 10_000_000 handle+                case result of+                    Left timeout -> expectationFailure timeout+                    Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                    Right (Right ()) -> pure ()+                collected <- readIORef ref+                length collected `shouldBe` 10++            it "receives live events appended after subscription starts" $ \store -> do+                ref <- newIORef ([] :: [RecordedEvent])+                countRef <- newTVarIO (0 :: Int)+                let handler' evt = do+                        modifyIORef' ref (evt :)+                        n <- atomically $ do+                            c <- readTVar countRef+                            let c' = c + 1+                            writeTVar countRef c'+                            pure c'+                        if n >= 5+                            then pure Stop+                            else pure Continue+                let cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "live-test"+                            , target = AllStreams+                            , handler = handler'+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                handle <- subscribe store cfg+                -- Give subscription time to start+                threadDelay 100_000+                -- Append 5 events+                let events = map (\i -> makeEvent ("Live" <> T.pack (show i)) (Aeson.object [])) [1 .. 5 :: Int]+                Right _ <- runStoreIO store $ appendToStream (StreamName "live-1") NoStream events+                -- Wait for subscription to complete+                result <- waitWithTimeout 10_000_000 handle+                case result of+                    Left timeout -> expectationFailure timeout+                    Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                    Right (Right ()) -> pure ()+                collected <- readIORef ref+                length collected `shouldBe` 5++            it "persists checkpoint and resumes from saved position" $ \store -> do+                -- Append 10 events+                let events = map (\i -> makeEvent ("CP" <> T.pack (show i)) (Aeson.object [])) [1 .. 10 :: Int]+                Right _ <- runStoreIO store $ appendToStream (StreamName "ckpt-1") NoStream events+                waitForPublisher store (GlobalPosition 10)+                -- First subscription: process 5 events then stop+                countRef1 <- newTVarIO (0 :: Int)+                let handler1 _evt = do+                        n <- atomically $ do+                            c <- readTVar countRef1+                            let c' = c + 1+                            writeTVar countRef1 c'+                            pure c'+                        if n >= 5+                            then pure Stop+                            else pure Continue+                let cfg1 =+                        SubscriptionConfig+                            { name = SubscriptionName "ckpt-test"+                            , target = AllStreams+                            , handler = handler1+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                h1 <- subscribe store cfg1+                _ <- waitWithTimeout 10_000_000 h1+                -- Second subscription with same name: should resume from position 5+                ref2 <- newIORef ([] :: [RecordedEvent])+                countRef2 <- newTVarIO (0 :: Int)+                let handler2 evt = do+                        modifyIORef' ref2 (evt :)+                        n <- atomically $ do+                            c <- readTVar countRef2+                            let c' = c + 1+                            writeTVar countRef2 c'+                            pure c'+                        if n >= 5+                            then pure Stop+                            else pure Continue+                let cfg2 =+                        SubscriptionConfig+                            { name = SubscriptionName "ckpt-test"+                            , target = AllStreams+                            , handler = handler2+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                h2 <- subscribe store cfg2+                _ <- waitWithTimeout 10_000_000 h2+                collected <- readIORef ref2+                -- Should receive events 6–10 only+                length collected `shouldBe` 5++            it "does not replay catch-up events when switching to all-stream live mode" $ \store -> do+                let seedEvents = map (\i -> makeEvent ("TransitionSeed" <> T.pack (show i)) (Aeson.object [])) [1 .. 5 :: Int]+                Right _ <- runStoreIO store $ appendToStream (StreamName "transition-seed") NoStream seedEvents+                waitForPublisher store (GlobalPosition 5)++                firstSeen <- newEmptyMVar+                releaseFirst <- newEmptyMVar+                countRef <- newTVarIO (0 :: Int)+                ref <- newIORef ([] :: [RecordedEvent])+                let stopType = EventType "TransitionStopAfterLive"+                    handler' evt = do+                        modifyIORef' ref (evt :)+                        n <- atomically $ do+                            c <- readTVar countRef+                            let c' = c + 1+                            writeTVar countRef c'+                            pure c'+                        if n == 1+                            then do+                                putMVar firstSeen ()+                                takeMVar releaseFirst+                            else pure ()+                        if evt ^. #eventType == stopType+                            then pure Stop+                            else pure Continue+                let cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "transition-no-duplicates"+                            , target = AllStreams+                            , handler = handler'+                            , batchSize = 2+                            , queueCapacity = 32+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                handle <- subscribe store cfg+                takeMVar firstSeen++                mapM_+                    ( \i -> do+                        let sn = StreamName ("transition-during-" <> T.pack (show (i :: Int)))+                        Right _ <- runStoreIO store $ appendToStream sn NoStream [makeEvent ("TransitionDuring" <> T.pack (show i)) (Aeson.object [])]+                        pure ()+                    )+                    [6 .. 10]+                waitForPublisher store (GlobalPosition 10)+                putMVar releaseFirst ()+                atomically $ do+                    c <- readTVar countRef+                    check (c >= 10)++                Right _ <- runStoreIO store $ appendToStream (StreamName "transition-stop") NoStream [makeEvent "TransitionStopAfterLive" (Aeson.object [])]+                result <- waitWithTimeout 10_000_000 handle+                case result of+                    Left timeout -> expectationFailure timeout+                    Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                    Right (Right ()) -> pure ()++                collected <- reverse <$> readIORef ref+                map (^. #globalPosition) collected `shouldBe` map GlobalPosition [1 .. 11]++            it "does not skip an event when cancelled before checkpoint save" $ \store -> do+                let events = map (\i -> makeEvent ("CancelReplay" <> T.pack (show i)) (Aeson.object [])) [1 .. 3 :: Int]+                Right _ <- runStoreIO store $ appendToStream (StreamName "cancel-replay") NoStream events+                waitForPublisher store (GlobalPosition 3)++                firstSeen <- newEmptyMVar+                block <- newEmptyMVar+                firstRef <- newIORef ([] :: [RecordedEvent])+                let handler1 evt = do+                        modifyIORef' firstRef (evt :)+                        putMVar firstSeen ()+                        takeMVar block+                        pure Continue+                    cfg1 =+                        SubscriptionConfig+                            { name = SubscriptionName "cancel-replay-test"+                            , target = AllStreams+                            , handler = handler1+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                h1 <- subscribe store cfg1+                takeMVar firstSeen+                cancel h1+                _ <- waitWithTimeout 5_000_000 h1++                ref2 <- newIORef ([] :: [RecordedEvent])+                let handler2 evt = do+                        modifyIORef' ref2 (evt :)+                        pure Stop+                    cfg2 =+                        SubscriptionConfig+                            { name = SubscriptionName "cancel-replay-test"+                            , target = AllStreams+                            , handler = handler2+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                h2 <- subscribe store cfg2+                result <- waitWithTimeout 10_000_000 h2+                case result of+                    Left timeout -> expectationFailure timeout+                    Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                    Right (Right ()) -> pure ()+                replayed <- reverse <$> readIORef ref2+                map (^. #globalPosition) replayed `shouldBe` [GlobalPosition 1]++            it "saves checkpoints at Stop boundaries without skipping the next event" $ \store -> do+                let events = map (\i -> makeEvent ("StopBoundary" <> T.pack (show i)) (Aeson.object [])) [1 .. 5 :: Int]+                Right _ <- runStoreIO store $ appendToStream (StreamName "stop-boundary") NoStream events+                waitForPublisher store (GlobalPosition 5)++                countRef1 <- newTVarIO (0 :: Int)+                let handler1 _evt = do+                        n <- atomically $ do+                            c <- readTVar countRef1+                            let c' = c + 1+                            writeTVar countRef1 c'+                            pure c'+                        if n >= 3 then pure Stop else pure Continue+                    cfg1 =+                        SubscriptionConfig+                            { name = SubscriptionName "stop-boundary-test"+                            , target = AllStreams+                            , handler = handler1+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                h1 <- subscribe store cfg1+                _ <- waitWithTimeout 10_000_000 h1++                ref2 <- newIORef ([] :: [RecordedEvent])+                countRef2 <- newTVarIO (0 :: Int)+                let handler2 evt = do+                        modifyIORef' ref2 (evt :)+                        n <- atomically $ do+                            c <- readTVar countRef2+                            let c' = c + 1+                            writeTVar countRef2 c'+                            pure c'+                        if n >= 2 then pure Stop else pure Continue+                    cfg2 =+                        SubscriptionConfig+                            { name = SubscriptionName "stop-boundary-test"+                            , target = AllStreams+                            , handler = handler2+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                h2 <- subscribe store cfg2+                result <- waitWithTimeout 10_000_000 h2+                case result of+                    Left timeout -> expectationFailure timeout+                    Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                    Right (Right ()) -> pure ()+                replayed <- reverse <$> readIORef ref2+                map (^. #globalPosition) replayed `shouldBe` [GlobalPosition 4, GlobalPosition 5]++            -- F18 regression — Category subscriptions in live mode previously+            -- received unfiltered events from $all because `filterEvents` was+            -- a no-op for Category. The fix routes Category live-mode through+            -- a DB-driven loop that re-uses the SQL category filter. Before+            -- the fix, the handler would observe the UserNoise event below.+            it "delivers only category-matching events during live mode (F18)" $ \store -> do+                seedSeen <- newEmptyMVar+                ref <- newIORef ([] :: [RecordedEvent])+                countRef <- newTVarIO (0 :: Int)+                let handler' evt = do+                        modifyIORef' ref (evt :)+                        n <- atomically $ do+                            c <- readTVar countRef+                            let c' = c + 1+                            writeTVar countRef c'+                            pure c'+                        -- After the catch-up seed event, signal that we are+                        -- entering live mode. Subsequent appends exercise+                        -- the live path under the new DB-driven loop.+                        if n == 1+                            then putMVar seedSeen ()+                            else pure ()+                        if n >= 3 then pure Stop else pure Continue+                -- Pre-seed an order event so catch-up fires the handler once.+                Right _ <-+                    runStoreIO store $+                        appendToStream+                            (StreamName "order-seed")+                            NoStream+                            [makeEvent "OrderSeed" (Aeson.object [])]+                let cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "f18-live-test"+                            , target = Category (CategoryName "order")+                            , handler = handler'+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                handle <- subscribe store cfg+                -- Block until catch-up has delivered the seed event — the+                -- worker has finished catch-up and is about to enter live+                -- mode.+                takeMVar seedSeen+                -- Append a non-matching user event followed by two matching+                -- order events. Under the bug, UserNoise would slip through+                -- the live broadcast unfiltered.+                Right _ <- runStoreIO store $ appendToStream (StreamName "user-1") NoStream [makeEvent "UserNoise" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "order-2") NoStream [makeEvent "OrderTwo" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "order-3") NoStream [makeEvent "OrderThree" (Aeson.object [])]+                result <- waitWithTimeout 10_000_000 handle+                case result of+                    Left timeout -> expectationFailure timeout+                    Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                    Right (Right ()) -> pure ()+                collected <- readIORef ref+                length collected `shouldBe` 3+                -- No UserNoise event should have been delivered.+                mapM_+                    (\e -> (e ^. #eventType) `shouldNotBe` EventType "UserNoise")+                    collected++            it "delivers only category-matching events during catch-up" $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "order-1") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "order-2") NoStream [makeEvent "OrderShipped" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "user-1") NoStream [makeEvent "UserRegistered" (Aeson.object [])]+                waitForPublisher store (GlobalPosition 3)+                ref <- newIORef ([] :: [RecordedEvent])+                countRef <- newTVarIO (0 :: Int)+                let handler' evt = do+                        modifyIORef' ref (evt :)+                        n <- atomically $ do+                            c <- readTVar countRef+                            let c' = c + 1+                            writeTVar countRef c'+                            pure c'+                        if n >= 2+                            then pure Stop+                            else pure Continue+                let cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "cat-sub-test"+                            , target = Category (CategoryName "order")+                            , handler = handler'+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                handle <- subscribe store cfg+                _ <- waitWithTimeout 10_000_000 handle+                collected <- readIORef ref+                length collected `shouldBe` 2+                -- All events should be order events+                mapM_ (\e -> (e ^. #eventType) `shouldSatisfy` (\(EventType t) -> T.isPrefixOf "Order" t)) collected++            it "preserves category subscription order under mixed invoice-payment writes" $ \store -> do+                let appendOne sn typ =+                        runStoreIO store (appendToStream sn AnyVersion [makeEvent typ (Aeson.object [])]) >>= \result ->+                            case result of+                                Right _ -> pure ()+                                Left err -> expectationFailure ("append failed: " <> show err)+                appendOne (StreamName "invoice-payment") "InvoicePaymentStarted"+                appendOne (StreamName "user-1") "UserNoiseOne"+                appendOne (StreamName "invoice-reminder") "InvoiceReminderSent"+                appendOne (StreamName "order-1") "OrderNoiseOne"+                appendOne (StreamName "invoice-payment") "InvoicePaymentFinished"+                appendOne (StreamName "user-2") "UserNoiseTwo"+                appendOne (StreamName "invoice-refund") "InvoiceRefundFinished"+                waitForPublisher store (GlobalPosition 7)++                ref <- newIORef ([] :: [RecordedEvent])+                countRef <- newTVarIO (0 :: Int)+                let handler' evt = do+                        modifyIORef' ref (evt :)+                        n <- atomically $ do+                            c <- readTVar countRef+                            let c' = c + 1+                            writeTVar countRef c'+                            pure c'+                        if n >= 4 then pure Stop else pure Continue+                    cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "invoice-category-ordering"+                            , target = Category (CategoryName "invoice")+                            , handler = handler'+                            , batchSize = 2+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                handle <- subscribe store cfg+                result <- waitWithTimeout 10_000_000 handle+                case result of+                    Left timeout -> expectationFailure timeout+                    Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                    Right (Right ()) -> pure ()+                collected <- reverse <$> readIORef ref+                map (^. #globalPosition) collected `shouldBe` [GlobalPosition 1, GlobalPosition 3, GlobalPosition 5, GlobalPosition 7]+                map (^. #eventType) collected+                    `shouldBe` [ EventType "InvoicePaymentStarted"+                               , EventType "InvoiceReminderSent"+                               , EventType "InvoicePaymentFinished"+                               , EventType "InvoiceRefundFinished"+                               ]++            it "cancels a running subscription cleanly" $ \store -> do+                let handler' _evt = pure Continue+                let cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "cancel-test"+                            , target = AllStreams+                            , handler = handler'+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                handle <- subscribe store cfg+                -- Give it time to start+                threadDelay 100_000+                cancel handle+                result <- waitWithTimeout 5_000_000 handle+                -- Should exit cleanly (AsyncCancelled or Right ())+                case result of+                    Left _timeout -> expectationFailure "Cancel did not terminate in time"+                    Right (Left _) -> pure () -- AsyncCancelled is expected+                    Right (Right ()) -> pure ()++            it "receives events appended to an initially empty store" $ \store -> do+                ref <- newIORef ([] :: [RecordedEvent])+                let handler' evt = do+                        modifyIORef' ref (evt :)+                        pure Stop+                let cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "empty-store-test"+                            , target = AllStreams+                            , handler = handler'+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                handle <- subscribe store cfg+                -- Give subscription time to start in live mode+                threadDelay 100_000+                -- Append one event+                Right _ <- runStoreIO store $ appendToStream (StreamName "empty-1") NoStream [makeEvent "First" (Aeson.object [])]+                result <- waitWithTimeout 10_000_000 handle+                case result of+                    Left timeout -> expectationFailure timeout+                    Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                    Right (Right ()) -> pure ()+                collected <- readIORef ref+                length collected `shouldBe` 1++            it "handles rapid appends without losing events (debouncing)" $ \store -> do+                ref <- newIORef ([] :: [RecordedEvent])+                countRef <- newTVarIO (0 :: Int)+                let handler' evt = do+                        modifyIORef' ref (evt :)+                        n <- atomically $ do+                            c <- readTVar countRef+                            let c' = c + 1+                            writeTVar countRef c'+                            pure c'+                        if n >= 50+                            then pure Stop+                            else pure Continue+                let cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "debounce-test"+                            , target = AllStreams+                            , handler = handler'+                            , batchSize = 100+                            , -- Sized to absorb 50 publisher batches without+                              -- backpressure overflow. The default 16 was+                              -- intermittently overrun under load (the+                              -- publisher emits one batch per append because+                              -- there is no inter-append debounce window in+                              -- this loop), surfacing as+                              -- SubscriptionOverflowed in flaky CI runs.+                              -- Coverage of the bounded-queue policy lives+                              -- in the F6 overflow test below, not here.+                              queueCapacity = 64+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                handle <- subscribe store cfg+                threadDelay 100_000+                -- Append 50 events rapidly to different streams+                mapM_+                    ( \i -> do+                        let sn = StreamName ("rapid-" <> T.pack (show (i :: Int)))+                        Right _ <- runStoreIO store $ appendToStream sn NoStream [makeEvent ("R" <> T.pack (show i)) (Aeson.object [])]+                        pure ()+                    )+                    [1 .. 50]+                result <- waitWithTimeout 30_000_000 handle+                case result of+                    Left timeout -> expectationFailure timeout+                    Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                    Right (Right ()) -> pure ()+                collected <- readIORef ref+                length collected `shouldBe` 50++            -- F6 regression — the publisher's broadcast was an unbounded TChan;+            -- a slow subscriber's dupTChan grew without limit until the host+            -- ran out of memory. The fix replaces the broadcast with a+            -- per-subscriber bounded TBQueue plus an overflow policy. With+            -- DropSubscription, the publisher signals overflow on the+            -- subscriber's status TVar; the worker observes it on its next+            -- STM read and surfaces SubscriptionOverflowed via wait/waitCatch.+            it "surfaces SubscriptionOverflowed when a slow subscriber overruns its queue (F6)" $ \store -> do+                firstSeen <- newEmptyMVar+                release <- newEmptyMVar+                seenCount <- newTVarIO (0 :: Int)+                let handler' _evt = do+                        n <- atomically $ do+                            c <- readTVar seenCount+                            let c' = c + 1+                            writeTVar seenCount c'+                            pure c'+                        if n == 1+                            then do+                                putMVar firstSeen ()+                                takeMVar release+                            else pure ()+                        pure Continue+                let cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "f6-overflow-test"+                            , target = AllStreams+                            , handler = handler'+                            , batchSize = 100+                            , queueCapacity = 1+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                handle <- subscribe store cfg+                -- First append: triggers handler, which blocks on the release MVar.+                Right _ <- runStoreIO store $ appendToStream (StreamName "f6-1") NoStream [makeEvent "E1" (Aeson.object [])]+                takeMVar firstSeen+                -- While the worker is stuck inside the handler, append events one+                -- at a time and wait for the publisher to fetch each individually.+                -- Each append corresponds to a separate publisher batch written+                -- to the subscriber's queue. Capacity is 1, so the second+                -- write fills it and the third triggers DropSubscription.+                let waitForPub n = atomically $ do+                        GlobalPosition p <- publisherPosition (store ^. #publisher)+                        check (p >= n)+                let appendOne i = do+                        let sn = StreamName ("f6-" <> T.pack (show (i :: Int)))+                        Right _ <- runStoreIO store $ appendToStream sn NoStream [makeEvent "Ex" (Aeson.object [])]+                        waitForPub (fromIntegral i)+                -- Append 4 more events with publisher synchronisation. Combined+                -- with the first event, that is 5 publisher batches.+                appendOne 2+                appendOne 3+                appendOne 4+                appendOne 5+                -- Release the handler. Worker exits processEvents and on the+                -- next STM read observes Overflowed.+                putMVar release ()+                result <- waitWithTimeout 10_000_000 handle+                case result of+                    Left timeout -> expectationFailure timeout+                    Right (Right ()) -> expectationFailure "expected SubscriptionOverflowed, got clean exit"+                    Right (Left e) ->+                        case Control.Exception.fromException e of+                            Just (SubscriptionOverflowed sn) ->+                                sn `shouldBe` SubscriptionName "f6-overflow-test"+                            Nothing ->+                                expectationFailure ("expected SubscriptionOverflowed, got: " <> show e)++                ref2 <- newIORef ([] :: [RecordedEvent])+                countRef2 <- newTVarIO (0 :: Int)+                let handler2 evt = do+                        modifyIORef' ref2 (evt :)+                        n <- atomically $ do+                            c <- readTVar countRef2+                            let c' = c + 1+                            writeTVar countRef2 c'+                            pure c'+                        if n >= 4 then pure Stop else pure Continue+                    cfg2 =+                        SubscriptionConfig+                            { name = SubscriptionName "f6-overflow-test"+                            , target = AllStreams+                            , handler = handler2+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                h2 <- subscribe store cfg2+                replayResult <- waitWithTimeout 10_000_000 h2+                case replayResult of+                    Left timeout -> expectationFailure timeout+                    Right (Left err) -> expectationFailure ("Subscription failed after overflow restart: " <> show err)+                    Right (Right ()) -> pure ()+                replayed <- reverse <$> readIORef ref2+                map (^. #globalPosition) replayed `shouldBe` map GlobalPosition [2 .. 5]++            it "catches up with an Eff-based handler via the effectful API" $ \store -> do+                -- Append 10 events+                let events = map (\i -> makeEvent ("Eff" <> T.pack (show i)) (Aeson.object [])) [1 .. 10 :: Int]+                Right _ <- runStoreIO store $ appendToStream (StreamName "eff-sub-1") NoStream events+                waitForPublisher store (GlobalPosition 10)+                -- Subscribe using the effectful API with an Eff-based handler+                ref <- newIORef ([] :: [RecordedEvent])+                countRef <- newTVarIO (0 :: Int)+                result <- runEff . runErrorNoCallStack @StoreError . runStorePool store . runSubscription store $ do+                    let effHandler :: (IOE :> es) => RecordedEvent -> Eff es SubscriptionResult+                        effHandler evt = do+                            liftIO $ modifyIORef' ref (evt :)+                            n <- liftIO $ atomically $ do+                                c <- readTVar countRef+                                let c' = c + 1+                                writeTVar countRef c'+                                pure c'+                            if n >= 10+                                then pure Stop+                                else pure Continue+                    let cfg =+                            SubscriptionConfig+                                { name = SubscriptionName "eff-catchup-test"+                                , target = AllStreams+                                , handler = effHandler+                                , batchSize = 100+                                , queueCapacity = 16+                                , overflowPolicy = DropSubscription+                                , consumerGroup = Nothing+                                , consumerGroupGuard = False+                                , retryPolicy = defaultRetryPolicy+                                , eventTypeFilter = AllEventTypes+                                , selector = Nothing+                                }+                    handle <- SubEff.subscribe cfg+                    liftIO $ do+                        r <- waitWithTimeout 10_000_000 handle+                        case r of+                            Left timeout -> expectationFailure timeout+                            Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                            Right (Right ()) -> pure ()+                case result of+                    Left err -> expectationFailure ("Store error: " <> show err)+                    Right () -> pure ()+                collected <- readIORef ref+                length collected `shouldBe` 10++        -- =================================================================+        -- withSubscription bracket tests (EP-2 F25)+        -- =================================================================+        describe "withSubscription" $ do+            -- F25 regression — bracket cancels the worker on normal scope exit.+            it "cancels the worker on normal scope exit" $ \store -> do+                handleRef <- newIORef Nothing+                let cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "withsub-normal"+                            , target = AllStreams+                            , handler = \_ -> pure Continue+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                withSubscription store cfg $ \h -> do+                    writeIORef handleRef (Just h)+                    threadDelay 100_000+                Just h <- readIORef handleRef+                -- Worker must terminate now that the scope has exited.+                outcome <- Async.race (threadDelay 2_000_000) (wait h)+                case outcome of+                    Left () -> expectationFailure "worker did not exit after withSubscription scope"+                    Right _ -> pure ()++            -- F25 regression — bracket cancels the worker even when the body throws.+            it "cancels the worker when the body throws" $ \store -> do+                handleRef <- newIORef Nothing+                let cfg =+                        SubscriptionConfig+                            { name = SubscriptionName "withsub-throw"+                            , target = AllStreams+                            , handler = \_ -> pure Continue+                            , batchSize = 100+                            , queueCapacity = 16+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                result <-+                    Control.Exception.try @SomeException $+                        withSubscription store cfg $ \h -> do+                            writeIORef handleRef (Just h)+                            threadDelay 100_000+                            error "withSubscription body deliberately throws"+                case result of+                    Left _ -> pure ()+                    Right () -> expectationFailure "expected exception to propagate"+                Just h <- readIORef handleRef+                outcome <- Async.race (threadDelay 2_000_000) (wait h)+                case outcome of+                    Left () -> expectationFailure "worker did not exit after exception in withSubscription body"+                    Right _ -> pure ()++    -- =================================================================+    -- Pure helpers (no database fixture)+    -- =================================================================++    -- F1 regression — pure detail parser used by attributeMultiStreamError.+    -- The integration scenario that would exercise this code path+    -- (ix_streams_stream_name 23505 raised inside an appendMultiStream txn)+    -- is unreachable via current SQL because every append CTE uses ON CONFLICT+    -- DO NOTHING / DO UPDATE. The pure helper is unit-tested here so a future+    -- schema change that introduces such a path arrives with the attribution+    -- already correct.+    describe "extractStreamNameFromDetail" $ do+        it "extracts the stream name from a typical PostgreSQL detail" $ do+            extractStreamNameFromDetail "Key (stream_name)=(orders-1) already exists."+                `shouldBe` Just "orders-1"+        it "extracts a stream name containing dashes and digits" $ do+            extractStreamNameFromDetail "Key (stream_name)=(multi-c-2) already exists."+                `shouldBe` Just "multi-c-2"+        it "returns Nothing when the detail is empty" $ do+            extractStreamNameFromDetail "" `shouldBe` Nothing+        it "returns Nothing when the detail does not contain '=('" $ do+            extractStreamNameFromDetail "no key here" `shouldBe` Nothing+        it "returns Nothing for an empty parenthesised value" $ do+            extractStreamNameFromDetail "Key (stream_name)=() already exists."+                `shouldBe` Nothing++    -- =================================================================+    -- Notifier reconnection tests (EP-3 F1)+    -- =================================================================+    describe "Notifier reconnection" $ do+        -- F1 regression — the listener loop reconnects on backend termination,+        -- and `stopNotifier` must release the *current* (post-reconnect)+        -- connection. Without the fix, the original Notifier.listenerConn was+        -- a frozen reference to the first conn and the reconnected conn leaked+        -- past `withStore` exit. We assert no kiroku-listener backend remains+        -- in pg_stat_activity after the store shuts down.+        it "releases the reconnected listener connection on shutdown" $ \() -> do+            n <- withMigratedTestDatabase $ \connStr -> do+                let settings = defaultConnectionSettings connStr+                withStore settings $ \store -> do+                    pid1 <- waitForListenerPid (store ^. #pool) 5_000_000+                    terminateBackend (store ^. #pool) pid1+                    pid2 <- waitForListenerPidNotEqual (store ^. #pool) pid1 15_000_000+                    pid2 `shouldNotBe` pid1+                -- After withStore exits, no kiroku-listener connection remains.+                listenerCount connStr+            n `shouldBe` (0 :: Int64)++    -- =================================================================+    -- Health monitoring tests (M6.8)+    -- =================================================================+    describe "observationHandler" $ do+        it "receives observations during store operations" $ \() -> do+            ref <- newIORef ([] :: [Observation])+            let handler obs = modifyIORef' ref (obs :)+            withTestStoreSettings+                (\settings -> settings{observationHandler = Just handler})+                $ \store -> do+                    Right _ <- runStoreIO store $ appendToStream (StreamName "obs-test") NoStream [makeEvent "X" (Aeson.object [])]+                    pure ()+            observations <- readIORef ref+            length observations `shouldSatisfy` (> 0)++    -- =================================================================+    -- KirokuEvent observation surface (EP-5 F1, F13, F14)+    -- =================================================================+    describe "KirokuEvent observation" $ do+        -- EP-5 F1 regression — terminating the listener backend triggers+        -- KirokuEventNotifierReconnecting then KirokuEventNotifierReconnected.+        -- Before EP-5 the reconnect path emitted no signal at all.+        it "emits notifier reconnect events on backend termination (F1)" $ \() -> do+            ref <- newIORef ([] :: [KirokuEvent])+            let evtHandler e = modifyIORef' ref (e :)+            withMigratedTestDatabase $ \connStr -> do+                let settings =+                        defaultConnectionSettings connStr+                            & #eventHandler .~ Just evtHandler+                withStore settings $ \store -> do+                    pid1 <- waitForListenerPid (store ^. #pool) 5_000_000+                    terminateBackend (store ^. #pool) pid1+                    _ <- waitForListenerPidNotEqual (store ^. #pool) pid1 15_000_000+                    pure ()+            evts <- readIORef ref+            let isReconnecting (KirokuEventNotifierReconnecting _ _) = True+                isReconnecting _ = False+                isReconnected KirokuEventNotifierReconnected = True+                isReconnected _ = False+            any isReconnecting evts `shouldBe` True+            any isReconnected evts `shouldBe` True++        -- EP-5 F14 regression — subscriptions emit started, caught-up, and+        -- stopped events. Before EP-5 the lifecycle was invisible.+        --+        -- Subscribe before appending so the worker enters catch-up at+        -- position 0, immediately reaches the publisher's position 0,+        -- emits CaughtUp, transitions to live mode, then receives the+        -- two appended events and stops.+        it "emits subscription lifecycle events (F14)" $ \() -> do+            ref <- newIORef ([] :: [KirokuEvent])+            let evtHandler e = modifyIORef' ref (e :)+            withTestStoreSettings+                (& #eventHandler .~ Just evtHandler)+                $ \store -> do+                    countRef <- newTVarIO (0 :: Int)+                    let h _ = do+                            n <- atomically $ do+                                c <- readTVar countRef+                                writeTVar countRef (c + 1)+                                pure (c + 1)+                            if n >= 2 then pure Stop else pure Continue+                    let cfg =+                            SubscriptionConfig+                                { name = SubscriptionName "lifecycle-test"+                                , target = AllStreams+                                , handler = h+                                , batchSize = 100+                                , queueCapacity = 16+                                , overflowPolicy = DropSubscription+                                , consumerGroup = Nothing+                                , consumerGroupGuard = False+                                , retryPolicy = defaultRetryPolicy+                                , eventTypeFilter = AllEventTypes+                                , selector = Nothing+                                }+                    handle <- subscribe store cfg+                    -- Give the worker a moment to enter live mode.+                    threadDelay 200_000+                    Right _ <-+                        runStoreIO store $+                            appendToStream (StreamName "lifecycle-1") NoStream [makeEvent "X" (Aeson.object [])]+                    Right _ <-+                        runStoreIO store $+                            appendToStream (StreamName "lifecycle-1") (ExactVersion (StreamVersion 1)) [makeEvent "Y" (Aeson.object [])]+                    _ <- waitWithTimeout 10_000_000 handle+                    pure ()+            evts <- readIORef ref+            let isStarted (KirokuEventSubscriptionStarted (SubscriptionName "lifecycle-test") _ _) = True+                isStarted _ = False+                isCaughtUp (KirokuEventSubscriptionCaughtUp (SubscriptionName "lifecycle-test") _ _) = True+                isCaughtUp _ = False+                isStopped (KirokuEventSubscriptionStopped (SubscriptionName "lifecycle-test") _ StopHandlerRequested _) = True+                isStopped _ = False+            any isStarted evts `shouldBe` True+            any isCaughtUp evts `shouldBe` True+            any isStopped evts `shouldBe` True++        -- EP-5 F13 regression — hard-delete emits a fail-safe audit event.+        -- Before EP-5 there was no in-band audit signal.+        it "emits a hard-delete event when the stream existed (F13)" $ \() -> do+            ref <- newIORef ([] :: [KirokuEvent])+            let evtHandler e = modifyIORef' ref (e :)+            withTestStoreSettings+                (& #eventHandler .~ Just evtHandler)+                $ \store -> do+                    Right _ <-+                        runStoreIO store $+                            appendToStream (StreamName "hard-delete-evt") NoStream [makeEvent "X" (Aeson.object [])]+                    Right _ <- runStoreIO store $ hardDeleteStream (StreamName "hard-delete-evt")+                    -- A hard-delete on a non-existent stream must not emit+                    -- the event — verify by issuing a second one.+                    Right _ <- runStoreIO store $ hardDeleteStream (StreamName "never-existed")+                    pure ()+            evts <- readIORef ref+            let hardDeletes =+                    [ name'+                    | KirokuEventHardDeleteIssued (StreamName name') _ <- evts+                    ]+            hardDeletes `shouldBe` ["hard-delete-evt"]
+ test/Test/CatchupDbErrorNoPrematureSwitch.hs view
@@ -0,0 +1,98 @@+module Test.CatchupDbErrorNoPrematureSwitch (spec) where++import Control.Concurrent.MVar (newEmptyMVar, tryPutMVar)+import Control.Concurrent.STM (atomically, check, newTVarIO, readTVar, writeTVar)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.List qualified as List+import Data.Vector qualified as V+import Hasql.Pool qualified as Pool+import Kiroku.Store+import Kiroku.Store.Subscription.Types qualified as SubTypes+import Kiroku.Store.Subscription.Worker (withFetchBatchHookForTest)+import Test.Helpers (+    caughtUpEventHandler,+    makeEvent,+    waitForPublisher,+    waitForSubscriptionLive,+    withTestStoreSettings,+ )+import Test.Hspec++spec :: Spec+spec =+    describe "catch-up DB error handling" $+        it "retries a transient fetch error instead of switching to live mode at a stale cursor" $ \() -> do+            deliveredRef <- newIORef ([] :: [GlobalPosition])+            failedOnce <- newIORef False+            eventRef <- newIORef ([] :: [KirokuEvent])+            seenCount <- newTVarIO (0 :: Int)+            caughtUp <- newEmptyMVar++            let subName = SubscriptionName "catchup-db-error-no-gap"+                targetTail = GlobalPosition 3+                handler' evt = do+                    modifyIORef' deliveredRef ((evt ^. #globalPosition) :)+                    atomically $ do+                        n <- readTVar seenCount+                        writeTVar seenCount (n + 1)+                    pure Continue+                cfg =+                    SubscriptionConfig+                        { name = subName+                        , target = AllStreams+                        , handler = handler'+                        , batchSize = 100+                        , queueCapacity = 16+                        , overflowPolicy = DropSubscription+                        , consumerGroup = Nothing+                        , consumerGroupGuard = False+                        , retryPolicy = defaultRetryPolicy+                        , eventTypeFilter = AllEventTypes+                        , selector = Nothing+                        }+                observe evt = do+                    modifyIORef' eventRef (evt :)+                    caughtUpEventHandler subName caughtUp Nothing evt+                injectOnce config cursor+                    | SubTypes.name config == subName && cursor == GlobalPosition 0 = do+                        alreadyFailed <- readIORef failedOnce+                        if alreadyFailed+                            then pure Nothing+                            else do+                                writeIORef failedOnce True+                                pure (Just (Left Pool.AcquisitionTimeoutUsageError))+                    | otherwise = pure Nothing++            withTestStoreSettings (& #eventHandler .~ Just observe) $ \store -> do+                Right _ <- runStoreIO store $ appendToStream (StreamName "catchup-db-error-1") NoStream [makeEvent "One" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "catchup-db-error-2") NoStream [makeEvent "Two" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "catchup-db-error-3") NoStream [makeEvent "Three" (Aeson.object [])]+                waitForPublisher store targetTail++                withFetchBatchHookForTest injectOnce $ do+                    handle <- subscribe store cfg+                    waitForSubscriptionLive caughtUp+                    atomically $ do+                        n <- readTVar seenCount+                        check (n >= 3)+                    cancel handle++            delivered <- readIORef deliveredRef+            List.sort delivered `shouldBe` [GlobalPosition 1, GlobalPosition 2, GlobalPosition 3]++            observed <- readIORef eventRef+            let isFetchDbError = \case+                    KirokuEventSubscriptionDbError n FetchBatch Pool.AcquisitionTimeoutUsageError _+                        | n == subName -> True+                    _ -> False+                caughtUpPositions =+                    [ pos+                    | KirokuEventSubscriptionCaughtUp n pos _ <- observed+                    , n == subName+                    ]++            any isFetchDbError observed `shouldBe` True+            V.fromList caughtUpPositions `shouldBe` V.singleton targetTail
+ test/Test/CategoryIdleNoSpin.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Regression tests for ExecPlan 37 — the live DB-driven subscription loops must+not busy-spin when idle while the store's global @$all@ position advances for+/other/ categories or partitions.++Two paths are covered:++  * Non-group @Category@ subscription+    ('Kiroku.Store.Subscription.Worker.liveLoopCategoryNotify'): an idle category+    blocks on its own per-category NOTIFY generation and does __zero__ database+    fetches while a different category receives sustained traffic. A real append+    to the subscribed category still wakes it (liveness).+  * Consumer-group member+    ('Kiroku.Store.Subscription.Worker.liveLoopDbDriven', corrected gate): an idle+    member gates on the /last observed global position/ rather than its+    per-partition cursor, so it wakes at most once per global advance — a bounded+    number of fetches — instead of the unbounded spin the original cursor-gate+    produced.++The deterministic signal is the additive+'Kiroku.Store.Observability.KirokuEventSubscriptionFetched' event, emitted once+per live DB-driven fetch. The store's @eventHandler@ counts those whose+'SubscriptionName' matches the subscriber under test; the subscription's own+handler counts deliveries. (@pg_stat_statements@ is not available in this suite —+see the plan's Decision Log.)++To confirm these specs actually pin the regression: temporarily restore the old+cursor-gated 'liveLoopDbDriven' body and route @(Nothing, Category{})@ back through+it — both idle fetch counts then explode and the assertions fail.+-}+module Test.CategoryIdleNoSpin (spec) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar (newEmptyMVar)+import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVarIO)+import Control.Exception (bracket)+import Control.Lens ((&), (.~))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.Text qualified as T+import Kiroku.Store+import Kiroku.Store.Subscription.Types (ConsumerGroup (..), SubscriptionConfigM (..))+import Test.Helpers (caughtUpEventHandler, makeEvent, waitForPublisher, waitForSubscriptionLive, withTestStoreSettings)+import Test.Hspec++-- | Poll an @IO Bool@ predicate until it holds or the microsecond budget runs out.+waitUntil :: Int -> IO Bool -> IO ()+waitUntil budget act+    | budget <= 0 = pure ()+    | otherwise = do+        ok <- act+        if ok+            then pure ()+            else do+                threadDelay 20_000+                waitUntil (budget - 20_000) act++-- | Append one event to each named stream, failing the test on a store error.+appendEach :: KirokuStore -> [T.Text] -> T.Text -> IO ()+appendEach store names typ =+    mapM_+        ( \sn -> do+            r <- runStoreIO store $ appendToStream (StreamName sn) NoStream [makeEvent typ (Aeson.object [])]+            either (error . ("append failed: " <>) . show) (const (pure ())) r+        )+        names++spec :: Spec+spec = describe "live loops do not busy-spin while idle (plan 37)" $ do+    it "an idle Category subscriber does zero fetches while another category is active, then wakes on its own event" $ do+        let subName = SubscriptionName "alpha-sub"+        deliveredVar <- newTVarIO (0 :: Int)+        fetchVar <- newTVarIO (0 :: Int)+        liveBarrier <- newEmptyMVar+        let countFetch evt = case evt of+                KirokuEventSubscriptionFetched n _ _+                    | n == subName -> atomically (modifyTVar' fetchVar (+ 1))+                _ -> pure ()+            obsHandler = caughtUpEventHandler subName liveBarrier (Just countFetch)+        withTestStoreSettings (\s -> s & #eventHandler .~ Just obsHandler) $ \store -> do+            let deliver _evt = do+                    atomically (modifyTVar' deliveredVar (+ 1))+                    pure Continue+                cfg = defaultSubscriptionConfig subName (Category (CategoryName "alpha")) deliver+            bracket (subscribe store cfg) cancel $ \_handle -> do+                -- Wait until the worker reaches live mode and completes its initial+                -- post-catch-up drain (one empty fetch), so the baseline is settled.+                waitForSubscriptionLive liveBarrier+                waitUntil 5_000_000 ((>= 1) <$> readTVarIO fetchVar)+                base <- readTVarIO fetchVar++                -- Drive a DIFFERENT category hard: the global tail races far ahead of+                -- alpha's cursor. Under the old gate alpha woke per global tick and+                -- spun one empty fetch each time; under the fix it never wakes (its+                -- category generation is untouched).+                let betaCount = 20 :: Int+                    betaStreams = ["beta-" <> T.pack (show i) | i <- [1 .. betaCount]]+                appendEach store betaStreams "Beta"+                waitForPublisher store (GlobalPosition (fromIntegral betaCount))+                -- Give a (hypothetical) spinning worker ample time to accumulate fetches.+                threadDelay 500_000++                afterIdle <- readTVarIO fetchVar+                deliveredIdle <- readTVarIO deliveredVar+                (afterIdle - base) `shouldBe` 0+                deliveredIdle `shouldBe` 0++                -- Liveness: a real append to alpha must wake the worker and deliver.+                appendEach store ["alpha-1"] "Alpha"+                waitUntil 5_000_000 ((>= 1) <$> readTVarIO deliveredVar)+                deliveredFinal <- readTVarIO deliveredVar+                deliveredFinal `shouldBe` 1++    it "an idle consumer-group member does not spin while a different category advances the global position" $ do+        let subName = SubscriptionName "grp-sub"+        deliveredVar <- newTVarIO (0 :: Int)+        fetchVar <- newTVarIO (0 :: Int)+        liveBarrier <- newEmptyMVar+        let countFetch evt = case evt of+                KirokuEventSubscriptionFetched n _ _+                    | n == subName -> atomically (modifyTVar' fetchVar (+ 1))+                _ -> pure ()+            obsHandler = caughtUpEventHandler subName liveBarrier (Just countFetch)+        withTestStoreSettings (\s -> s & #eventHandler .~ Just obsHandler) $ \store -> do+            let deliver _evt = do+                    atomically (modifyTVar' deliveredVar (+ 1))+                    pure Continue+                -- Member 0 of 3 over category "grp" — which receives NO events, so+                -- this member's partition fetch is always empty. The flood lands in+                -- a different category, advancing only the global position.+                cfg =+                    (defaultSubscriptionConfig subName (Category (CategoryName "grp")) deliver)+                        { consumerGroup = Just ConsumerGroup{member = 0, size = 3}+                        }+            bracket (subscribe store cfg) cancel $ \_handle -> do+                waitForSubscriptionLive liveBarrier++                -- The corrected group loop gates BEFORE draining, so on an empty+                -- store it blocks with zero fetches until the global position moves.+                let floodCount = 20 :: Int+                    floodStreams = ["flood-" <> T.pack (show i) | i <- [1 .. floodCount]]+                appendEach store floodStreams "Flood"+                waitForPublisher store (GlobalPosition (fromIntegral floodCount))+                threadDelay 500_000++                afterIdle <- readTVarIO fetchVar+                deliveredIdle <- readTVarIO deliveredVar+                -- The corrected gate wakes at most once per observed global position+                -- (<= floodCount), bounded — NOT the unbounded busy-spin of the old+                -- cursor gate, which racks up thousands of empty fetches in 500ms.+                afterIdle `shouldSatisfy` (< 50)+                deliveredIdle `shouldBe` 0
+ test/Test/Causation.hs view
@@ -0,0 +1,168 @@+{- | Tests for "Kiroku.Store.Causation" — the causation- and+correlation-walking helpers.++Three groups of tests exercise the three exported functions:++  * 'findCausationDescendants' over a 5-deep chain @A -> B -> C -> D -> E@+    spread across three streams, plus single-element and empty cases.+  * 'findCausationAncestors' over the same chain, asserting leaf-first+    depth ordering.+  * 'findByCorrelation' fanning in across multiple streams, plus a noise+    correlation and an empty case.+-}+module Test.Causation (spec) where++import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as T+import Data.UUID (UUID)+import Data.UUID qualified as UUID+import Data.UUID.V4 qualified as UUIDv4+import Data.Vector (Vector)+import Data.Vector qualified as V+import Kiroku.Store+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec++spec :: Spec+spec = around withTestStore $ do+    describe "findCausationDescendants" $ do+        it "returns the seed event and every descendant in global-position order" $ \store -> do+            uuids@[uA, uB, uC, uD, uE] <- replicateUuids 5+            appendChain store uuids+            Right found <- runStoreIO store $ findCausationDescendants (EventId uA)+            eventIds found `shouldBe` map EventId uuids+            globalPositionsStrictlyIncreasing found `shouldBe` True++        it "on an eventId with no descendants returns a vector of length 1 (the seed only)" $ \store -> do+            uId <- UUIDv4.nextRandom+            let ev = mkEventWithIds "Solo" (Just uId) Nothing Nothing+            Right _ <- runStoreIO store $ appendToStream (StreamName "solo-stream") NoStream [ev]+            Right found <- runStoreIO store $ findCausationDescendants (EventId uId)+            V.length found `shouldBe` 1+            (V.head found ^. #eventId) `shouldBe` EventId uId++        it "on a non-existent eventId returns an empty vector" $ \store -> do+            -- Make sure the store has *some* events so we know we're not+            -- silently returning the whole table.+            let ev = makeEvent "Other" Aeson.Null+            Right _ <- runStoreIO store $ appendToStream (StreamName "other-stream") NoStream [ev]+            Right found <- runStoreIO store $ findCausationDescendants (EventId UUID.nil)+            V.null found `shouldBe` True++    describe "findCausationAncestors" $ do+        it "walks from a leaf back to the root, leaf first" $ \store -> do+            uuids@[uA, uB, uC, uD, uE] <- replicateUuids 5+            appendChain store uuids+            Right found <- runStoreIO store $ findCausationAncestors (EventId uE)+            eventIds found `shouldBe` map EventId [uE, uD, uC, uB, uA]++    describe "findByCorrelation" $ do+        it "returns every event with the given correlation across multiple streams in global-position order" $ \store -> do+            cMain <- UUIDv4.nextRandom+            cOther <- UUIDv4.nextRandom+            -- 7 events with correlation = cMain across 4 streams.+            let mkEv :: Int -> EventData+                mkEv i =+                    mkEventWithIds+                        (mkName "Main" i)+                        Nothing+                        Nothing+                        (Just cMain)+                mainPlan =+                    [ ("saga-a", NoStream, [mkEv 1, mkEv 2])+                    , ("saga-b", NoStream, [mkEv 3])+                    , ("saga-c", NoStream, [mkEv 4, mkEv 5, mkEv 6])+                    , ("saga-d", NoStream, [mkEv 7])+                    ]+            mapM_+                ( \(sn, ev, evts) -> do+                    Right _ <- runStoreIO store $ appendToStream (StreamName sn) ev evts+                    pure ()+                )+                mainPlan+            -- Noise: one event with no correlation.+            Right _ <- runStoreIO store $ appendToStream (StreamName "noise-stream") NoStream [makeEvent "Noise" Aeson.Null]+            -- A separate correlation set we should not see.+            let mkOther :: Int -> EventData+                mkOther i =+                    mkEventWithIds+                        (mkName "Other" i)+                        Nothing+                        Nothing+                        (Just cOther)+            Right _ <- runStoreIO store $ appendToStream (StreamName "other-saga") NoStream [mkOther i | i <- [1 .. 5 :: Int]]++            Right found <- runStoreIO store $ findByCorrelation cMain+            V.length found `shouldBe` 7+            all (\e -> e ^. #correlationId == Just cMain) found `shouldBe` True+            globalPositionsStrictlyIncreasing found `shouldBe` True++        it "on an unknown correlation returns an empty vector" $ \store -> do+            -- Insert *something* so we're not just observing an empty store.+            let noise = mkEventWithIds "Noise" Nothing Nothing (Just UUID.nil)+            Right _ <-+                runStoreIO store $+                    appendToStream (StreamName "noise-stream") NoStream [noise]+            unknown <- UUIDv4.nextRandom+            Right found <- runStoreIO store $ findByCorrelation unknown+            V.null found `shouldBe` True++-- ---------------------------------------------------------------------------+-- Local helpers+-- ---------------------------------------------------------------------------++replicateUuids :: Int -> IO [UUID]+replicateUuids n = mapM (const UUIDv4.nextRandom) [1 .. n]++{- | Build an 'EventData' from explicit event-id, causation-id, and+correlation-id arguments. Wraps the field updates in a typed binding so+'DuplicateRecordFields' does not complain about ambiguous record+updates ('eventId', 'causationId', and 'correlationId' all appear on+both 'EventData' and 'RecordedEvent').+-}+mkEventWithIds :: Text -> Maybe UUID -> Maybe UUID -> Maybe UUID -> EventData+mkEventWithIds typ mEid mCause mCorr =+    EventData+        { eventId = fmap EventId mEid+        , eventType = EventType typ+        , payload = Aeson.Null+        , metadata = Nothing+        , causationId = mCause+        , correlationId = mCorr+        }++{- | Append a 5-event causation chain @A -> B -> C -> D -> E@ across three+streams (@pm-trigger@, @pm-cmd@, @pm-result@). Each event's+@causationId@ points at the previous event's @eventId@.++Expects exactly five UUIDs; calls 'error' on any other length so the+caller's signature stays simple.+-}+appendChain :: KirokuStore -> [UUID] -> IO ()+appendChain store [uA, uB, uC, uD, uE] = do+    let evA = mkEventWithIds "A" (Just uA) Nothing Nothing+        evB = mkEventWithIds "B" (Just uB) (Just uA) Nothing+        evC = mkEventWithIds "C" (Just uC) (Just uB) Nothing+        evD = mkEventWithIds "D" (Just uD) (Just uC) Nothing+        evE = mkEventWithIds "E" (Just uE) (Just uD) Nothing+    Right _ <- runStoreIO store $ appendToStream (StreamName "pm-trigger") NoStream [evA]+    Right _ <- runStoreIO store $ appendToStream (StreamName "pm-cmd") NoStream [evB]+    Right _ <- runStoreIO store $ appendToStream (StreamName "pm-cmd") AnyVersion [evC]+    Right _ <- runStoreIO store $ appendToStream (StreamName "pm-result") NoStream [evD]+    Right _ <- runStoreIO store $ appendToStream (StreamName "pm-result") AnyVersion [evE]+    pure ()+appendChain _ _ = error "appendChain: expected exactly 5 UUIDs"++eventIds :: Vector RecordedEvent -> [EventId]+eventIds = V.toList . V.map (^. #eventId)++globalPositionsStrictlyIncreasing :: Vector RecordedEvent -> Bool+globalPositionsStrictlyIncreasing v =+    let ps = V.toList (V.map (\e -> let GlobalPosition p = e ^. #globalPosition in p) v)+     in and (zipWith (<) ps (drop 1 ps))++mkName :: String -> Int -> Text+mkName tag i = T.pack (tag <> "-" <> show i)
+ test/Test/Concurrency.hs view
@@ -0,0 +1,280 @@+{- | Deterministic concurrency tests for kiroku-store.++Each test spawns multiple threads that race on append paths the+single-threaded scenario suite cannot exercise. The tests target the+EP-6 M1 Concurrency Scenarios (F9–F11) and verify EP-1 F4 (the sorted+@SELECT … FOR UPDATE@ pre-pass that prevents multi-stream deadlocks)+under deliberate adversarial ordering.++Each test acquires a fresh ephemeral PostgreSQL via 'withTestStore'.+-}+module Test.Concurrency (spec) where++import Control.Concurrent.Async qualified as Async+import Control.Lens ((^.))+import Control.Monad (forM_)+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.Int (Int64)+import Data.List (sort)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.UUID qualified as UUID+import Data.Vector qualified as V+import Kiroku.Store+import Test.Helpers (countEvents, makeEvent, withTestStore)+import Test.Hspec++spec :: Spec+spec = describe "kiroku-store concurrency (deterministic)" $ do+    it "many AnyVersion writers to one stream preserve stream and global order" $+        withTestStore $ \store -> do+            let writerCount = 24+                stream = StreamName "stress-one-stream"+            results <-+                Async.forConcurrently [1 .. writerCount] $ \i -> do+                    runStoreIO store $+                        appendToStream+                            stream+                            AnyVersion+                            [makeEvent ("Stress" <> T.pack (show i)) (Aeson.object [])]+            mapM_ assertRightAppend results+            Right streamEvents <- runStoreIO store $ readStreamForward stream (StreamVersion 0) 1000+            V.length streamEvents `shouldBe` writerCount+            streamVersions streamEvents `shouldBe` [1 .. fromIntegral writerCount]+            Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 1000+            V.length allEvents `shouldBe` writerCount+            globalPositions allEvents `shouldBe` [1 .. fromIntegral writerCount]++    it "many AnyVersion writers to invoice-payment preserve stream and global order" $+        withTestStore $ \store -> do+            let writerCount = 32+                stream = StreamName "invoice-payment"+            results <-+                Async.forConcurrently [1 .. writerCount] $ \i -> do+                    runStoreIO store $+                        appendToStream+                            stream+                            AnyVersion+                            [makeEvent ("InvoicePayment" <> T.pack (show i)) (Aeson.object [])]+            mapM_ assertRightAppend results+            Right streamEvents <- runStoreIO store $ readStreamForward stream (StreamVersion 0) 1000+            V.length streamEvents `shouldBe` writerCount+            streamVersions streamEvents `shouldBe` [1 .. fromIntegral writerCount]+            Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 1000+            V.length allEvents `shouldBe` writerCount+            globalPositions allEvents `shouldBe` [1 .. fromIntegral writerCount]+            Set.fromList (eventIds streamEvents) `shouldBe` Set.fromList (eventIds allEvents)++    it "many batched writers to different streams preserve batch-local and global order" $+        withTestStore $ \store -> do+            let streamCount = 12+                batchSize = 10+                totalEvents = streamCount * batchSize+                mkStream i = StreamName ("stress-batch-" <> T.pack (show i))+                mkBatch i =+                    [ makeEvent ("Batch" <> T.pack (show i) <> "-" <> T.pack (show j)) (Aeson.object [])+                    | j <- [1 .. batchSize]+                    ]+            results <-+                Async.forConcurrently [1 .. streamCount] $ \i -> do+                    runStoreIO store $ appendToStream (mkStream i) NoStream (mkBatch i)+            mapM_ assertRightAppend results+            forM_ [1 .. streamCount] $ \i -> do+                Right streamEvents <- runStoreIO store $ readStreamForward (mkStream i) (StreamVersion 0) 1000+                streamVersions streamEvents `shouldBe` [1 .. fromIntegral batchSize]+            Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 1000+            V.length allEvents `shouldBe` totalEvents+            globalPositions allEvents `shouldBe` [1 .. fromIntegral totalEvents]++    it "large append batches return the final stream and global positions" $+        withTestStore $ \store -> do+            let stream = StreamName "stress-large-batches"+                mkBatch label n =+                    [ makeEvent (label <> "-" <> T.pack (show i)) (Aeson.object [])+                    | i <- [1 .. n]+                    ]+            Right r10 <- runStoreIO store $ appendToStream stream NoStream (mkBatch "Batch10" 10)+            (r10 ^. #streamVersion) `shouldBe` StreamVersion 10+            (r10 ^. #globalPosition) `shouldBe` GlobalPosition 10+            Right r100 <- runStoreIO store $ appendToStream stream AnyVersion (mkBatch "Batch100" 100)+            (r100 ^. #streamVersion) `shouldBe` StreamVersion 110+            (r100 ^. #globalPosition) `shouldBe` GlobalPosition 110+            Right streamEvents <- runStoreIO store $ readStreamForward stream (StreamVersion 0) 200+            streamVersions streamEvents `shouldBe` [1 .. 110]+            Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 200+            globalPositions allEvents `shouldBe` [1 .. 110]++    it "overlapping appendMultiStream stress preserves all-or-nothing ordering" $+        withTestStore $ \store -> do+            let streams = [StreamName "stress-multi-a", StreamName "stress-multi-b", StreamName "stress-multi-c"]+                rotations =+                    [ streams+                    , [StreamName "stress-multi-b", StreamName "stress-multi-c", StreamName "stress-multi-a"]+                    , [StreamName "stress-multi-c", StreamName "stress-multi-a", StreamName "stress-multi-b"]+                    ]+                opsFor i =+                    [ (sn, AnyVersion, [makeEvent ("Multi" <> T.pack (show i) <> "-" <> labelStream sn) (Aeson.object [])])+                    | sn <- rotations !! (i `mod` length rotations)+                    ]+            forM_ streams $ \sn -> do+                result <- runStoreIO store $ appendToStream sn NoStream [makeEvent "init" (Aeson.object [])]+                assertRightAppend result+            results <-+                Async.forConcurrently [1 .. 9] $ \i -> do+                    runStoreIO store $ appendMultiStream (opsFor i)+            mapM_ assertRightMulti results+            forM_ streams $ \sn -> do+                Right streamEvents <- runStoreIO store $ readStreamForward sn (StreamVersion 0) 100+                streamVersions streamEvents `shouldBe` [1 .. 10]+            Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+            V.length allEvents `shouldBe` 30+            globalPositions allEvents `shouldBe` [1 .. 30]++    it "duplicate event failure leaves touched streams and $all unchanged" $+        withTestStore $ \store -> do+            let duplicate =+                    EventId $+                        case UUID.fromString "01234567-89ab-7def-8012-34567890abce" of+                            Just u -> u+                            Nothing -> error "bad uuid"+                duplicateEvent =+                    EventData+                        { eventId = Just duplicate+                        , eventType = EventType "Duplicate"+                        , payload = Aeson.object []+                        , metadata = Nothing+                        , causationId = Nothing+                        , correlationId = Nothing+                        }+            Right _ <- runStoreIO store $ appendToStream (StreamName "rollback-seed") NoStream [duplicateEvent]+            Right _ <- runStoreIO store $ appendToStream (StreamName "rollback-a") NoStream [makeEvent "init-a" (Aeson.object [])]+            Right _ <- runStoreIO store $ appendToStream (StreamName "rollback-b") NoStream [makeEvent "init-b" (Aeson.object [])]+            beforeCount <- countEvents store+            Right beforeAll <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+            result <-+                runStoreIO store $+                    appendMultiStream+                        [ (StreamName "rollback-a", AnyVersion, [duplicateEvent])+                        , (StreamName "rollback-b", AnyVersion, [makeEvent "should-not-commit" (Aeson.object [])])+                        ]+            case result of+                Left (DuplicateEvent _) -> pure ()+                other -> expectationFailure ("duplicate event should abort the multi-stream transaction, got: " <> show other)+            countEvents store `shouldReturn` beforeCount+            Right afterAll <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+            globalPositions afterAll `shouldBe` globalPositions beforeAll+            Right streamA <- runStoreIO store $ readStreamForward (StreamName "rollback-a") (StreamVersion 0) 100+            Right streamB <- runStoreIO store $ readStreamForward (StreamName "rollback-b") (StreamVersion 0) 100+            streamVersions streamA `shouldBe` [1]+            streamVersions streamB `shouldBe` [1]++    -- F9 — Two concurrent appends to different streams. Both calls+    -- must succeed, the global positions must be unique and contiguous,+    -- and the test must not deadlock.+    it "two concurrent appends to different streams both succeed (F9)" $+        withTestStore $ \store -> do+            (rA, rB) <-+                Async.concurrently+                    (runStoreIO store $ appendToStream (StreamName "f9-a") NoStream [makeEvent "A" (Aeson.object [])])+                    (runStoreIO store $ appendToStream (StreamName "f9-b") NoStream [makeEvent "B" (Aeson.object [])])+            case (rA, rB) of+                (Right resA, Right resB) -> do+                    let pA = case resA ^. #globalPosition of GlobalPosition n -> n+                        pB = case resB ^. #globalPosition of GlobalPosition n -> n+                    pA `shouldNotBe` pB+                    Set.fromList [pA, pB] `shouldBe` Set.fromList [1, 2]+                other -> expectationFailure ("F9: both should succeed, got: " <> show other)++    -- F10 — Two concurrent appends to the same stream with the same+    -- ExactVersion. Exactly one must succeed; the other must fail+    -- with WrongExpectedVersion. No deadlock. Stream is pre-created+    -- because ExactVersion 0 against a non-existent stream is itself+    -- an error in kiroku (streams start at version 1).+    it "two concurrent ExactVersion appends to same stream — one wins (F10)" $+        withTestStore $ \store -> do+            Right _ <- runStoreIO store $ appendToStream (StreamName "f10") NoStream [makeEvent "Init" (Aeson.object [])]+            (r1, r2) <-+                Async.concurrently+                    (runStoreIO store $ appendToStream (StreamName "f10") (ExactVersion (StreamVersion 1)) [makeEvent "X" (Aeson.object [])])+                    (runStoreIO store $ appendToStream (StreamName "f10") (ExactVersion (StreamVersion 1)) [makeEvent "Y" (Aeson.object [])])+            case (r1, r2) of+                (Right _, Left (WrongExpectedVersion _ _ _)) -> pure ()+                (Left (WrongExpectedVersion _ _ _), Right _) -> pure ()+                other -> expectationFailure ("F10: exactly one should win with the loser returning WrongExpectedVersion, got: " <> show other)+            -- Stream must have exactly init + winner = 2 events after the race.+            Right events <- runStoreIO store $ readStreamForward (StreamName "f10") (StreamVersion 0) 100+            V.length events `shouldBe` 2++    -- F11 — Two concurrent appendMultiStream calls touching the same+    -- streams in opposite order. EP-1 F4's sorted SELECT FOR UPDATE+    -- pre-pass ensures both transactions acquire row locks in the+    -- same canonical order, preventing the classic two-resource+    -- deadlock. Without the fix, this test would intermittently fail+    -- with PostgreSQL deadlock detection (40P01).+    it "two concurrent multi-stream appends in opposite order do not deadlock (F11)" $+        withTestStore $ \store -> do+            -- Pre-create both streams so the multi-stream calls take+            -- the existing-stream path (where pre-locking matters).+            Right _ <- runStoreIO store $ appendToStream (StreamName "f11-x") NoStream [makeEvent "init-x" (Aeson.object [])]+            Right _ <- runStoreIO store $ appendToStream (StreamName "f11-y") NoStream [makeEvent "init-y" (Aeson.object [])]+            let opsXY =+                    [ (StreamName "f11-x", AnyVersion, [makeEvent "Ax" (Aeson.object [])])+                    , (StreamName "f11-y", AnyVersion, [makeEvent "Ay" (Aeson.object [])])+                    ]+                opsYX =+                    [ (StreamName "f11-y", AnyVersion, [makeEvent "By" (Aeson.object [])])+                    , (StreamName "f11-x", AnyVersion, [makeEvent "Bx" (Aeson.object [])])+                    ]+            (rA, rB) <-+                Async.concurrently+                    (runStoreIO store $ appendMultiStream opsXY)+                    (runStoreIO store $ appendMultiStream opsYX)+            case (rA, rB) of+                (Right _, Right _) -> pure ()+                other -> expectationFailure ("F11: both calls must succeed without deadlock, got: " <> show other)+            -- Each stream contains its init event plus one event from+            -- each of the two concurrent multi-stream appends (3 each).+            Right xs <- runStoreIO store $ readStreamForward (StreamName "f11-x") (StreamVersion 0) 100+            Right ys <- runStoreIO store $ readStreamForward (StreamName "f11-y") (StreamVersion 0) 100+            V.length xs `shouldBe` 3+            V.length ys `shouldBe` 3+            -- \$all has 6 events total (2 inits + 4 from concurrent calls).+            Right allEvts <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+            V.length allEvts `shouldBe` 6+            let positions =+                    map+                        (\e -> case e ^. #globalPosition of GlobalPosition n -> n)+                        (V.toList allEvts)+            sort positions `shouldBe` [1, 2, 3, 4, 5, 6]++assertRightAppend :: Either StoreError AppendResult -> IO ()+assertRightAppend = \case+    Right _ -> pure ()+    Left err -> expectationFailure ("append should succeed, got: " <> show err)++assertRightMulti :: Either StoreError [AppendResult] -> IO ()+assertRightMulti = \case+    Right _ -> pure ()+    Left err -> expectationFailure ("appendMultiStream should succeed, got: " <> show err)++streamVersions :: V.Vector RecordedEvent -> [Int64]+streamVersions =+    map+        (\e -> case e ^. #streamVersion of StreamVersion n -> n)+        . V.toList++globalPositions :: V.Vector RecordedEvent -> [Int64]+globalPositions =+    map+        (\e -> case e ^. #globalPosition of GlobalPosition n -> n)+        . V.toList++eventIds :: V.Vector RecordedEvent -> [EventId]+eventIds =+    map (^. #eventId)+        . V.toList++labelStream :: StreamName -> Text+labelStream (StreamName name) = name
+ test/Test/ConsumerGroup.hs view
@@ -0,0 +1,335 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Runtime tests for consumer groups (ExecPlan 29 / EP-2). Each member runs as+one in-process subscription worker over a fresh ephemeral PostgreSQL. The+properties proven here are the user-visible contract: a group's members deliver a+/disjoint/, /complete/, /per-stream-ordered/ partition of the source; a size-1+group equals a plain subscription; and each member resumes from its /own/+checkpoint.+-}+module Test.ConsumerGroup (spec) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar)+import Control.Exception (fromException)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int32, Int64)+import Data.List (sort)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Conn+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Kiroku.Store+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Subscription.Stream (subscriptionStream)+import Kiroku.Store.Subscription.Types (ConsumerGroup (..), SubscriptionConfigM (..))+import Kiroku.Test.Postgres (withMigratedTestDatabase)+import Streamly.Data.Stream qualified as Stream+import Test.Helpers (makeEvent, waitForPublisher, waitWithTimeout, withTestStore, withTestStoreSettings)+import Test.Hspec++-- | Extract @(originalStreamId, globalPosition)@ as raw 'Int64's from an event.+pairOf :: RecordedEvent -> (Int64, Int64)+pairOf e =+    ( case e ^. #originalStreamId of StreamId s -> s+    , case e ^. #globalPosition of GlobalPosition p -> p+    )++-- | Append @perStream@ events to each named stream, seeding the store.+seed :: KirokuStore -> [Text] -> Int -> IO ()+seed store names perStream =+    mapM_+        ( \sn -> do+            let evs = map (\k -> makeEvent ("E" <> T.pack (show k)) (Aeson.object [])) [1 .. perStream]+            r <- runStoreIO store $ appendToStream (StreamName sn) NoStream evs+            case r of+                Left err -> error ("seed append failed for " <> T.unpack sn <> ": " <> show err)+                Right _ -> pure ()+        )+        names++-- | Poll an @IO Bool@ predicate until it holds or the microsecond budget runs out.+waitUntil :: Int -> IO Bool -> IO ()+waitUntil budget act+    | budget <= 0 = pure ()+    | otherwise = do+        ok <- act+        if ok+            then pure ()+            else do+                threadDelay 20_000+                waitUntil (budget - 20_000) act++{- | Assert that within each originating stream the global positions, taken in+delivery order, are strictly ascending (i.e. equal to their sorted form).+-}+assertPerStreamAscending :: [(Int64, Int64)] -> Expectation+assertPerStreamAscending chrono =+    let byStream = Map.fromListWith (\new old -> old ++ new) [(sid, [gp]) | (sid, gp) <- chrono]+     in mapM_ (\ps -> ps `shouldBe` sort ps) (Map.elems byStream)++-- | A size-@n@ category-group config for member @m@ with the given handler.+memberConfig ::+    Text -> Text -> Int32 -> Int32 -> EventHandler -> SubscriptionConfig+memberConfig nm cat m n h =+    (defaultSubscriptionConfig (SubscriptionName nm) (Category (CategoryName cat)) h)+        { consumerGroup = Just (ConsumerGroup{member = m, size = n})+        }++-- | A size-@n@ @$all@-group config for member @m@ with the given handler.+memberConfigAll ::+    Text -> Int32 -> Int32 -> EventHandler -> SubscriptionConfig+memberConfigAll nm m n h =+    (defaultSubscriptionConfig (SubscriptionName nm) AllStreams h)+        { consumerGroup = Just (ConsumerGroup{member = m, size = n})+        }++{- | Run a subscription built from the given config-completer, collecting the+global positions it delivers and stopping the handler after @k@ events. Returns+the @k@ positions in delivery order.+-}+collectStopAfter :: KirokuStore -> (EventHandler -> SubscriptionConfig) -> Int -> IO [Int64]+collectStopAfter store mkCfg k = do+    ref <- newIORef []+    countVar <- newTVarIO (0 :: Int)+    let h evt = do+            modifyIORef' ref (snd (pairOf evt) :)+            c <- atomically $ do+                c0 <- readTVar countVar+                let c1 = c0 + 1+                writeTVar countVar c1+                pure c1+            pure (if c >= k then Stop else Continue)+    handle <- subscribe store (mkCfg h)+    _ <- waitWithTimeout 15_000_000 handle+    reverse <$> readIORef ref++-- | Run a Hasql session against the store pool, failing the test on a usage error.+runStmtP :: KirokuStore -> Session.Session a -> IO a+runStmtP store session = do+    r <- Pool.use (store ^. #pool) session+    either (error . show) pure r++spec :: Spec+spec = describe "consumer groups" $ do+    it "delivers a disjoint, complete, per-stream-ordered partition (size-4 category group)" $+        withTestStore $ \store -> do+            let nStreams = 40+                perStream = 3+                total = nStreams * perStream+                streams = ["acct-" <> T.pack (show i) | i <- [1 .. nStreams]]+            seed store streams perStream+            waitForPublisher store (GlobalPosition (fromIntegral total))++            let n = 4 :: Int32+            refs <- mapM (const (newIORef [])) [0 .. n - 1]+            handles <-+                mapM+                    ( \m -> do+                        let ref = refs !! fromIntegral m+                            h evt = do+                                modifyIORef' ref (pairOf evt :)+                                pure Continue+                        subscribe store (memberConfig "cg-cat" "acct" m n h)+                    )+                    [0 .. n - 1]++            let collectedCount = sum <$> mapM (fmap length . readIORef) refs+            waitUntil 15_000_000 (fmap (>= total) collectedCount)+            mapM_ cancel handles++            collected <- mapM readIORef refs+            -- (1) Disjoint + complete: the multiset of all delivered positions is+            --     exactly [1..total] — no duplicate (would lengthen it) and no gap.+            let allPositions = sort (concatMap (map snd) collected)+            allPositions `shouldBe` [1 .. fromIntegral total]+            -- (2) Per-stream ordering within each member (collector prepended, so+            --     reverse to recover delivery order).+            mapM_ (assertPerStreamAscending . reverse) collected++    it "size-1 group delivers the same set as a plain subscription" $+        withTestStore $ \store -> do+            let nStreams = 4+                perStream = 3+                total = nStreams * perStream+                streams = ["uno-" <> T.pack (show i) | i <- [1 .. nStreams]]+            seed store streams perStream+            waitForPublisher store (GlobalPosition (fromIntegral total))++            let runCollector cfgFor nm = do+                    ref <- newIORef []+                    countVar <- newTVarIO (0 :: Int)+                    let h evt = do+                            modifyIORef' ref (snd (pairOf evt) :)+                            c <- atomically $ do+                                c0 <- readTVar countVar+                                let c1 = c0 + 1+                                writeTVar countVar c1+                                pure c1+                            pure (if c >= total then Stop else Continue)+                    handle <- subscribe store (cfgFor nm h)+                    _ <- waitWithTimeout 15_000_000 handle+                    sort <$> readIORef ref++            plain <-+                runCollector+                    (\nm h -> defaultSubscriptionConfig (SubscriptionName nm) (Category (CategoryName "uno")) h)+                    "uno-plain"+            grouped <-+                runCollector+                    (\nm h -> memberConfig nm "uno" 0 1 h)+                    "uno-group"++            plain `shouldBe` [1 .. fromIntegral total]+            grouped `shouldBe` plain++    it "$all group partitions the whole store across members" $+        withTestStore $ \store -> do+            let cats = ["acct", "user", "order"]+                perCat = 10+                perStream = 2+                streams = [c <> "-" <> T.pack (show i) | c <- cats, i <- [1 .. perCat]]+                total = length streams * perStream+            seed store streams perStream+            waitForPublisher store (GlobalPosition (fromIntegral total))++            let n = 4 :: Int32+            refs <- mapM (const (newIORef [])) [0 .. n - 1]+            handles <-+                mapM+                    ( \m -> do+                        let ref = refs !! fromIntegral m+                            h evt = do+                                modifyIORef' ref (pairOf evt :)+                                pure Continue+                        subscribe store (memberConfigAll "cg-all" m n h)+                    )+                    [0 .. n - 1]++            let collectedCount = sum <$> mapM (fmap length . readIORef) refs+            waitUntil 15_000_000 (fmap (>= total) collectedCount)+            mapM_ cancel handles++            collected <- mapM readIORef refs+            let allPositions = sort (concatMap (map snd) collected)+            allPositions `shouldBe` [1 .. fromIntegral total]+            mapM_ (assertPerStreamAscending . reverse) collected++    it "resumes member 2 from its own (name, member) checkpoint" $+        withTestStore $ \store -> do+            let nStreams = 60+                streams = ["rz-" <> T.pack (show i) | i <- [1 .. nStreams]]+            seed store streams 1+            waitForPublisher store (GlobalPosition (fromIntegral nStreams))++            -- Member 2's slice positions, in order, straight from the EP-1 partition+            -- SQL — the deterministic ground truth for what member 2 should receive.+            sliceV <-+                runStmtP store $+                    Session.statement+                        (0 :: Int64, "rz" :: Text, 2 :: Int32, 4 :: Int32, 100000 :: Int32)+                        SQL.readCategoryForwardConsumerGroupStmt+            let slice = map (snd . pairOf) (V.toList sliceV)+            length slice `shouldSatisfy` (>= 4)++            -- Run 1: member 2 stops after 2 events; checkpoint (rz-sub, 2) = slice!!1.+            run1 <- collectStopAfter store (memberConfig "rz-sub" "rz" 2 4) 2+            run1 `shouldBe` take 2 slice++            -- A competing, much higher checkpoint for a DIFFERENT member under the+            -- SAME name. If checkpoints were keyed by name only, member 2's restart+            -- would resume from here and skip its events; member-keyed checkpoints+            -- must ignore it.+            runStmtP store $+                Session.statement+                    ("rz-sub" :: Text, 0 :: Int32, 10_000_000 :: Int64)+                    SQL.saveCheckpointMemberStmt++            -- Run 2: member 2 restarts and must resume from its OWN checkpoint+            -- (slice!!1), delivering the next two member-2 events.+            run2 <- collectStopAfter store (memberConfig "rz-sub" "rz" 2 4) 2+            run2 `shouldBe` take 2 (drop 2 slice)++    it "lifecycle events carry the consumer-group member context (GroupMember 2 4)" $ do+        ref <- newIORef ([] :: [KirokuEvent])+        let evtHandler e = modifyIORef' ref (e :)+            isStartedMember2 ev = case ev of+                KirokuEventSubscriptionStarted (SubscriptionName "obs-sub") _ (GroupMember 2 4) -> True+                _ -> False+        withTestStoreSettings (\s -> s & #eventHandler .~ Just evtHandler) $ \store -> do+            handle <- subscribe store (memberConfig "obs-sub" "obs" 2 4 (\_ -> pure Continue))+            waitUntil 5_000_000 (any isStartedMember2 <$> readIORef ref)+            cancel handle+            evts <- readIORef ref+            any isStartedMember2 evts `shouldBe` True++    it "consumerGroupGuard fails fast when another holder holds the (name, member) lock" $ do+        withMigratedTestDatabase $ \cs -> do+            withStore (defaultConnectionSettings cs) $ \store -> do+                -- Holder: a dedicated connection takes the SESSION-level advisory+                -- lock for the same key the worker's guard probes, namely+                -- hashtextextended("guard-sub:3", 0). It is held until release.+                eConn <- Connection.acquire (Conn.connectionString cs)+                conn <- either (\e -> error ("guard holder connect failed: " <> show e)) pure eConn+                let holdStmt :: Statement Text ()+                    holdStmt =+                        preparable+                            "SELECT pg_advisory_lock(hashtextextended($1, 0))"+                            (E.param (E.nonNullable E.text))+                            D.noResult+                lockRes <- Connection.use conn (Session.statement "guard-sub:3" holdStmt)+                either (\e -> error ("guard holder lock failed: " <> show e)) pure lockRes++                let cfg =+                        (defaultSubscriptionConfig (SubscriptionName "guard-sub") (Category (CategoryName "guardcat")) (\_ -> pure Continue))+                            { consumerGroup = Just (ConsumerGroup{member = 3, size = 4})+                            , consumerGroupGuard = True+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                handle <- subscribe store cfg+                res <- waitWithTimeout 5_000_000 handle+                Connection.release conn+                case res of+                    Right (Left e)+                        | Just (ConsumerGroupGuardConflict (SubscriptionName "guard-sub") 3) <- fromException e ->+                            pure ()+                    other ->+                        expectationFailure ("expected ConsumerGroupGuardConflict, got: " <> show other)++    it "subscriptionStream forwards the consumer-group field (member 0 of 2 sees its slice)" $+        withTestStore $ \store -> do+            let nStreams = 20+                perStream = 2+                total = nStreams * perStream+                streams = ["bridge-" <> T.pack (show i) | i <- [1 .. nStreams]]+            seed store streams perStream+            waitForPublisher store (GlobalPosition (fromIntegral total))++            sliceV <-+                runStmtP store $+                    Session.statement+                        (0 :: Int64, "bridge" :: Text, 0 :: Int32, 2 :: Int32, 100000 :: Int32)+                        SQL.readCategoryForwardConsumerGroupStmt+            let slicePos = sort (map (snd . pairOf) (V.toList sliceV))+                k = length slicePos+            -- A proper, non-trivial subset of the whole category.+            k `shouldSatisfy` (\x -> x > 0 && x < total)++            (stream, cancelStream) <-+                subscriptionStream store (memberConfig "bridge-sub" "bridge" 0 2 (\_ -> pure Continue)) 64+            pulled <- Stream.toList (Stream.take k stream)+            cancelStream+            sort (map (snd . pairOf) pulled) `shouldBe` slicePos
+ test/Test/ConsumerGroupEffect.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{- | Consumer-group tests for the /effectful/ subscription API (ExecPlan 30 /+EP-3). EP-2's 'Test.ConsumerGroup' proves the partitioning contract through the+plain-IO 'Kiroku.Store.Subscription.subscribe'; this module proves the same+contract holds through 'Kiroku.Store.Subscription.Effect' — the higher-order+'Subscription' effect interpreted by 'runSubscription' inside an @Eff@ stack.++Two properties are proven:++  * Each member of a size-2 category group, driven through @runSubscription@ /+    @subscribe@, receives exactly its hash-assigned slice; the two slices are+    /disjoint/, their union is /complete/, and each is /per-stream-ordered/.+  * The @ConcUnlift Persistent (Limited 1)@ strategy used by 'runSubscription'+    keeps the effect environment alive across handler calls: an+    'Effectful.State.Static.Local.State' counter mutated inside the handler+    accumulates @1, 2, 3, ...@ across deliveries rather than resetting to @1@+    each call (which is what an @Ephemeral@ unlift would produce).++__Why every handler returns 'Stop' rather than relying on external cancel.__+A worker started through the effectful interpreter runs its handler via the+captured @localUnliftIO@ environment. Cancelling such a worker from outside+(e.g. through the effectful 'Kiroku.Store.Subscription.Effect.withSubscription'+bracket) while it is blocked inside that unlift does not terminate cleanly — it+hangs the worker thread. Every member here therefore stops itself once it has+seen its expected number of events, so the worker exits on its own and the+@Eff@ scope closes with no live thread (the same shape as the working effectful+test in @kiroku-store/test/Main.hs@, "catches up with an Eff-based handler via+the effectful API"). See this module's Surprises note in+@docs/plans/30-consumer-group-effect-api-and-shibuya-adapter-integration.md@.+-}+module Test.ConsumerGroupEffect (spec) where++import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar)+import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int32, Int64)+import Data.List (sort)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import Effectful (Eff, IOE, runEff, (:>))+import Effectful.State.Static.Local qualified as State+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Kiroku.Store+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Subscription.Effect qualified as SubEff+import Kiroku.Store.Subscription.Types (ConsumerGroup (..), SubscriptionConfigM (..))+import Test.Helpers (makeEvent, waitForPublisher, waitWithTimeout, withTestStore)+import Test.Hspec++-- | Extract @(originalStreamId, globalPosition)@ as raw 'Int64's from an event.+pairOf :: RecordedEvent -> (Int64, Int64)+pairOf e =+    ( case e ^. #originalStreamId of StreamId s -> s+    , case e ^. #globalPosition of GlobalPosition p -> p+    )++-- | Append @perStream@ events to each named stream, seeding the store.+seed :: KirokuStore -> [Text] -> Int -> IO ()+seed store names perStream =+    mapM_+        ( \sn -> do+            let evs = map (\k -> makeEvent ("E" <> T.pack (show k)) (Aeson.object [])) [1 .. perStream]+            r <- runStoreIO store $ appendToStream (StreamName sn) NoStream evs+            case r of+                Left err -> error ("seed append failed for " <> T.unpack sn <> ": " <> show err)+                Right _ -> pure ()+        )+        names++{- | Assert that within each originating stream the global positions, taken in+delivery order, are strictly ascending (i.e. equal to their sorted form).+-}+assertPerStreamAscending :: [(Int64, Int64)] -> Expectation+assertPerStreamAscending chrono =+    let byStream = Map.fromListWith (\new old -> old ++ new) [(sid, [gp]) | (sid, gp) <- chrono]+     in mapM_ (\ps -> ps `shouldBe` sort ps) (Map.elems byStream)++-- | Run a Hasql session against the store pool, failing the test on error.+runStmtP :: KirokuStore -> Session.Session a -> IO a+runStmtP store session = do+    r <- Pool.use (store ^. #pool) session+    either (error . show) pure r++{- | Drive one effectful category-group member to self-completion: it 'Stop's+after receiving exactly @k@ events, so the worker exits on its own (no external+cancel). Returns the @(streamId, globalPosition)@ pairs in delivery order. The+handler runs in @Eff es@ (needing only 'IOE'), exercising the @runSubscription@+record-update pass-through of the @consumerGroup@ field.+-}+runEffMember :: KirokuStore -> Text -> Text -> Int32 -> Int32 -> Int -> IO [(Int64, Int64)]+runEffMember store nm cat m n k = do+    ref <- newIORef []+    countVar <- newTVarIO (0 :: Int)+    let effHandler :: (IOE :> es) => RecordedEvent -> Eff es SubscriptionResult+        effHandler evt = do+            liftIO $ modifyIORef' ref (pairOf evt :)+            c <- liftIO $ atomically $ do+                c0 <- readTVar countVar+                writeTVar countVar (c0 + 1)+                pure (c0 + 1)+            pure (if c >= k then Stop else Continue)+        cfg =+            (defaultSubscriptionConfig (SubscriptionName nm) (Category (CategoryName cat)) effHandler)+                { consumerGroup = Just (ConsumerGroup{member = m, size = n})+                }+    runEff $ SubEff.runSubscription store $ do+        handle <- SubEff.subscribe cfg+        liftIO $ do+            r <- waitWithTimeout 15_000_000 handle+            case r of+                Left timeout -> expectationFailure timeout+                Right (Left err) -> expectationFailure ("effectful member failed: " <> show err)+                Right (Right ()) -> pure ()+    reverse <$> readIORef ref++spec :: Spec+spec = describe "consumer groups (effectful)" $ do+    it "routes each member through the effectful API to its own disjoint, complete, per-stream-ordered slice (size-2 category group)" $+        withTestStore $ \store -> do+            let nStreams = 40+                perStream = 3+                total = nStreams * perStream+                streams = ["effcg-" <> T.pack (show i) | i <- [1 .. nStreams]]+            seed store streams perStream+            waitForPublisher store (GlobalPosition (fromIntegral total))++            -- Deterministic ground truth: each member's slice size straight from the+            -- EP-1 partition SQL. The effectful workers must reproduce exactly these.+            let sliceSize m =+                    V.length+                        <$> runStmtP+                            store+                            ( Session.statement+                                (0 :: Int64, "effcg" :: Text, m, 2 :: Int32, 100000 :: Int32)+                                SQL.readCategoryForwardConsumerGroupStmt+                            )+            k0 <- sliceSize 0+            k1 <- sliceSize 1+            k0 `shouldSatisfy` (> 0)+            k1 `shouldSatisfy` (> 0)+            (k0 + k1) `shouldBe` total++            -- Each member is driven through runSubscription/subscribe and self-exits.+            -- Same subscription name, distinct members → independent (name, member)+            -- checkpoints, so running them in sequence is safe.+            m0 <- runEffMember store "eff-cg-cat" "effcg" 0 2 k0+            m1 <- runEffMember store "eff-cg-cat" "effcg" 1 2 k1++            -- (1) Disjoint + complete: the union of both members' delivered positions+            --     is exactly [1..total] — no duplicate and no gap.+            let allPositions = sort (map snd m0 ++ map snd m1)+            allPositions `shouldBe` [1 .. fromIntegral total]+            -- (2) Per-stream ordering preserved within each member.+            assertPerStreamAscending m0+            assertPerStreamAscending m1++    it "preserves State across handler calls within one member (Persistent unlift)" $+        withTestStore $ \store -> do+            -- Five events on one stream of category "effstate"; a size-1 member sees all.+            seed store ["effstate-1"] 5+            waitForPublisher store (GlobalPosition 5)++            -- 'seenRef' records the Effectful State value observed after each+            -- increment; 'nVar' counts deliveries and drives the Stop (so self-exit+            -- never depends on the property under test). With the Persistent unlift+            -- the cloned environment is reused across calls and the counter+            -- accumulates 1,2,3,4,5; an Ephemeral unlift would record 1 every time.+            seenRef <- newIORef ([] :: [Int])+            nVar <- newTVarIO (0 :: Int)+            runEff $+                SubEff.runSubscription store $+                    State.evalState (0 :: Int) $ do+                        let cfg =+                                ( defaultSubscriptionConfig+                                    (SubscriptionName "eff-state-sub")+                                    (Category (CategoryName "effstate"))+                                    ( \_ -> do+                                        State.modify @Int (+ 1)+                                        s <- State.get @Int+                                        liftIO (modifyIORef' seenRef (s :))+                                        c <- liftIO $ atomically $ do+                                            c0 <- readTVar nVar+                                            writeTVar nVar (c0 + 1)+                                            pure (c0 + 1)+                                        pure (if c >= 5 then Stop else Continue)+                                    )+                                )+                                    { consumerGroup = Just (ConsumerGroup{member = 0, size = 1})+                                    }+                        handle <- SubEff.subscribe cfg+                        liftIO $ do+                            r <- waitWithTimeout 10_000_000 handle+                            case r of+                                Left timeout -> expectationFailure timeout+                                Right (Left err) -> expectationFailure ("effectful state member failed: " <> show err)+                                Right (Right ()) -> pure ()++            seen <- reverse <$> readIORef seenRef+            seen `shouldBe` [1, 2, 3, 4, 5]
+ test/Test/ConsumerGroupSql.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE OverloadedStrings #-}++{- | SQL-level tests for consumer-group partition routing and per-member+checkpoints (ExecPlan 28 / EP-1). These exercise the new prepared statements in+"Kiroku.Store.SQL" directly through the connection pool, with no subscription+runtime, on a fresh ephemeral PostgreSQL per test.++Terms: a /consumer group/ of /size/ N has members 0..N-1; each source stream is+assigned to exactly one member by 'Kiroku.Store.SQL'-encoded hash routing. The+properties proven here — disjointness, completeness, per-stream affinity,+determinism, and size-1 equivalence — are the contract EP-2's runtime depends on.+-}+module Test.ConsumerGroupSql (spec) where++import Contravariant.Extras (contrazip2)+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.Int (Int32, Int64)+import Data.List (sort)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.UUID (UUID)+import Data.Vector (Vector)+import Data.Vector qualified as V+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Kiroku.Store+import Kiroku.Store.SQL qualified as SQL+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec++-- | A generous limit that returns every seeded event in one read.+bigLimit :: Int32+bigLimit = 100000++-- | Run a statement against the store's pool, failing the test on a usage error.+runStmt :: KirokuStore -> Session.Session a -> IO a+runStmt store session = do+    result <- Pool.use (store ^. #pool) session+    case result of+        Left err -> error ("ConsumerGroupSql statement failed: " <> show err)+        Right a -> pure a++{- | Append one event to each of the named streams, seeding the store. Each+stream gets a single event; per-stream affinity is what we test, so one event+per stream is enough, but the helper appends 'n' events to vary versions.+-}+seedStreams :: KirokuStore -> [Text] -> Int -> IO ()+seedStreams store names n =+    mapM_+        ( \name -> do+            let events = map (\i -> makeEvent ("E" <> T.pack (show i)) (Aeson.object [])) [1 .. n]+            r <- runStoreIO store $ appendToStream (StreamName name) NoStream events+            case r of+                Left err -> error ("seed append failed for " <> T.unpack name <> ": " <> show err)+                Right _ -> pure ()+        )+        names++-- | Collect the event ids from a read result, in order.+eventIds :: Vector RecordedEvent -> [UUID]+eventIds = map (\e -> case e ^. #eventId of EventId u -> u) . V.toList++-- | Collect (originalStreamId, globalPosition) pairs from a read result.+streamPositions :: Vector RecordedEvent -> [(Int64, Int64)]+streamPositions =+    map+        ( \e ->+            ( case e ^. #originalStreamId of StreamId s -> s+            , case e ^. #globalPosition of GlobalPosition p -> p+            )+        )+        . V.toList++{- | Direct call to the partition rule for one stream id and size, returning the+member index PostgreSQL computes. Mirrors IP-1 exactly so the test pins the+formula, not just its consequences.+-}+runMemberOf :: KirokuStore -> Int64 -> Int32 -> IO Int32+runMemberOf store streamId size = runStmt store (Session.statement (streamId, size) stmt)+  where+    stmt :: Statement (Int64, Int32) Int32+    stmt =+        preparable+            "SELECT (((hashtextextended($1::text, 0) % $2) + $2) % $2)::int4"+            ( contrazip2+                (E.param (E.nonNullable E.int8))+                (E.param (E.nonNullable E.int4))+            )+            (D.singleRow (D.column (D.nonNullable D.int4)))++-- | All distinct (originalStreamId) values present in the unpartitioned read.+distinctStreamIds :: Vector RecordedEvent -> [Int64]+distinctStreamIds = Set.toList . Set.fromList . map fst . streamPositions++spec :: Spec+spec = do+    describe "ConsumerGroupSql" $ do+        categorySpec+        checkpointSpec+        allSpec+        memberOfSpec++-- ---------------------------------------------------------------------------+-- M1: category partitioning+-- ---------------------------------------------------------------------------++categorySpec :: Spec+categorySpec = around withTestStore $ do+    describe "category consumer-group partitioning (size 4)" $ do+        let cat = "acct"+            names = map (\i -> "acct-" <> T.pack (show i)) [1 .. 50 :: Int]+            size = 4 :: Int32++        let readMember store m =+                runStmt store $+                    Session.statement (0 :: Int64, cat, m, size, bigLimit) SQL.readCategoryForwardConsumerGroupStmt+            readFull store =+                runStmt store $+                    Session.statement (0 :: Int64, cat, bigLimit) SQL.readCategoryForwardStmt++        it "splits a category into 4 pairwise-disjoint member slices" $ \store -> do+            seedStreams store names 2+            slices <- mapM (readMember store) [0 .. size - 1]+            let idSets = map (Set.fromList . eventIds) slices+            -- pairwise disjoint: union of sizes equals size of union+            let totalIds = sum (map Set.size idSets)+                unionIds = Set.size (Set.unions idSets)+            totalIds `shouldBe` unionIds++        it "union of all member slices equals the unpartitioned category read" $ \store -> do+            seedStreams store names 2+            slices <- mapM (readMember store) [0 .. size - 1]+            full <- readFull store+            let unionIds = Set.unions (map (Set.fromList . eventIds) slices)+                fullIds = Set.fromList (eventIds full)+            unionIds `shouldBe` fullIds++        it "every stream's events go to exactly one member, in ascending global position" $ \store -> do+            seedStreams store names 3+            slices <- mapM (readMember store) [0 .. size - 1]+            -- For each member slice, every stream present must have all its events+            -- in ascending global position, and no stream may appear in two slices.+            let perMemberStreams = map (Set.fromList . map fst . streamPositions) slices+            -- per-stream affinity: stream sets are pairwise disjoint+            let totalStreams = sum (map Set.size perMemberStreams)+                unionStreams = Set.size (Set.unions perMemberStreams)+            totalStreams `shouldBe` unionStreams+            -- ascending global position within each slice+            mapM_+                ( \slice -> do+                    let ps = map snd (streamPositions slice)+                    ps `shouldBe` sort ps+                )+                slices++        it "member assignment is deterministic across repeated reads" $ \store -> do+            seedStreams store names 1+            firstReads <- mapM (\m -> eventIds <$> readMember store m) [0 .. size - 1]+            secondReads <- mapM (\m -> eventIds <$> readMember store m) [0 .. size - 1]+            firstReads `shouldBe` secondReads++        it "size 1 is equivalent to an unpartitioned category read" $ \store -> do+            seedStreams store names 2+            one <-+                runStmt store $+                    Session.statement (0 :: Int64, cat, 0 :: Int32, 1 :: Int32, bigLimit) SQL.readCategoryForwardConsumerGroupStmt+            full <- readFull store+            eventIds one `shouldBe` eventIds full++-- ---------------------------------------------------------------------------+-- M2: per-member checkpoints+-- ---------------------------------------------------------------------------++checkpointSpec :: Spec+checkpointSpec = around withTestStore $ do+    describe "per-member checkpoints" $ do+        let subName = "proj-acct" :: Text++        it "stores and reads independent checkpoints per member" $ \store -> do+            runStmt store $ Session.statement (subName, 0 :: Int32, 7 :: Int64) SQL.saveCheckpointMemberStmt+            runStmt store $ Session.statement (subName, 1 :: Int32, 13 :: Int64) SQL.saveCheckpointMemberStmt+            m0 <- runStmt store $ Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt+            m1 <- runStmt store $ Session.statement (subName, 1 :: Int32) SQL.getCheckpointMemberStmt+            m0 `shouldBe` Just 7+            m1 `shouldBe` Just 13++        it "never moves a member checkpoint backward (GREATEST monotonicity)" $ \store -> do+            runStmt store $ Session.statement (subName, 0 :: Int32, 20 :: Int64) SQL.saveCheckpointMemberStmt+            runStmt store $ Session.statement (subName, 0 :: Int32, 5 :: Int64) SQL.saveCheckpointMemberStmt+            m0 <- runStmt store $ Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt+            m0 `shouldBe` Just 20++        it "missing member checkpoint reads as Nothing" $ \store -> do+            m9 <- runStmt store $ Session.statement (subName, 9 :: Int32) SQL.getCheckpointMemberStmt+            m9 `shouldBe` Nothing++        it "the existing name-keyed checkpoint statements still round-trip (as member 0)" $ \store -> do+            runStmt store $ Session.statement (subName, 42 :: Int64) SQL.saveCheckpointStmt+            -- name-keyed read returns the same row (member 0)+            byName <- runStmt store $ Session.statement subName SQL.getCheckpointStmt+            byMember0 <- runStmt store $ Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt+            byName `shouldBe` Just 42+            byMember0 `shouldBe` Just 42++-- ---------------------------------------------------------------------------+-- M3: $all partitioning+-- ---------------------------------------------------------------------------++allSpec :: Spec+allSpec = around withTestStore $ do+    describe "$all consumer-group partitioning (size 4)" $ do+        -- \$all spans several categories; partitioning is by originating stream.+        let names =+                concatMap+                    (\c -> map (\i -> c <> "-" <> T.pack (show i)) [1 .. 20 :: Int])+                    ["acct", "user", "order"]+            size = 4 :: Int32++        let readMember store m =+                runStmt store $+                    Session.statement (0 :: Int64, m, size, bigLimit) SQL.readAllForwardConsumerGroupStmt+            readFull store =+                runStmt store $+                    Session.statement (0 :: Int64, bigLimit) SQL.readAllForwardStmt++        it "splits $all into 4 pairwise-disjoint member slices" $ \store -> do+            seedStreams store names 2+            slices <- mapM (readMember store) [0 .. size - 1]+            let idSets = map (Set.fromList . eventIds) slices+                totalIds = sum (map Set.size idSets)+                unionIds = Set.size (Set.unions idSets)+            totalIds `shouldBe` unionIds++        it "union of all member slices equals the unpartitioned $all read" $ \store -> do+            seedStreams store names 2+            slices <- mapM (readMember store) [0 .. size - 1]+            full <- readFull store+            let unionIds = Set.unions (map (Set.fromList . eventIds) slices)+                fullIds = Set.fromList (eventIds full)+            unionIds `shouldBe` fullIds++        it "every stream's events go to exactly one member, in ascending global position" $ \store -> do+            seedStreams store names 3+            slices <- mapM (readMember store) [0 .. size - 1]+            let perMemberStreams = map (Set.fromList . map fst . streamPositions) slices+                totalStreams = sum (map Set.size perMemberStreams)+                unionStreams = Set.size (Set.unions perMemberStreams)+            totalStreams `shouldBe` unionStreams+            mapM_+                ( \slice -> do+                    let ps = map snd (streamPositions slice)+                    ps `shouldBe` sort ps+                )+                slices++        it "size 1 is equivalent to an unpartitioned $all read" $ \store -> do+            seedStreams store names 2+            one <-+                runStmt store $+                    Session.statement (0 :: Int64, 0 :: Int32, 1 :: Int32, bigLimit) SQL.readAllForwardConsumerGroupStmt+            full <- readFull store+            eventIds one `shouldBe` eventIds full++-- ---------------------------------------------------------------------------+-- The partition rule, pinned directly.+-- ---------------------------------------------------------------------------++memberOfSpec :: Spec+memberOfSpec = around withTestStore $ do+    describe "member_of assignment rule" $ do+        it "returns a member index in [0, size) for every stream" $ \store -> do+            let names = map (\i -> "rule-" <> T.pack (show i)) [1 .. 30 :: Int]+            seedStreams store names 1+            full <- runStmt store $ Session.statement (0 :: Int64, bigLimit) SQL.readAllForwardStmt+            let sids = distinctStreamIds full+            mapM_+                ( \sid -> do+                    m <- runMemberOf store sid 4+                    m `shouldSatisfy` (\x -> x >= 0 && x < 4)+                )+                sids
+ test/Test/EventTypeFilter.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Regression tests for EP-43 (MasterPlan 6, child plan 4) — per-subscription+event-type filtering in @kiroku-store@.++These pin the behavioral acceptance criteria from the ExecPlan:++  * __selective delivery__: a subscription with+    @'eventTypeFilter' = 'OnlyEventTypes' {A}@ over a mixed @A@\/@B@ stream+    delivers only the @A@ events to its handler;+  * __checkpoint advances past filtered events__: the persisted @last_seen@+    equals the global position of the /last event of any type/, including a+    trailing filtered-out event, so the subscription never re-scans skipped+    events after a restart;+  * __no stall__: a long run of non-matching events (1 @A@, 1000 @B@, 1 @A@)+    does not hang the subscription — both @A@s are delivered and the checkpoint+    reaches 1002;+  * __filter before dead-letter__: a handler that dead-letters /every/ event it+    sees, behind a filter that admits no events in the stream, is never invoked,+    writes no dead-letter rows, and still advances the checkpoint.++They also cover the opaque 'selector' escape hatch (a @RecordedEvent -> Bool@+predicate the type set cannot express, e.g. on payload\/metadata):++  * __selector no-stall__: a selector over a payload tag delivers only matching+    events and advances the checkpoint past a long run of rejected ones;+  * __AND composition__: 'selector' and 'eventTypeFilter' compose as a logical+    AND — an event is delivered only when it passes both.++All use an 'AllStreams' subscription (the FSM 'DeliverBatch' delivery path).+Events are appended and the publisher is awaited before subscribing, so delivery+happens during catch-up; the worker applies the filter in 'processEvents' before+the handler call.+-}+module Test.EventTypeFilter (spec) where++import Control.Concurrent (threadDelay)+import Control.Lens ((^.))+import Data.Aeson ((.=))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int32, Int64)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Vector qualified as V+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Kiroku.Store+import Kiroku.Store.SQL qualified as SQL+import Test.Helpers (makeEvent, waitForPublisher, withTestStore)+import Test.Hspec++typeOf :: RecordedEvent -> Text+typeOf ev = case ev ^. #eventType of EventType t -> t++readCheckpoint :: KirokuStore -> Text -> IO (Maybe Int64)+readCheckpoint store subName = do+    result <- Pool.use (store ^. #pool) (Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt)+    case result of+        Left err -> error ("readCheckpoint failed: " <> show err)+        Right mPos -> pure mPos++readDeadLetters :: KirokuStore -> Text -> IO [SQL.DeadLetterRecord]+readDeadLetters store subName = do+    result <- Pool.use (store ^. #pool) (Session.statement (subName, 0 :: Int32) SQL.readDeadLettersStmt)+    case result of+        Left err -> error ("readDeadLetters failed: " <> show err)+        Right v -> pure (V.toList v)++-- Poll the checkpoint until it reaches @target@ (or ~10s elapse). Because the+-- worker saves the checkpoint at the batch tail only after every handler call in+-- the batch, a checkpoint at @target@ means all deliveries up to @target@ are+-- done, so the collected delivery list is stable once this returns 'True'.+waitForCheckpoint :: KirokuStore -> Text -> Int64 -> IO Bool+waitForCheckpoint store subName target = go (0 :: Int)+  where+    go n+        | n > 200 = pure False+        | otherwise = do+            mPos <- readCheckpoint store subName+            case mPos of+                Just p | p >= target -> pure True+                _ -> threadDelay 50_000 >> go (n + 1)++mkE :: Text -> EventData+mkE typ = makeEvent typ (Aeson.object [])++-- An event tagged @{ "keep": True\/False }@ in its payload — a property the+-- 'eventTypeFilter' type set cannot express, used to exercise the opaque+-- 'selector' escape hatch.+mkTagged :: Text -> Bool -> EventData+mkTagged typ keep = makeEvent typ (Aeson.object ["keep" .= keep])++-- The opaque selector: deliver only events whose payload says @keep = True@.+keepOnly :: RecordedEvent -> Bool+keepOnly ev = (ev ^. #payload) == Aeson.object ["keep" .= True]++posOf :: RecordedEvent -> Int64+posOf ev = case ev ^. #globalPosition of GlobalPosition p -> p++spec :: Spec+spec = describe "event-type filter" $ do+    it "delivers only matching types and advances the checkpoint past filtered events" $ do+        withTestStore $ \store -> do+            let subT = "etf-mixed" :: Text+                subName = SubscriptionName subT+            -- A, B, A, B, A on one stream -> global positions 1..5.+            Right _ <-+                runStoreIO store $+                    appendToStream+                        (StreamName "etf-mixed-stream")+                        NoStream+                        [mkE "A", mkE "B", mkE "A", mkE "B", mkE "A"]+            waitForPublisher store (GlobalPosition 5)++            deliveredRef <- newIORef ([] :: [Text])+            let handler' ev = do+                    modifyIORef' deliveredRef (<> [typeOf ev])+                    pure Continue+                cfg =+                    (defaultSubscriptionConfig subName AllStreams handler')+                        { eventTypeFilter = OnlyEventTypes (Set.fromList [EventType "A"])+                        }+            handle <- subscribe store cfg+            reached <- waitForCheckpoint store subT 5+            cancel handle++            reached `shouldBe` True+            delivered <- readIORef deliveredRef+            delivered `shouldBe` ["A", "A", "A"]+            readCheckpoint store subT `shouldReturn` Just 5++    it "advances the checkpoint past a trailing filtered-out event" $ do+        withTestStore $ \store -> do+            let subT = "etf-trailing" :: Text+                subName = SubscriptionName subT+            -- A then B: the last event (B at position 2) is filtered out.+            Right _ <-+                runStoreIO store $+                    appendToStream+                        (StreamName "etf-trailing-stream")+                        NoStream+                        [mkE "A", mkE "B"]+            waitForPublisher store (GlobalPosition 2)++            deliveredRef <- newIORef ([] :: [Text])+            let handler' ev = do+                    modifyIORef' deliveredRef (<> [typeOf ev])+                    pure Continue+                cfg =+                    (defaultSubscriptionConfig subName AllStreams handler')+                        { eventTypeFilter = OnlyEventTypes (Set.fromList [EventType "A"])+                        }+            handle <- subscribe store cfg+            reached <- waitForCheckpoint store subT 2+            cancel handle++            reached `shouldBe` True+            delivered <- readIORef deliveredRef+            delivered `shouldBe` ["A"]+            -- last_seen is 2 (the trailing B), proving the cursor advanced past+            -- a filtered-out event rather than stopping at the last delivered A.+            readCheckpoint store subT `shouldReturn` Just 2++    it "never stalls on a long run of non-matching events (1 A, 1000 B, 1 A)" $ do+        withTestStore $ \store -> do+            let subT = "etf-nostall" :: Text+                subName = SubscriptionName subT+                events = [mkE "A"] <> replicate 1000 (mkE "B") <> [mkE "A"]+            Right _ <-+                runStoreIO store $+                    appendToStream (StreamName "etf-nostall-stream") NoStream events+            waitForPublisher store (GlobalPosition 1002)++            deliveredRef <- newIORef ([] :: [Text])+            let handler' ev = do+                    modifyIORef' deliveredRef (<> [typeOf ev])+                    pure Continue+                cfg =+                    (defaultSubscriptionConfig subName AllStreams handler')+                        { eventTypeFilter = OnlyEventTypes (Set.fromList [EventType "A"])+                        , batchSize = 2000+                        }+            handle <- subscribe store cfg+            reached <- waitForCheckpoint store subT 1002+            cancel handle++            reached `shouldBe` True+            delivered <- readIORef deliveredRef+            -- Exactly the two As; the 1000 Bs advanced the cursor without delivery.+            delivered `shouldBe` ["A", "A"]+            readCheckpoint store subT `shouldReturn` Just 1002++    it "does not dead-letter a filtered-out type even when the handler would" $ do+        withTestStore $ \store -> do+            let subT = "etf-no-dl" :: Text+                subName = SubscriptionName subT+            -- Only Bs; the filter admits only A, so the handler never runs.+            Right _ <-+                runStoreIO store $+                    appendToStream+                        (StreamName "etf-no-dl-stream")+                        NoStream+                        [mkE "B", mkE "B", mkE "B", mkE "B", mkE "B"]+            waitForPublisher store (GlobalPosition 5)++            deliveredRef <- newIORef ([] :: [Text])+            let handler' ev = do+                    -- The handler would dead-letter everything it sees — but a+                    -- filtered-out event must never reach it.+                    modifyIORef' deliveredRef (<> [typeOf ev])+                    pure (DeadLetter (DeadLetterPoison "should-never-fire"))+                cfg =+                    (defaultSubscriptionConfig subName AllStreams handler')+                        { eventTypeFilter = OnlyEventTypes (Set.fromList [EventType "A"])+                        }+            handle <- subscribe store cfg+            reached <- waitForCheckpoint store subT 5+            cancel handle++            reached `shouldBe` True+            delivered <- readIORef deliveredRef+            delivered `shouldBe` []+            -- No dead-letter rows were written for the filtered-out Bs, and the+            -- checkpoint still advanced past them.+            dls <- readDeadLetters store subT+            length dls `shouldBe` 0+            readCheckpoint store subT `shouldReturn` Just 5++    -- The opaque 'selector' escape hatch: a predicate over the whole+    -- 'RecordedEvent' (here, its payload) that the 'eventTypeFilter' type set+    -- cannot express. Same no-stall / checkpoint-advances guarantees apply.+    it "delivers only events matching an opaque selector and advances past the rest (no stall)" $ do+        withTestStore $ \store -> do+            let subT = "sel-nostall" :: Text+                subName = SubscriptionName subT+                -- All one type "A" (so eventTypeFilter cannot distinguish them);+                -- only the payload tag differs. keep, 1000 skips, keep.+                events =+                    [mkTagged "A" True]+                        <> replicate 1000 (mkTagged "A" False)+                        <> [mkTagged "A" True]+            Right _ <-+                runStoreIO store $+                    appendToStream (StreamName "sel-nostall-stream") NoStream events+            waitForPublisher store (GlobalPosition 1002)++            deliveredRef <- newIORef ([] :: [Int64])+            let handler' ev = do+                    modifyIORef' deliveredRef (<> [posOf ev])+                    pure Continue+                cfg =+                    (defaultSubscriptionConfig subName AllStreams handler')+                        { selector = Just keepOnly+                        , batchSize = 2000+                        }+            handle <- subscribe store cfg+            reached <- waitForCheckpoint store subT 1002+            cancel handle++            reached `shouldBe` True+            delivered <- readIORef deliveredRef+            -- Only the two keep events (positions 1 and 1002); the 1000 skips+            -- advanced the cursor without delivery.+            delivered `shouldBe` [1, 1002]+            readCheckpoint store subT `shouldReturn` Just 1002++    it "composes the selector with eventTypeFilter as a logical AND" $ do+        withTestStore $ \store -> do+            let subT = "sel-and-type" :: Text+                subName = SubscriptionName subT+                -- A/keep, A/skip, B/keep, B/skip, A/keep -> positions 1..5.+                -- Only events that are type A AND keep survive: positions 1, 5.+                events =+                    [ mkTagged "A" True+                    , mkTagged "A" False+                    , mkTagged "B" True+                    , mkTagged "B" False+                    , mkTagged "A" True+                    ]+            Right _ <-+                runStoreIO store $+                    appendToStream (StreamName "sel-and-type-stream") NoStream events+            waitForPublisher store (GlobalPosition 5)++            deliveredRef <- newIORef ([] :: [Int64])+            let handler' ev = do+                    modifyIORef' deliveredRef (<> [posOf ev])+                    pure Continue+                cfg =+                    (defaultSubscriptionConfig subName AllStreams handler')+                        { eventTypeFilter = OnlyEventTypes (Set.fromList [EventType "A"])+                        , selector = Just keepOnly+                        }+            handle <- subscribe store cfg+            reached <- waitForCheckpoint store subT 5+            cancel handle++            reached `shouldBe` True+            delivered <- readIORef deliveredRef+            -- B/keep (pos 3) is rejected by the type filter; A/skip (pos 2) by the+            -- selector. Only A-and-keep at 1 and 5 are delivered.+            delivered `shouldBe` [1, 5]+            readCheckpoint store subT `shouldReturn` Just 5
+ test/Test/FailureInjection.hs view
@@ -0,0 +1,112 @@+{- | Failure-injection tests for kiroku-store.++Each test deliberately disrupts a runtime dependency (the LISTEN+connection, the connection pool) and asserts the system recovers per its+documented contract.++Currently covers:++  * F14: Listener killed during a window where an event is appended.+    The event is still delivered after the listener reconnects, because+    the publisher re-queries the database from its last position when+    the next NOTIFY arrives — no safety-poll wait needed.++F15 (pool exhaustion → 'PoolAcquisitionTimeout') is deferred until the+'acquisitionTimeout' field is exposed in 'ConnectionSettings'. The+mapping itself ('Kiroku.Store.Error.mapUsageError'+@AcquisitionTimeoutUsageError -> PoolAcquisitionTimeout@) is+straightforward; without a way to set a sub-second acquisition timeout+from the test, the test would either hang (default unbounded timeout)+or require modifying the production type. See the EP-6 plan's M2 notes.+-}+module Test.FailureInjection (spec) where++import Control.Concurrent.STM (atomically, newTVarIO, readTVar, retry, writeTVar)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Kiroku.Store+import Test.Helpers (+    makeEvent,+    terminateBackend,+    waitForListenerPid,+    waitForListenerPidNotEqual,+    waitWithTimeout,+    withTestStoreSettings,+ )+import Test.Hspec++spec :: Spec+spec = describe "kiroku-store failure injection" $ do+    -- F14 — Listener killed during a window where an event is+    -- appended. The publisher's broadcast loop pulls events directly+    -- from PostgreSQL when the next NOTIFY arrives, so the+    -- down-window event is delivered as soon as a post-reconnect+    -- event triggers a tick. No 30-second safety-poll wait required.+    it "delivers events appended during listener-down window after reconnect (F14)" $ \() -> do+        ref <- newIORef ([] :: [RecordedEvent])+        countVar <- newTVarIO (0 :: Int)+        let handler' evt = do+                modifyIORef' ref (evt :)+                n <- atomically $ do+                    c <- readTVar countVar+                    let c' = c + 1+                    writeTVar countVar c'+                    pure c'+                if n >= 3 then pure Stop else pure Continue+        let cfg =+                SubscriptionConfig+                    { name = SubscriptionName "f14-down-window"+                    , target = AllStreams+                    , handler = handler'+                    , batchSize = 100+                    , queueCapacity = 16+                    , overflowPolicy = DropSubscription+                    , consumerGroup = Nothing+                    , consumerGroupGuard = False+                    , retryPolicy = defaultRetryPolicy+                    , eventTypeFilter = AllEventTypes+                    , selector = Nothing+                    }+        withTestStoreSettings (& #eventHandler .~ Nothing) $ \store -> do+            handle <- subscribe store cfg+            -- Pre-event: confirm the subscription is alive and the+            -- listener has reached pg_stat_activity.+            Right _ <- runStoreIO store $ appendToStream (StreamName "f14-pre") NoStream [makeEvent "Pre" (Aeson.object [])]+            atomically $ do+                c <- readTVar countVar+                if c >= 1 then pure () else retry+            -- Find listener pid, terminate it. The listener loop+            -- will reconnect with a fresh pid.+            --+            -- NOTE: pg_terminate_backend is the "administrator command"+            -- that makes PostgreSQL report+            --   FATAL: terminating connection due to administrator command+            -- on the targeted backend. The kiroku-listener's libpq socket+            -- (inside hasql-notifications' waitForNotifications) receives+            -- that as it dies, so that FATAL line on stderr during this+            -- test is EXPECTED — it is the fault we are injecting, not a+            -- connection leak or a teardown-ordering bug. (log_min_messages+            -- is already PANIC, so this is the client seeing a server-+            -- initiated termination, not server-side logging.)+            pid1 <- waitForListenerPid (store ^. #pool) 5_000_000+            terminateBackend (store ^. #pool) pid1+            -- Append the during-down-window event. No NOTIFY reaches+            -- the publisher right now because the listener is+            -- disconnected.+            Right _ <- runStoreIO store $ appendToStream (StreamName "f14-during") NoStream [makeEvent "During" (Aeson.object [])]+            -- Wait for the listener to come back with a fresh pid.+            _ <- waitForListenerPidNotEqual (store ^. #pool) pid1 15_000_000+            -- Append the post-reconnect event. The new NOTIFY+            -- triggers the publisher to fetch from its last position+            -- — which picks up both the during-down event AND this+            -- one.+            Right _ <- runStoreIO store $ appendToStream (StreamName "f14-after") NoStream [makeEvent "After" (Aeson.object [])]+            result <- waitWithTimeout 30_000_000 handle+            case result of+                Left timeout -> expectationFailure timeout+                Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                Right (Right ()) -> pure ()+            collected <- readIORef ref+            length collected `shouldBe` 3
+ test/Test/Helpers.hs view
@@ -0,0 +1,301 @@+{- | Shared fixtures and synchronization helpers for the kiroku-store+test suite.++Three groups of helpers live here:++  * Database fixture: 'withTestStore' brackets an ephemeral PostgreSQL+    instance and a 'KirokuStore'.+  * Event/wait helpers: 'makeEvent', 'waitWithTimeout', plus the+    listener-pid and TRUNCATE-rejection utilities used by the+    Notifier/Lifecycle regression tests.+  * Deterministic synchronization: 'waitForPublisher' and+    'waitForSubscriptionLive' replace 'threadDelay'-based sleeps in+    subscription tests with STM- and event-handler-driven barriers+    (per EP-6 F12/F14 and the threadDelay inventory in+    @docs\/plans\/6-test-and-benchmark-hardening-for-production-confidence.md@).+-}+module Test.Helpers (+    -- * Database fixture+    withSharedMigratedPostgres,+    withTestStore,+    withTestStoreSettings,++    -- * Event construction+    makeEvent,++    -- * Subscription wait+    waitWithTimeout,++    -- * Raw SQL helpers+    countEvents,+    insertEventUsingDefaultId,+    serverVersionNum,+    truncateRejected,+    tableExists,++    -- * Listener-pid helpers+    findListenerPid,+    waitForListenerPid,+    waitForListenerPidNotEqual,+    terminateBackend,+    listenerCount,++    -- * Deterministic synchronization+    waitForPublisher,+    waitForSubscriptionLive,+    caughtUpEventHandler,+) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.MVar (MVar, takeMVar, tryPutMVar)+import Control.Concurrent.STM (atomically, check)+import Control.Exception (SomeException)+import Control.Lens ((^.))+import Data.Aeson (Value)+import Data.Generics.Labels ()+import Data.Int (Int32, Int64)+import Data.Text (Text)+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Conn+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable, unpreparable)+import Kiroku.Store+import Kiroku.Store.Subscription.EventPublisher (publisherPosition)+import Kiroku.Test.Postgres (withMigratedTestDatabase, withSharedMigratedPostgres)++{- | Bracket that creates an ephemeral PostgreSQL database, applies the+Kiroku migrations, and provides a 'KirokuStore' handle.+-}+withTestStore :: (KirokuStore -> IO ()) -> IO ()+withTestStore = withTestStoreSettings Prelude.id++{- | Variant of 'withTestStore' that lets the caller transform the+'ConnectionSettings' before the store is opened. Used by tests that+install an 'eventHandler' or other observation hook.+-}+withTestStoreSettings :: (ConnectionSettings -> ConnectionSettings) -> (KirokuStore -> IO ()) -> IO ()+withTestStoreSettings tweak action =+    withMigratedTestDatabase $ \connStr ->+        withStore (tweak (defaultConnectionSettings connStr)) action++-- | Create a simple 'EventData' with an auto-generated id.+makeEvent :: Text -> Value -> EventData+makeEvent typ payload =+    EventData+        { eventId = Nothing+        , eventType = EventType typ+        , payload = payload+        , metadata = Nothing+        , causationId = Nothing+        , correlationId = Nothing+        }++{- | Wait for a subscription with a timeout (in microseconds).+Returns 'Left' on timeout, or the subscription result.+-}+waitWithTimeout :: Int -> SubscriptionHandle -> IO (Either String (Either SomeException ()))+waitWithTimeout micros handle = do+    result <- Async.race (threadDelay micros) (wait handle)+    case result of+        Left () -> do+            cancel handle+            pure (Left "Subscription timed out")+        Right r -> pure (Right r)++{- | Count rows in the @events@ table via raw SQL. Used by hard-delete+regression tests that need to assert event payloads are actually removed+(not just unlinked).+-}+countEvents :: KirokuStore -> IO Int64+countEvents store = do+    let stmt :: Statement () Int64+        stmt =+            preparable+                "SELECT COUNT(*) FROM events"+                E.noParams+                (D.singleRow (D.column (D.nonNullable D.int8)))+    result <- Pool.use (store ^. #pool) (Session.statement () stmt)+    case result of+        Left err -> error ("countEvents failed: " <> show err)+        Right n -> pure n++{- | Insert directly into @events@ without an @event_id@ so the database+default is responsible for UUID generation. Returns the generated UUID+text; used to prove the schema-level @uuidv7()@ fallback works.+-}+insertEventUsingDefaultId :: KirokuStore -> IO Text+insertEventUsingDefaultId store = do+    let stmt :: Statement () Text+        stmt =+            preparable+                "INSERT INTO events (event_type, data) VALUES ('DefaultUuidGenerated', '{}'::jsonb) RETURNING event_id::text"+                E.noParams+                (D.singleRow (D.column (D.nonNullable D.text)))+    result <- Pool.use (store ^. #pool) (Session.statement () stmt)+    case result of+        Left err -> error ("insertEventUsingDefaultId failed: " <> show err)+        Right eventIdText -> pure eventIdText++{- | Report whether a schema-qualified relation exists, via+@to_regclass(name) IS NOT NULL@. The name is schema-qualified+(e.g. @"kiroku.streams"@ or @"public.streams"@), so the result does not+depend on the connection's @search_path@. Used by the schema-placement+tests that prove Kiroku objects install under @kiroku@ and not @public@.+-}+tableExists :: KirokuStore -> Text -> IO Bool+tableExists store qualifiedName = do+    let stmt :: Statement Text Bool+        stmt =+            preparable+                "SELECT to_regclass($1) IS NOT NULL"+                (E.param (E.nonNullable E.text))+                (D.singleRow (D.column (D.nonNullable D.bool)))+    result <- Pool.use (store ^. #pool) (Session.statement qualifiedName stmt)+    case result of+        Left err -> error ("tableExists failed: " <> show err)+        Right exists -> pure exists++-- | Return PostgreSQL's numeric server version for failure messages.+serverVersionNum :: KirokuStore -> IO Text+serverVersionNum store = do+    let stmt :: Statement () Text+        stmt =+            preparable+                "SELECT current_setting('server_version_num')"+                E.noParams+                (D.singleRow (D.column (D.nonNullable D.text)))+    result <- Pool.use (store ^. #pool) (Session.statement () stmt)+    case result of+        Left err -> error ("serverVersionNum failed: " <> show err)+        Right version -> pure version++{- | Try to TRUNCATE the named table without the GUC; returns 'True' if the+operation was rejected by the @protect_truncation@ trigger (the expected+behavior after EP-1 F6) and 'False' if it succeeded.+-}+truncateRejected :: KirokuStore -> Text -> IO Bool+truncateRejected store tableName = do+    let stmt :: Statement () ()+        stmt = unpreparable ("TRUNCATE " <> tableName) E.noParams D.noResult+    result <- Pool.use (store ^. #pool) (Session.statement () stmt)+    case result of+        Left _ -> pure True+        Right () -> pure False++-- | Look up the pid of the kiroku-listener backend in @pg_stat_activity@.+findListenerPid :: Pool.Pool -> IO (Maybe Int32)+findListenerPid pool = do+    let stmt :: Statement () (Maybe Int32)+        stmt =+            preparable+                "SELECT pid::int4 FROM pg_stat_activity WHERE application_name = 'kiroku-listener' LIMIT 1"+                E.noParams+                (D.rowMaybe (D.column (D.nonNullable D.int4)))+    result <- Pool.use pool (Session.statement () stmt)+    case result of+        Left err -> error ("findListenerPid failed: " <> show err)+        Right mPid -> pure mPid++-- | Wait until the listener appears in @pg_stat_activity@, or fail after the budget.+waitForListenerPid :: Pool.Pool -> Int -> IO Int32+waitForListenerPid pool budgetMicros+    | budgetMicros <= 0 = error "waitForListenerPid: timeout — kiroku-listener never appeared in pg_stat_activity"+    | otherwise = do+        m <- findListenerPid pool+        case m of+            Just pid -> pure pid+            Nothing -> do+                threadDelay 50_000+                waitForListenerPid pool (budgetMicros - 50_000)++-- | Wait until the listener pid in @pg_stat_activity@ differs from the supplied pid.+waitForListenerPidNotEqual :: Pool.Pool -> Int32 -> Int -> IO Int32+waitForListenerPidNotEqual pool oldPid budgetMicros+    | budgetMicros <= 0 = error "waitForListenerPidNotEqual: timeout — listener did not reconnect"+    | otherwise = do+        m <- findListenerPid pool+        case m of+            Just pid | pid /= oldPid -> pure pid+            _ -> do+                threadDelay 50_000+                waitForListenerPidNotEqual pool oldPid (budgetMicros - 50_000)++-- | Terminate the named backend pid via @pg_terminate_backend@.+terminateBackend :: Pool.Pool -> Int32 -> IO ()+terminateBackend pool pid = do+    let stmt :: Statement Int32 Bool+        stmt =+            preparable+                "SELECT pg_terminate_backend($1::int4)"+                (E.param (E.nonNullable E.int4))+                (D.singleRow (D.column (D.nonNullable D.bool)))+    result <- Pool.use pool (Session.statement pid stmt)+    case result of+        Left err -> error ("terminateBackend failed: " <> show err)+        Right _ -> pure ()++{- | Count kiroku-listener connections via a fresh connection (used after+the store has shut down, when the application pool is no longer+available).+-}+listenerCount :: Text -> IO Int64+listenerCount connStr = do+    eConn <- Connection.acquire (Conn.connectionString connStr)+    case eConn of+        Left err -> error ("listenerCount: failed to acquire verification conn: " <> show err)+        Right conn -> do+            let stmt :: Statement () Int64+                stmt =+                    preparable+                        "SELECT COUNT(*) FROM pg_stat_activity WHERE application_name = 'kiroku-listener'"+                        E.noParams+                        (D.singleRow (D.column (D.nonNullable D.int8)))+            r <- Connection.use conn (Session.statement () stmt)+            Connection.release conn+            case r of+                Left err -> error ("listenerCount: query failed: " <> show err)+                Right n -> pure n++{- | Block until the EventPublisher has ingested events at or beyond the+given 'GlobalPosition'. Replaces @threadDelay 200_000@ heuristics in+subscription catch-up tests with a deterministic STM barrier.+-}+waitForPublisher :: KirokuStore -> GlobalPosition -> IO ()+waitForPublisher store (GlobalPosition target) =+    atomically $ do+        GlobalPosition p <- publisherPosition (store ^. #publisher)+        check (p >= target)++{- | Block until the named subscription emits+'KirokuEventSubscriptionCaughtUp'. The caller passes an 'MVar' that is+wired into the test store's @eventHandler@ via 'caughtUpEventHandler'.+Replaces @threadDelay 100_000@ "wait for subscription to enter live+mode" in subscription tests.+-}+waitForSubscriptionLive :: MVar () -> IO ()+waitForSubscriptionLive = takeMVar++{- | Build an 'eventHandler' that opens the supplied 'MVar' the first+time 'KirokuEventSubscriptionCaughtUp' fires for the named subscription.+Subsequent emissions and other event types are ignored by the barrier+('tryPutMVar' guarantees idempotence). Composes with a passthrough+caller for tests that need to inspect the full event stream.+-}+caughtUpEventHandler ::+    SubscriptionName ->+    MVar () ->+    Maybe (KirokuEvent -> IO ()) ->+    KirokuEvent ->+    IO ()+caughtUpEventHandler name barrier passthrough evt = do+    case evt of+        KirokuEventSubscriptionCaughtUp n _ _+            | n == name -> () <$ tryPutMVar barrier ()+        _ -> pure ()+    case passthrough of+        Nothing -> pure ()+        Just f -> f evt
+ test/Test/InterpreterHooks.hs view
@@ -0,0 +1,178 @@+{- | Tests for the interpreter-level event-data hooks installed via+'Kiroku.Store.Settings.StoreSettings'.++Three concerns are covered (added across the plan's milestones):++  * @enrichEvent@ fires on the append path before encoding, so an+    appended event surfaces with the hook's mutation visible.+  * @decodeHook@ fires on the read and subscription paths after+    decoding, so both 'readAllForward' and a live 'subscribe' handler+    see the hook's mutation.+  * With both hooks 'Nothing' (the default), a round-trip is+    byte-identical to the input — the no-op fast path introduces no+    'pure'-wrapping artefact.+-}+module Test.InterpreterHooks (spec) where++import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as Aeson+import Data.Foldable (for_)+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Vector qualified as V+import Kiroku.Store+import Test.Helpers (makeEvent, waitForPublisher, waitWithTimeout, withTestStore, withTestStoreSettings)+import Test.Hspec++spec :: Spec+spec = describe "InterpreterHooks" $ do+    describe "enrichEvent" appendHookFiresSpec+    describe "decodeHook" readHookFiresSpec+    describe "no hooks" noHookNoEffectSpec++-- ---------------------------------------------------------------------------+-- enrichEvent+-- ---------------------------------------------------------------------------++appendHookFiresSpec :: Spec+appendHookFiresSpec = do+    it "applies enrichEvent to appended events surfaced through readStreamForward" $ do+        let marker = Aeson.object [("hook", Aeson.String "applied")]+            inject ed = pure $ ed & #metadata .~ Just marker+            tweak cs =+                cs+                    & #storeSettings+                        .~ defaultStoreSettings{enrichEvent = Just inject}+        withTestStoreSettings tweak $ \store -> do+            Right _ <-+                runStoreIO store $+                    appendToStream+                        (StreamName "hook-append-1")+                        NoStream+                        [makeEvent "X" (Aeson.object [("seed", Aeson.Number 1)])]+            evs <-+                runStoreIO store $+                    readStreamForward (StreamName "hook-append-1") (StreamVersion 0) 10+            case evs of+                Right v+                    | V.length v == 1 ->+                        (V.head v ^. #metadata) `shouldBe` Just marker+                other -> expectationFailure ("unexpected read result: " <> show other)++    it "applies enrichEvent across appendMultiStream per-stream batches" $ do+        countRef <- newIORef (0 :: Int)+        let inject ed = do+                modifyIORef' countRef (+ 1)+                pure $ ed & #metadata .~ Just (Aeson.object [("multi", Aeson.Bool True)])+            tweak cs =+                cs+                    & #storeSettings+                        .~ defaultStoreSettings{enrichEvent = Just inject}+        withTestStoreSettings tweak $ \store -> do+            let ops =+                    [ (StreamName "hook-multi-A", NoStream, [makeEvent "A1" (Aeson.object []), makeEvent "A2" (Aeson.object [])])+                    , (StreamName "hook-multi-B", NoStream, [makeEvent "B1" (Aeson.object [])])+                    ]+            Right _ <- runStoreIO store $ appendMultiStream ops+            n <- readIORef countRef+            n `shouldBe` 3+            Right vA <- runStoreIO store $ readStreamForward (StreamName "hook-multi-A") (StreamVersion 0) 10+            Right vB <- runStoreIO store $ readStreamForward (StreamName "hook-multi-B") (StreamVersion 0) 10+            for_ (V.toList vA <> V.toList vB) $ \re ->+                (re ^. #metadata) `shouldBe` Just (Aeson.object [("multi", Aeson.Bool True)])++-- ---------------------------------------------------------------------------+-- decodeHook+-- ---------------------------------------------------------------------------++readHookFiresSpec :: Spec+readHookFiresSpec = do+    it "applies decodeHook to readAllForward results" $ do+        let marker = Aeson.object [("decoded", Aeson.String "yes")]+            inject re = pure $ re & #metadata .~ Just marker+            tweak cs =+                cs+                    & #storeSettings+                        .~ defaultStoreSettings{decodeHook = Just inject}+        withTestStoreSettings tweak $ \store -> do+            Right _ <-+                runStoreIO store $+                    appendToStream+                        (StreamName "hook-decode-1")+                        NoStream+                        [ makeEvent "E1" (Aeson.object [])+                        , makeEvent "E2" (Aeson.object [])+                        , makeEvent "E3" (Aeson.object [])+                        ]+            Right v <-+                runStoreIO store $+                    readAllForward (GlobalPosition 0) 10+            V.length v `shouldBe` 3+            for_ (V.toList v) $ \re ->+                (re ^. #metadata) `shouldBe` Just marker++    it "applies decodeHook to subscription handlers across catch-up and live phases" $ do+        let marker = Aeson.object [("sub", Aeson.String "tagged")]+            inject re = pure $ re & #metadata .~ Just marker+            subName = SubscriptionName "hook-sub-1"+            tweak cs =+                cs+                    & #storeSettings+                        .~ defaultStoreSettings{decodeHook = Just inject}+        withTestStoreSettings tweak $ \store -> do+            -- Pre-append one event so the worker's catch-up path runs+            -- before live mode kicks in.+            Right warm <-+                runStoreIO store $+                    appendToStream+                        (StreamName "hook-sub-stream-1")+                        NoStream+                        [makeEvent "warm" (Aeson.object [])]+            waitForPublisher store (warm ^. #globalPosition)++            seen <- newIORef ([] :: [Maybe Aeson.Value])+            done <- newEmptyMVar+            let handlerFn re = do+                    modifyIORef' seen ((re ^. #metadata) :)+                    n <- length <$> readIORef seen+                    if n >= 2+                        then Stop <$ tryPutMVar done ()+                        else pure Continue+                config = defaultSubscriptionConfig subName AllStreams handlerFn+            sub <- subscribe store config+            -- Append a second event to land in live mode.+            Right _ <-+                runStoreIO store $+                    appendToStream+                        (StreamName "hook-sub-stream-2")+                        NoStream+                        [makeEvent "live" (Aeson.object [])]+            takeMVar done+            res <- waitWithTimeout 2_000_000 sub+            case res of+                Right (Right ()) -> pure ()+                other -> expectationFailure ("subscription did not finish cleanly: " <> show other)+            metas <- reverse <$> readIORef seen+            metas `shouldBe` [Just marker, Just marker]++-- ---------------------------------------------------------------------------+-- no-op fast path+-- ---------------------------------------------------------------------------++noHookNoEffectSpec :: Spec+noHookNoEffectSpec = around withTestStore $+    it "with defaultStoreSettings, a round-trip preserves payload and metadata exactly" $ \store -> do+        let originalMeta = Just (Aeson.object [("k", Aeson.String "v")])+            originalPayload = Aeson.object [("x", Aeson.Number 42), ("y", Aeson.String "z")]+            event = makeEvent "Identity" originalPayload & #metadata .~ originalMeta+        Right _ <-+            runStoreIO store $+                appendToStream (StreamName "no-hook-roundtrip") NoStream [event]+        Right v <-+            runStoreIO store $+                readStreamForward (StreamName "no-hook-roundtrip") (StreamVersion 0) 10+        V.length v `shouldBe` 1+        let re = V.head v+        (re ^. #payload) `shouldBe` originalPayload+        (re ^. #metadata) `shouldBe` originalMeta
+ test/Test/Properties.hs view
@@ -0,0 +1,226 @@+{- | Property-based tests for invariants identified by EP-1 through EP-5.++Each property generates a random sequence of operations and asserts that+some invariant holds after the sequence executes. The properties target+the cross-cutting invariants enumerated in EP-6 M1's Invariant List+(F2–F8 of @docs\/plans\/6-test-and-benchmark-hardening-for-production-confidence.md@):++  * F2 — global position contiguity across appends, multi-stream appends,+    and links.+  * F3 — no orphan event payloads after lifecycle operations.+  * F4 — soft-delete write barrier under arbitrary append constructors.+  * F5 — caller-supplied event-id idempotence.++These properties run inside hspec via 'hspec-hedgehog'. Each property+acquires a fresh ephemeral PostgreSQL via 'withTestStore' inside the+hedgehog test action; the operation count per property is small (10-20+ops) to keep total runtime bounded.+-}+module Test.Properties (spec) where++import Control.Lens ((^.))+import Control.Monad (forM_, void)+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import Data.List (sort)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.UUID.V4 qualified as UUIDv4+import Data.Vector qualified as V+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Kiroku.Store+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec+import Test.Hspec.Hedgehog (PropertyT, hedgehog, modifyMaxSuccess)++-- | Operations the property generators can produce.+data Op+    = OpAppend !StreamName ![Text]+    | OpAppendMulti ![(StreamName, [Text])]+    | OpSoftDelete !StreamName+    | OpUndelete !StreamName+    | OpHardDelete !StreamName+    deriving stock (Show)++genStreamName :: Gen StreamName+genStreamName = do+    -- Bounded universe (5 streams) so generated sequences exercise reuse.+    n <- Gen.int (Range.linear 0 4)+    pure (StreamName ("prop-" <> T.pack (show n)))++genEventTypes :: Gen [Text]+genEventTypes = do+    n <- Gen.int (Range.linear 1 3)+    pure (map (\i -> "Type" <> T.pack (show i)) [1 .. n])++genOp :: Gen Op+genOp =+    Gen.frequency+        [ (60, OpAppend <$> genStreamName <*> genEventTypes)+        ,+            ( 10+            , OpAppendMulti+                <$> Gen.list+                    (Range.linear 2 3)+                    ((,) <$> genStreamName <*> genEventTypes)+            )+        , (10, OpSoftDelete <$> genStreamName)+        , (10, OpUndelete <$> genStreamName)+        , (10, OpHardDelete <$> genStreamName)+        ]++genOps :: Gen [Op]+genOps = Gen.list (Range.linear 1 12) genOp++{- | Run a generated operation, ignoring any 'StoreError' (the property+is about the system's invariants surviving any sequence of attempts,+including ones that fail).+-}+runOp :: KirokuStore -> Op -> IO ()+runOp store = \case+    OpAppend sn types -> do+        let evts = map (\t -> makeEvent t (Aeson.object [])) types+        void $ runStoreIO store $ appendToStream sn AnyVersion evts+    OpAppendMulti ops -> do+        let triples = map (\(sn, types) -> (sn, AnyVersion, map (\t -> makeEvent t (Aeson.object [])) types)) ops+        void $ runStoreIO store $ appendMultiStream triples+    OpSoftDelete sn -> void $ runStoreIO store $ softDeleteStream sn+    OpUndelete sn -> void $ runStoreIO store $ undeleteStream sn+    OpHardDelete sn -> void $ runStoreIO store $ hardDeleteStream sn++-- | Read the global position cursor by counting events on `$all`.+readAllCount :: KirokuStore -> IO Int+readAllCount store = do+    Right v <- runStoreIO store $ readAllForward (GlobalPosition 0) 100000+    pure (V.length v)++{- | Read all events on `$all` and return their global positions in+the order returned.+-}+readAllPositions :: KirokuStore -> IO [Int]+readAllPositions store = do+    Right v <- runStoreIO store $ readAllForward (GlobalPosition 0) 100000+    pure (V.toList (V.map (\e -> case e ^. #globalPosition of GlobalPosition n -> fromIntegral n) v))++{- | Each property creates a fresh ephemeral PostgreSQL per test case,+which dominates wall-clock time. Cap iterations at 15 per property —+enough to exercise generator coverage without blowing the suite past+two minutes.+-}+spec :: Spec+spec = modifyMaxSuccess (const 15) $ do+    describe "kiroku-store invariants (property-based, hedgehog)" $ do+        -- F2 — Global position contiguity. After any sequence of+        -- appends, multi-appends, soft/undelete/hard-delete operations,+        -- the global positions on $all (excluding hard-deleted events)+        -- form a strictly ascending sequence with no duplicates and no+        -- gaps relative to the events that actually exist on $all.+        it "$all global positions are strictly ascending and unique (F2)" $+            hedgehog $+                propAllPositionsAscending++        -- F4 — Soft-delete write barrier. After softDeleteStream, no+        -- subsequent appendToStream of any ExpectedVersion succeeds+        -- (until undeleteStream). Generates a random append, soft-deletes,+        -- attempts further appends with each ExpectedVersion constructor,+        -- asserts each one fails.+        it "soft-deleted streams reject appends of every ExpectedVersion (F4)" $+            hedgehog $+                propSoftDeleteBarrier++        -- F5 — Idempotent caller-supplied event ids. A batch of appends+        -- with all-unique event ids succeeds; a batch where any id is a+        -- repeat of a previously committed id fails with DuplicateEvent.+        it "duplicate caller-supplied event ids are rejected (F5)" $+            hedgehog $+                propDuplicateEventIds++propAllPositionsAscending :: PropertyT IO ()+propAllPositionsAscending = do+    ops <- forAll genOps+    positions <- evalIO $ withTestStoreReturn $ \store -> do+        forM_ ops (runOp store)+        readAllPositions store+    annotateShow positions+    -- Strictly ascending: each position greater than the previous.+    sort positions === positions+    -- Unique: no duplicates.+    length positions === length (Set.fromList positions)+    -- The count returned by $all matches the position list length.+    cnt <- evalIO $ withTestStoreReturn $ \store -> do+        forM_ ops (runOp store)+        readAllCount store+    cnt === length positions++propSoftDeleteBarrier :: PropertyT IO ()+propSoftDeleteBarrier = do+    streamSeed <- forAll (Gen.int (Range.linear 0 9))+    nEvents <- forAll (Gen.int (Range.linear 1 4))+    evalIO $ withTestStoreReturn $ \store -> do+        let sn = StreamName ("barrier-" <> T.pack (show streamSeed))+        let evts = map (\i -> makeEvent ("E" <> T.pack (show i)) (Aeson.object [])) [1 .. nEvents]+        Right _ <- runStoreIO store $ appendToStream sn NoStream evts+        Right _ <- runStoreIO store $ softDeleteStream sn+        -- Every subsequent append constructor must be rejected.+        rNo <- runStoreIO store $ appendToStream sn NoStream [makeEvent "X" (Aeson.object [])]+        case rNo of+            Left (StreamAlreadyExists _) -> pure ()+            other -> error ("F4 violated: NoStream against soft-deleted should be StreamAlreadyExists, got: " <> show other)+        rExact <- runStoreIO store $ appendToStream sn (ExactVersion (StreamVersion (fromIntegral nEvents))) [makeEvent "X" (Aeson.object [])]+        case rExact of+            Left (WrongExpectedVersion _ _ _) -> pure ()+            Left (StreamNotFound _) -> pure ()+            other -> error ("F4 violated: ExactVersion against soft-deleted should fail, got: " <> show other)+        rExists <- runStoreIO store $ appendToStream sn StreamExists [makeEvent "X" (Aeson.object [])]+        case rExists of+            Left (StreamNotFound _) -> pure ()+            other -> error ("F4 violated: StreamExists against soft-deleted should be StreamNotFound, got: " <> show other)+        rAny <- runStoreIO store $ appendToStream sn AnyVersion [makeEvent "X" (Aeson.object [])]+        case rAny of+            Left (StreamNotFound _) -> pure ()+            other -> error ("F4 violated: AnyVersion against soft-deleted should be StreamNotFound, got: " <> show other)++propDuplicateEventIds :: PropertyT IO ()+propDuplicateEventIds = do+    nFirst <- forAll (Gen.int (Range.linear 1 4))+    evalIO $ withTestStoreReturn $ \store -> do+        -- Generate a batch of unique caller-supplied event ids.+        ids <- mapM (const UUIDv4.nextRandom) [1 .. nFirst]+        let mkEvent uid =+                EventData+                    { eventId = Just (EventId uid)+                    , eventType = EventType "Dup"+                    , payload = Aeson.object []+                    , metadata = Nothing+                    , causationId = Nothing+                    , correlationId = Nothing+                    }+        let evts1 = map mkEvent ids+        r1 <- runStoreIO store $ appendToStream (StreamName "dup-prop-1") NoStream evts1+        case r1 of+            Right _ -> pure ()+            other -> error ("Initial append with unique ids should succeed: " <> show other)+        -- Re-issue any one of those ids in a fresh stream — must be rejected.+        let dupId = case ids of+                (i : _) -> i+                [] -> error "propDuplicateEventIds: nFirst >= 1 by Range, ids must be non-empty"+        let evts2 = [mkEvent dupId]+        r2 <- runStoreIO store $ appendToStream (StreamName "dup-prop-2") NoStream evts2+        case r2 of+            Left (DuplicateEvent _) -> pure ()+            other -> error ("F5 violated: duplicate event id should be rejected, got: " <> show other)++-- | Variant of 'withTestStore' that returns the action's result.+withTestStoreReturn :: (KirokuStore -> IO a) -> IO a+withTestStoreReturn action = do+    ref <- newIORef (Nothing :: Maybe a)+    withTestStore $ \store -> do+        r <- action store+        atomicModifyIORef' ref (\_ -> (Just r, ()))+    readIORef ref >>= \case+        Just r -> pure r+        Nothing -> error "withTestStoreReturn: action did not produce a result"
+ test/Test/PublisherRestartNoRebroadcast.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.PublisherRestartNoRebroadcast (spec) where++import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar)+import Control.Lens ((&), (.~), (^.))+import Control.Monad (when)+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Text qualified as T+import Kiroku.Store+import Kiroku.Store.Subscription.Types (OverflowPolicy (..), SubscriptionConfigM (..))+import Kiroku.Test.Postgres (withMigratedTestDatabase)+import Test.Helpers (caughtUpEventHandler, makeEvent, waitForPublisher, waitForSubscriptionLive, waitWithTimeout)+import Test.Hspec++spec :: Spec+spec =+    describe "publisher restart tail initialization" $ do+        it "does not rebroadcast restart history into a blocked all-stream subscriber" $+            withMigratedTestDatabase $ \connStr -> do+                let settings = defaultConnectionSettings connStr+                withStore settings $ \store ->+                    appendBatch store "tail-init-overflow-seed" "TailInitSeed" 1001++                firstSeen <- newEmptyMVar+                releaseFirst <- newEmptyMVar+                caughtUp <- newEmptyMVar+                blockedFirst <- newTVarIO True+                ref <- newIORef ([] :: [GlobalPosition])++                let subName = SubscriptionName "tail-init-no-rebroadcast"+                    stopType = EventType "TailInitStop"+                    handler' evt = do+                        modifyIORef' ref ((evt ^. #globalPosition) :)+                        shouldBlock <- atomically $ do+                            block <- readTVar blockedFirst+                            when block (writeTVar blockedFirst False)+                            pure block+                        when shouldBlock $ do+                            putMVar firstSeen ()+                            takeMVar releaseFirst+                        if evt ^. #eventType == stopType+                            then pure Stop+                            else pure Continue+                    cfg =+                        SubscriptionConfig+                            { name = subName+                            , target = AllStreams+                            , handler = handler'+                            , batchSize = 10+                            , queueCapacity = 1+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                    liveSettings =+                        settings+                            & #eventHandler .~ Just (caughtUpEventHandler subName caughtUp Nothing)++                withStore liveSettings $ \store -> do+                    handle <- subscribe store cfg+                    takeMVar firstSeen++                    Right _ <-+                        runStoreIO store $+                            appendToStream+                                (StreamName "tail-init-overflow-live")+                                NoStream+                                [makeEvent "TailInitDuringCatchUp" (Aeson.object [])]+                    waitForPublisher store (GlobalPosition 1002)++                    putMVar releaseFirst ()+                    waitForSubscriptionLive caughtUp++                    Right _ <-+                        runStoreIO store $+                            appendToStream+                                (StreamName "tail-init-overflow-stop")+                                NoStream+                                [makeEvent "TailInitStop" (Aeson.object [])]++                    result <- waitWithTimeout 10_000_000 handle+                    case result of+                        Left timeout -> expectationFailure timeout+                        Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                        Right (Right ()) -> pure ()++                collected <- reverse <$> readIORef ref+                collected `shouldBe` map GlobalPosition [1 .. 1003]++        it "delivers a live event appended after a restarted subscriber catches up" $+            withMigratedTestDatabase $ \connStr -> do+                let settings = defaultConnectionSettings connStr+                    subName = SubscriptionName "tail-init-live-after-catchup"+                withStore settings $ \store ->+                    appendBatch store "tail-init-live-seed" "TailInitLiveSeed" 3++                caughtUp <- newEmptyMVar+                ref <- newIORef ([] :: [GlobalPosition])+                let cfg =+                        SubscriptionConfig+                            { name = subName+                            , target = AllStreams+                            , handler = \evt -> do+                                modifyIORef' ref ((evt ^. #globalPosition) :)+                                if evt ^. #globalPosition == GlobalPosition 4+                                    then pure Stop+                                    else pure Continue+                            , batchSize = 10+                            , queueCapacity = 1+                            , overflowPolicy = DropSubscription+                            , consumerGroup = Nothing+                            , consumerGroupGuard = False+                            , retryPolicy = defaultRetryPolicy+                            , eventTypeFilter = AllEventTypes+                            , selector = Nothing+                            }+                    liveSettings =+                        settings+                            & #eventHandler .~ Just (caughtUpEventHandler subName caughtUp Nothing)++                withStore liveSettings $ \store -> do+                    handle <- subscribe store cfg+                    waitForSubscriptionLive caughtUp+                    Right _ <-+                        runStoreIO store $+                            appendToStream+                                (StreamName "tail-init-live-after-catchup")+                                NoStream+                                [makeEvent "TailInitLiveAfterCatchUp" (Aeson.object [])]+                    result <- waitWithTimeout 10_000_000 handle+                    case result of+                        Left timeout -> expectationFailure timeout+                        Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+                        Right (Right ()) -> pure ()++                collected <- reverse <$> readIORef ref+                collected `shouldBe` map GlobalPosition [1 .. 4]++        it "keeps per-subscription checkpoints independent from the publisher tail" $+            withMigratedTestDatabase $ \connStr -> do+                let settings = defaultConnectionSettings connStr+                withStore settings $ \store ->+                    appendBatch store "tail-init-checkpoint-seed" "TailInitCheckpointSeed" 10++                withStore settings $ \store -> do+                    runUntil store (SubscriptionName "tail-init-sub-a") 3+                        `shouldReturn` map GlobalPosition [1 .. 3]+                    runUntil store (SubscriptionName "tail-init-sub-b") 7+                        `shouldReturn` map GlobalPosition [1 .. 7]++                withStore settings $ \store -> do+                    runUntil store (SubscriptionName "tail-init-sub-a") 7+                        `shouldReturn` map GlobalPosition [4 .. 10]+                    runUntil store (SubscriptionName "tail-init-sub-b") 3+                        `shouldReturn` map GlobalPosition [8 .. 10]++appendBatch :: KirokuStore -> T.Text -> T.Text -> Int -> IO ()+appendBatch store streamName typePrefix count = do+    let events =+            [ makeEvent (typePrefix <> T.pack (show i)) (Aeson.object [])+            | i <- [1 .. count]+            ]+    result <- runStoreIO store $ appendToStream (StreamName streamName) NoStream events+    case result of+        Left err -> expectationFailure ("append failed: " <> show err)+        Right _ -> pure ()++runUntil :: KirokuStore -> SubscriptionName -> Int -> IO [GlobalPosition]+runUntil store subName targetCount = do+    ref <- newIORef ([] :: [GlobalPosition])+    countRef <- newTVarIO (0 :: Int)+    let handler' evt = do+            modifyIORef' ref ((evt ^. #globalPosition) :)+            n <- atomically $ do+                count <- readTVar countRef+                let count' = count + 1+                writeTVar countRef count'+                pure count'+            if n >= targetCount+                then pure Stop+                else pure Continue+        cfg =+            SubscriptionConfig+                { name = subName+                , target = AllStreams+                , handler = handler'+                , batchSize = 10+                , queueCapacity = 1+                , overflowPolicy = DropSubscription+                , consumerGroup = Nothing+                , consumerGroupGuard = False+                , retryPolicy = defaultRetryPolicy+                , eventTypeFilter = AllEventTypes+                , selector = Nothing+                }+    handle <- subscribe store cfg+    result <- waitWithTimeout 10_000_000 handle+    case result of+        Left timeout -> expectationFailure timeout+        Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+        Right (Right ()) -> pure ()+    reverse <$> readIORef ref
+ test/Test/ReadStream.hs view
@@ -0,0 +1,94 @@+{- | Tests for "Kiroku.Store.Read".'readStreamForwardStream' — the+Streamly-shaped sibling of 'readStreamForward'. The streaming wrapper+must yield the same events in the same order as the @Vector@-returning+form, page transparently across the configured @pageSize@, terminate on+empty / nonexistent streams, and honor a non-zero starting cursor.+-}+module Test.ReadStream (spec) where++import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.List.NonEmpty qualified as NE+import Data.Text qualified as T+import Data.Vector qualified as V+import Kiroku.Store+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Stream+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec++spec :: Spec+spec = around withTestStore $+    describe "readStreamForwardStream" $ do+        it "matches readStreamForward on a single-page stream" $ \store -> do+            let name = StreamName "rsfs-single-page"+                events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. 5 :: Int]]+            Right _ <- runStoreIO store $ appendToStream name NoStream events+            streamed <- runStoreIO store $ Stream.toList (readStreamForwardStream name (StreamVersion 0) 256)+            vectored <- runStoreIO store $ readStreamForward name (StreamVersion 0) 256+            case (streamed, vectored) of+                (Right xs, Right v) -> xs `shouldBe` V.toList v+                _ -> expectationFailure ("Unexpected error: " <> show streamed <> " / " <> show vectored)++        it "folds 1000 events end-to-end with Fold.length across multiple pages" $ \store -> do+            let name = StreamName "rsfs-multi-page"+                total = 1000 :: Int+                events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. total]]+            Right _ <- runStoreIO store $ appendToStream name NoStream events+            countResult <-+                runStoreIO store $+                    Stream.fold Fold.length (readStreamForwardStream name (StreamVersion 0) 256)+            countResult `shouldBe` Right total+            allEvents <-+                runStoreIO store $+                    Stream.toList (readStreamForwardStream name (StreamVersion 0) 256)+            case allEvents of+                Right xs -> case NE.nonEmpty xs of+                    Just ne -> do+                        let h = NE.head ne+                            l = NE.last ne+                        (h ^. #streamVersion) `shouldBe` StreamVersion 1+                        (h ^. #eventType) `shouldBe` EventType (T.pack "E1")+                        (l ^. #streamVersion) `shouldBe` StreamVersion (fromIntegral total)+                        (l ^. #eventType) `shouldBe` EventType (T.pack ("E" <> show total))+                    Nothing -> expectationFailure "Expected non-empty events list"+                Left err -> expectationFailure ("Unexpected error: " <> show err)++        it "preserves order and avoids duplicates / gaps when paging at pageSize 2" $ \store -> do+            let name = StreamName "rsfs-page-boundary"+                events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. 5 :: Int]]+            Right _ <- runStoreIO store $ appendToStream name NoStream events+            versions <-+                runStoreIO store $+                    Stream.toList $+                        fmap (^. #streamVersion) (readStreamForwardStream name (StreamVersion 0) 2)+            versions+                `shouldBe` Right+                    [ StreamVersion 1+                    , StreamVersion 2+                    , StreamVersion 3+                    , StreamVersion 4+                    , StreamVersion 5+                    ]++        it "terminates immediately on a nonexistent stream" $ \store -> do+            let name = StreamName "rsfs-never-created"+            result <-+                runStoreIO store $+                    Stream.toList (readStreamForwardStream name (StreamVersion 0) 256)+            result `shouldBe` Right []++        it "honors a non-zero starting cursor with exclusivity" $ \store -> do+            let name = StreamName "rsfs-non-zero-cursor"+                events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. 5 :: Int]]+            Right _ <- runStoreIO store $ appendToStream name NoStream events+            tailEvents <-+                runStoreIO store $+                    Stream.toList (readStreamForwardStream name (StreamVersion 2) 256)+            case tailEvents of+                Right xs -> do+                    length xs `shouldBe` 3+                    map (^. #streamVersion) xs+                        `shouldBe` [StreamVersion 3, StreamVersion 4, StreamVersion 5]+                Left err -> expectationFailure ("Unexpected error: " <> show err)
+ test/Test/StreamNameLookup.hs view
@@ -0,0 +1,52 @@+{- | Tests for 'Kiroku.Store.Read.lookupStreamNames' and 'lookupStreamName'+(plan 36). These resolve the surrogate 'RecordedEvent.originalStreamId' carried+by fan-in reads back to a human-readable 'StreamName', without every read having+to return the name (which a benchmark showed costs ~13% on @$all@ pages).+-}+module Test.StreamNameLookup (spec) where++import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Vector qualified as V+import Kiroku.Store+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec++spec :: Spec+spec = around withTestStore $+    describe "lookupStreamNames / lookupStreamName" $ do+        it "resolves originalStreamId back to the source stream for $all reads" $ \store -> do+            Right _ <-+                runStoreIO store $+                    appendToStream (StreamName "orders-1") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+            Right _ <-+                runStoreIO store $+                    appendToStream (StreamName "shipments-1") NoStream [makeEvent "ShipmentDispatched" (Aeson.object [])]+            Right evs <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+            Right names <- runStoreIO store $ lookupStreamNames (map (^. #originalStreamId) (V.toList evs))+            let nameOf typ =+                    case V.find ((== EventType typ) . (^. #eventType)) evs of+                        Just e -> Map.lookup (e ^. #originalStreamId) names+                        Nothing -> Nothing+            nameOf "OrderCreated" `shouldBe` Just (StreamName "orders-1")+            nameOf "ShipmentDispatched" `shouldBe` Just (StreamName "shipments-1")++        it "omits ids that name no existing stream" $ \store -> do+            Right names <- runStoreIO store $ lookupStreamNames [StreamId 999999]+            Map.size names `shouldBe` 0++        it "returns an empty map for an empty id list" $ \store -> do+            Right names <- runStoreIO store $ lookupStreamNames []+            Map.null names `shouldBe` True++        it "lookupStreamName resolves a single id, and Nothing for an unknown one" $ \store -> do+            Right _ <-+                runStoreIO store $+                    appendToStream (StreamName "widgets-7") NoStream [makeEvent "WidgetMade" (Aeson.object [])]+            Right (Just sid) <- runStoreIO store $ lookupStreamId (StreamName "widgets-7")+            Right found <- runStoreIO store $ lookupStreamName sid+            found `shouldBe` Just (StreamName "widgets-7")+            Right missing <- runStoreIO store $ lookupStreamName (StreamId 888888)+            missing `shouldBe` Nothing
+ test/Test/SubscriptionPauseResume.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Regression tests for ExecPlan 41 M2 — recoverable backpressure.++Before M2, a slow AllStreams consumer that filled its bounded queue was+__terminal__: the publisher marked it @Overflowed@ and the worker threw+'Kiroku.Store.Subscription.Types.SubscriptionOverflowed' and died (overflow+policy 'Kiroku.Store.Subscription.Types.DropSubscription'). M2 adds the+recoverable 'Kiroku.Store.Subscription.Types.PauseAndResume' policy (now the+default): when the queue fills the publisher /pauses/ delivery rather than+killing the subscriber, and the worker — once its slow handler catches up —+drains the stale queue and re-reads the events it missed directly from the+database from its checkpoint. No event is lost and the checkpoint advances+monotonically.++The first spec proves the recovery: a handler that blocks long enough to fill a+@queueCapacity = 1@ subscriber while five events are appended still delivers all+five in order, stops cleanly (not via 'SubscriptionOverflowed'), advances the+checkpoint to the last position, and emits a+'Kiroku.Store.Observability.KirokuEventSubscriptionPaused' followed by a+'Kiroku.Store.Observability.KirokuEventSubscriptionResumed'.++The second spec proves the fail-fast path is preserved: the identical scenario+under 'DropSubscription' still surfaces 'SubscriptionOverflowed' on @wait@.++To confirm the first spec actually pins the new behavior: temporarily set its+@overflowPolicy@ to 'DropSubscription' and it fails with+@Left (SubscriptionOverflowed ...)@ where it expected @Right ()@.+-}+module Test.SubscriptionPauseResume (spec) where++import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar)+import Control.Exception qualified+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int32)+import Data.Text qualified as T+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Kiroku.Store+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Subscription.Types (OverflowPolicy (..), SubscriptionConfigM (..), SubscriptionOverflowed (..))+import Test.Helpers (makeEvent, waitForPublisher, waitWithTimeout, withTestStoreSettings)+import Test.Hspec++-- Read the durable checkpoint (@kiroku.subscriptions.last_seen@) for a non-group+-- subscription (member 0), or 'Nothing' if no row exists yet.+readCheckpoint :: KirokuStore -> T.Text -> IO (Maybe Int)+readCheckpoint store subName = do+    result <- Pool.use (store ^. #pool) (Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt)+    case result of+        Left err -> error ("readCheckpoint failed: " <> show err)+        Right mPos -> pure (fmap fromIntegral mPos)++spec :: Spec+spec = describe "subscription FSM — recoverable backpressure (EP-41 M2)" $ do+    it "pauses a slow AllStreams consumer and resumes, delivering all events" $ do+        evtRef <- newIORef ([] :: [KirokuEvent])+        let evtHandler e = modifyIORef' evtRef (e :)+        withTestStoreSettings (& #eventHandler .~ Just evtHandler) $ \store -> do+            firstSeen <- newEmptyMVar+            release <- newEmptyMVar+            delivered <- newIORef ([] :: [GlobalPosition])+            seenCount <- newTVarIO (0 :: Int)+            let handler' evt = do+                    modifyIORef' delivered ((evt ^. #globalPosition) :)+                    n <- atomically $ do+                        c <- readTVar seenCount+                        writeTVar seenCount (c + 1)+                        pure (c + 1)+                    if n == 1+                        then putMVar firstSeen () >> takeMVar release+                        else pure ()+                    -- Stop once all five have been seen, so `wait` resolves Right ().+                    if n >= 5 then pure Stop else pure Continue+            let cfg =+                    SubscriptionConfig+                        { name = SubscriptionName "pause-resume-test"+                        , target = AllStreams+                        , handler = handler'+                        , batchSize = 100+                        , queueCapacity = 1+                        , overflowPolicy = PauseAndResume+                        , consumerGroup = Nothing+                        , consumerGroupGuard = False+                        , retryPolicy = defaultRetryPolicy+                        , eventTypeFilter = AllEventTypes+                        , selector = Nothing+                        }+            handle <- subscribe store cfg+            -- First append: the worker reads it from the queue and the handler+            -- blocks inside it on `release`, so the worker stops draining.+            Right _ <- runStoreIO store $ appendToStream (StreamName "pr-1") NoStream [makeEvent "E1" (Aeson.object [])]+            takeMVar firstSeen+            -- With the worker stuck, append four more one at a time. Capacity is 1,+            -- so the second of these fills the queue and the publisher pauses the+            -- subscriber for the rest (skipping, not dropping).+            let appendOne i = do+                    let sn = StreamName ("pr-" <> T.pack (show (i :: Int)))+                    Right _ <- runStoreIO store $ appendToStream sn NoStream [makeEvent "Ex" (Aeson.object [])]+                    waitForPublisher store (GlobalPosition (fromIntegral i))+            appendOne 2+            appendOne 3+            appendOne 4+            appendOne 5+            -- Release the slow handler; the worker drains, resumes, re-catches-up+            -- from its checkpoint, and delivers the skipped events.+            putMVar release ()+            result <- waitWithTimeout 15_000_000 handle+            case result of+                Left timeout -> expectationFailure timeout+                Right (Left e) -> expectationFailure ("expected a clean stop, got: " <> show e)+                Right (Right ()) -> pure ()+            ds <- reverse <$> readIORef delivered+            ds `shouldBe` map GlobalPosition [1 .. 5]+            cp <- readCheckpoint store "pause-resume-test"+            cp `shouldBe` Just 5+            evts <- readIORef evtRef+            let isPaused (KirokuEventSubscriptionPaused (SubscriptionName "pause-resume-test") _ _) = True+                isPaused _ = False+                isResumed (KirokuEventSubscriptionResumed (SubscriptionName "pause-resume-test") _ _) = True+                isResumed _ = False+            any isPaused evts `shouldBe` True+            any isResumed evts `shouldBe` True++    it "still fails fast under DropSubscription" $ do+        withTestStoreSettings Prelude.id $ \store -> do+            firstSeen <- newEmptyMVar+            release <- newEmptyMVar+            seenCount <- newTVarIO (0 :: Int)+            let handler' _evt = do+                    n <- atomically $ do+                        c <- readTVar seenCount+                        writeTVar seenCount (c + 1)+                        pure (c + 1)+                    if n == 1+                        then putMVar firstSeen () >> takeMVar release+                        else pure ()+                    pure Continue+            let cfg =+                    SubscriptionConfig+                        { name = SubscriptionName "dropsub-overflow-test"+                        , target = AllStreams+                        , handler = handler'+                        , batchSize = 100+                        , queueCapacity = 1+                        , overflowPolicy = DropSubscription+                        , consumerGroup = Nothing+                        , consumerGroupGuard = False+                        , retryPolicy = defaultRetryPolicy+                        , eventTypeFilter = AllEventTypes+                        , selector = Nothing+                        }+            handle <- subscribe store cfg+            Right _ <- runStoreIO store $ appendToStream (StreamName "ds-1") NoStream [makeEvent "E1" (Aeson.object [])]+            takeMVar firstSeen+            let appendOne i = do+                    let sn = StreamName ("ds-" <> T.pack (show (i :: Int)))+                    Right _ <- runStoreIO store $ appendToStream sn NoStream [makeEvent "Ex" (Aeson.object [])]+                    waitForPublisher store (GlobalPosition (fromIntegral i))+            appendOne 2+            appendOne 3+            appendOne 4+            appendOne 5+            putMVar release ()+            result <- waitWithTimeout 15_000_000 handle+            case result of+                Left timeout -> expectationFailure timeout+                Right (Right ()) -> expectationFailure "expected SubscriptionOverflowed, got a clean stop"+                Right (Left e) ->+                    case Control.Exception.fromException e of+                        Just (SubscriptionOverflowed sn) -> sn `shouldBe` SubscriptionName "dropsub-overflow-test"+                        Nothing -> expectationFailure ("expected SubscriptionOverflowed, got: " <> show e)
+ test/Test/SubscriptionReconnect.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Regression test for ExecPlan 41 M3 — worker-level live reconnect.++Before M3, a live database fetch error in the Category / consumer-group live+loops was retried in place, forever and invisibly. M3 lifts recovery into the+FSM: a live-mode 'Hasql.Pool.UsageError' drives the worker into the+'Kiroku.Store.Subscription.Fsm.Reconnecting' state — it emits+'Kiroku.Store.Observability.KirokuEventSubscriptionReconnecting', backs off, and+re-catches-up from its checkpoint — instead of silently spinning. The+subscription survives the fault and resumes from where it left off.++This spec uses a __Category__ subscription, not AllStreams: AllStreams live+delivery is fed by the shared publisher (which owns its own reconnect), so the+AllStreams worker performs no live-mode fetch and has nothing to reconnect. The+Category worker fetches in live mode, so 'withFetchBatchHookForTest' can inject+failures there. The hook fails the first @K@ fetches that occur __after__ the+subscription has caught up (a 'TVar' flag the @eventHandler@ sets on+'KirokuEventSubscriptionCaughtUp'), then falls through to the real database.++Asserted: at least one 'KirokuEventSubscriptionReconnecting' fired; @wait@ did+not surface the injected error (the worker recovered rather than died); every+appended event was delivered in increasing position; the checkpoint advanced to+the last position.+-}+module Test.SubscriptionReconnect (spec) where++import Control.Concurrent.STM (atomically, check, newTVarIO, readTVar, readTVarIO, writeTVar)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int32)+import Data.Text qualified as T+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Kiroku.Store+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Subscription.Types qualified as SubTypes+import Kiroku.Store.Subscription.Worker (withFetchBatchHookForTest)+import Test.Helpers (makeEvent, waitWithTimeout, withTestStoreSettings)+import Test.Hspec++readCheckpoint :: KirokuStore -> T.Text -> IO (Maybe Int)+readCheckpoint store subName = do+    result <- Pool.use (store ^. #pool) (Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt)+    case result of+        Left err -> error ("readCheckpoint failed: " <> show err)+        Right mPos -> pure (fmap fromIntegral mPos)++spec :: Spec+spec = describe "subscription FSM — worker-level live reconnect (EP-41 M3)" $ do+    it "reconnects and resumes after transient live-mode database errors" $ do+        evtRef <- newIORef ([] :: [KirokuEvent])+        deliveredRef <- newIORef ([] :: [GlobalPosition])+        caughtUpFlag <- newTVarIO False+        failsLeft <- newTVarIO (2 :: Int)+        seenCount <- newTVarIO (0 :: Int)++        let subName = SubscriptionName "reconnect-test"+            observe evt = do+                modifyIORef' evtRef (evt :)+                case evt of+                    KirokuEventSubscriptionCaughtUp n _ _+                        | n == subName -> atomically (writeTVar caughtUpFlag True)+                    _ -> pure ()+            -- Fail the first K fetches that happen after catch-up, then fall+            -- through to the real database. Catch-up fetches (flag still False)+            -- are never failed, so the fault is purely a live-mode event.+            injectHook config _cursor+                | SubTypes.name config == subName = do+                    cu <- readTVarIO caughtUpFlag+                    if not cu+                        then pure Nothing+                        else atomically $ do+                            n <- readTVar failsLeft+                            if n > 0+                                then do+                                    writeTVar failsLeft (n - 1)+                                    pure (Just (Left Pool.AcquisitionTimeoutUsageError))+                                else pure Nothing+                | otherwise = pure Nothing+            handler' evt = do+                modifyIORef' deliveredRef ((evt ^. #globalPosition) :)+                n <- atomically $ do+                    c <- readTVar seenCount+                    writeTVar seenCount (c + 1)+                    pure (c + 1)+                if n >= 3 then pure Stop else pure Continue+            cfg =+                SubscriptionConfig+                    { name = subName+                    , target = Category (CategoryName "rc")+                    , handler = handler'+                    , batchSize = 100+                    , queueCapacity = 16+                    , overflowPolicy = PauseAndResume+                    , consumerGroup = Nothing+                    , consumerGroupGuard = False+                    , retryPolicy = defaultRetryPolicy+                    , eventTypeFilter = AllEventTypes+                    , selector = Nothing+                    }++        withTestStoreSettings (& #eventHandler .~ Just observe) $ \store -> do+            withFetchBatchHookForTest injectHook $ do+                -- Empty store: the worker catches up instantly (no fetch), sets the+                -- flag, then its first live-mode fetch is the one the hook fails —+                -- so the fault lands squarely in live mode.+                handle <- subscribe store cfg+                -- Wait until catch-up has completed and the reconnect failures have+                -- been consumed, so the appends below are served by the real DB.+                atomically $ do+                    cu <- readTVar caughtUpFlag+                    check cu+                    n <- readTVar failsLeft+                    check (n == 0)+                Right _ <- runStoreIO store $ appendToStream (StreamName "rc-1") NoStream [makeEvent "A" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "rc-2") NoStream [makeEvent "B" (Aeson.object [])]+                Right _ <- runStoreIO store $ appendToStream (StreamName "rc-3") NoStream [makeEvent "C" (Aeson.object [])]+                result <- waitWithTimeout 20_000_000 handle+                case result of+                    Left timeout -> expectationFailure timeout+                    Right (Left e) -> expectationFailure ("worker did not survive the fault: " <> show e)+                    Right (Right ()) -> pure ()++            delivered <- reverse <$> readIORef deliveredRef+            delivered `shouldBe` map GlobalPosition [1 .. 3]+            cp <- readCheckpoint store "reconnect-test"+            cp `shouldBe` Just 3+            evts <- readIORef evtRef+            let isReconnecting (KirokuEventSubscriptionReconnecting n _ _) = n == subName+                isReconnecting _ = False+            any isReconnecting evts `shouldBe` True
+ test/Test/SubscriptionRegistry.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Tests for the central subscription-state registry (ExecPlan 45 / EP-1 of+MasterPlan 7).++These prove the registry's observable behaviour against a real migrated+PostgreSQL database:++  * Several live subscriptions (including consumer-group members) appear in the+    'Kiroku.Store.Subscription.subscriptionStates' snapshot with sensible state+    labels, matching keys, and a valid FSM cursor, and a live handle's+    'currentState' agrees with its snapshot entry (the single-source-of-truth+    reshape).+  * A subscription's key disappears from the snapshot when it stops cleanly, is+    cancelled, or crashes — and its held handle's 'currentState' then returns+    'Nothing'.+  * A stale duplicate-key worker's cleanup cannot delete a newer worker's+    replacement entry (the per-worker token defends the active entry).+-}+module Test.SubscriptionRegistry (spec) where++import Control.Concurrent (threadDelay)+import Control.Exception (throwIO)+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Foldable (for_)+import Data.Generics.Labels ()+import Data.Int (Int32)+import Data.Map.Strict qualified as Map+import Data.Maybe (isJust, isNothing)+import Data.Text (Text)+import Kiroku.Store+import Kiroku.Store.Subscription.Types (SubscriptionConfigM (..))+import Test.Helpers (makeEvent, waitForPublisher, withTestStore)+import Test.Hspec++-- | A plain @$all@ subscription config whose handler never stops.+plainCont :: Text -> SubscriptionConfig+plainCont nm = defaultSubscriptionConfig (SubscriptionName nm) AllStreams (\_ -> pure Continue)++-- | A size-@n@ category-group config for member @m@ whose handler never stops.+groupCont :: Text -> Text -> Int32 -> Int32 -> SubscriptionConfig+groupCont nm cat m n =+    (defaultSubscriptionConfig (SubscriptionName nm) (Category (CategoryName cat)) (\_ -> pure Continue))+        { consumerGroup = Just (ConsumerGroup{member = m, size = n})+        }++-- | Poll the snapshot until the keyed entry reaches the given 'statePhase' label.+waitUntilPhase :: Int -> KirokuStore -> (SubscriptionName, Int32) -> Text -> IO Bool+waitUntilPhase budget store key phase+    | budget <= 0 = pure False+    | otherwise = do+        m <- subscriptionStates store+        case Map.lookup key m of+            Just v | (v ^. #statePhase) == phase -> pure True+            _ -> threadDelay 20_000 >> waitUntilPhase (budget - 20_000) store key phase++-- | Poll the snapshot until the keyed entry is present.+waitUntilPresent :: Int -> KirokuStore -> (SubscriptionName, Int32) -> IO Bool+waitUntilPresent budget store key+    | budget <= 0 = pure False+    | otherwise = do+        m <- subscriptionStates store+        if Map.member key m+            then pure True+            else threadDelay 20_000 >> waitUntilPresent (budget - 20_000) store key++-- | Poll the snapshot until the keyed entry is absent.+waitUntilAbsent :: Int -> KirokuStore -> (SubscriptionName, Int32) -> IO Bool+waitUntilAbsent budget store key+    | budget <= 0 = pure False+    | otherwise = do+        m <- subscriptionStates store+        if Map.member key m+            then threadDelay 20_000 >> waitUntilAbsent (budget - 20_000) store key+            else pure True++spec :: Spec+spec = describe "subscription registry (EP-1 / plan 45)" $ do+    it "registers every live subscription with a sensible state and position" $+        withTestStore $ \store -> do+            let plainName = SubscriptionName "reg-plain"+                groupName = SubscriptionName "reg-group"+            Right _ <- runStoreIO store $ appendToStream (StreamName "reg-1") NoStream [makeEvent "A" (Aeson.object [])]+            Right _ <- runStoreIO store $ appendToStream (StreamName "reg-2") NoStream [makeEvent "B" (Aeson.object [])]+            waitForPublisher store (GlobalPosition 2)+            hPlain <- subscribe store (plainCont "reg-plain")+            hG0 <- subscribe store (groupCont "reg-group" "reg" 0 2)+            hG1 <- subscribe store (groupCont "reg-group" "reg" 1 2)+            okP <- waitUntilPhase 5_000_000 store (plainName, 0) "live"+            ok0 <- waitUntilPhase 5_000_000 store (groupName, 0) "live"+            ok1 <- waitUntilPhase 5_000_000 store (groupName, 1) "live"+            (okP, ok0, ok1) `shouldBe` (True, True, True)+            snap <- subscriptionStates store+            Map.keys snap `shouldMatchList` [(plainName, 0), (groupName, 0), (groupName, 1)]+            for_ (Map.toList snap) $ \((nm, mbr), v) -> do+                (v ^. #subscriptionName) `shouldBe` nm+                (v ^. #member) `shouldBe` mbr+                (v ^. #statePhase) `shouldSatisfy` (`elem` (["catching_up", "live"] :: [Text]))+                let GlobalPosition p = v ^. #cursor+                p `shouldSatisfy` (>= 0)+            -- currentState on a live handle agrees with its snapshot entry.+            Just s <- currentState hPlain+            case Map.lookup (plainName, 0) snap of+                Just v -> stateName s `shouldBe` (v ^. #statePhase)+                Nothing -> expectationFailure "plain subscription missing from snapshot"+            mapM_ cancel [hPlain, hG0, hG1]++    it "removes a subscription's entry when it stops cleanly" $+        withTestStore $ \store -> do+            let nm = SubscriptionName "reg-stop"+            Right _ <- runStoreIO store $ appendToStream (StreamName "stop-1") NoStream [makeEvent "A" (Aeson.object [])]+            waitForPublisher store (GlobalPosition 1)+            handle <- subscribe store (defaultSubscriptionConfig nm AllStreams (\_ -> pure Stop))+            _ <- wait handle+            gone <- waitUntilAbsent 5_000_000 store (nm, 0)+            gone `shouldBe` True+            cs <- currentState handle+            cs `shouldSatisfy` isNothing++    it "removes a subscription's entry when it is cancelled" $+        withTestStore $ \store -> do+            let nm = SubscriptionName "reg-cancel"+            Right _ <- runStoreIO store $ appendToStream (StreamName "cancel-1") NoStream [makeEvent "A" (Aeson.object [])]+            waitForPublisher store (GlobalPosition 1)+            handle <- subscribe store (plainCont "reg-cancel")+            live <- waitUntilPhase 5_000_000 store (nm, 0) "live"+            live `shouldBe` True+            cancel handle+            _ <- wait handle+            gone <- waitUntilAbsent 5_000_000 store (nm, 0)+            gone `shouldBe` True+            cs <- currentState handle+            cs `shouldSatisfy` isNothing++    it "removes a subscription's entry when its handler crashes" $+        withTestStore $ \store -> do+            let nm = SubscriptionName "reg-crash"+            Right _ <- runStoreIO store $ appendToStream (StreamName "crash-1") NoStream [makeEvent "A" (Aeson.object [])]+            waitForPublisher store (GlobalPosition 1)+            handle <- subscribe store (defaultSubscriptionConfig nm AllStreams (\_ -> throwIO (userError "boom")))+            res <- wait handle+            case res of+                Left _ -> pure ()+                Right () -> expectationFailure "expected the crashing handler to fail the worker"+            gone <- waitUntilAbsent 5_000_000 store (nm, 0)+            gone `shouldBe` True+            cs <- currentState handle+            cs `shouldSatisfy` isNothing++    it "stale duplicate-key cleanup does not remove the replacement entry" $+        withTestStore $ \store -> do+            let nm = SubscriptionName "reg-dup"+            h1 <- subscribe store (plainCont "reg-dup")+            present1 <- waitUntilPresent 5_000_000 store (nm, 0)+            present1 `shouldBe` True+            -- A second subscribe with the same (name, member) supersedes h1's+            -- entry in the registry (insert is synchronous, before the fork).+            h2 <- subscribe store (plainCont "reg-dup")+            -- Stopping the first worker must not delete the second's live entry.+            cancel h1+            _ <- wait h1+            snap <- subscriptionStates store+            Map.member (nm, 0) snap `shouldBe` True+            cs1 <- currentState h1+            cs1 `shouldSatisfy` isNothing+            cs2 <- currentState h2+            cs2 `shouldSatisfy` isJust+            cancel h2
+ test/Test/SubscriptionRetryDeadLetter.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Regression tests for EP-40 (MasterPlan 6, child plan 2) — per-event retry+and dead-letter dispositions in @kiroku-store@.++These pin the three behavioral acceptance criteria from the ExecPlan:++  * __dead-letter__: a handler returning 'DeadLetter' for one event records it in+    @kiroku.dead_letters@, advances the checkpoint past it atomically, and keeps+    delivering later events;+  * __bounded retry__: a handler returning 'Retry' for one event sees that same+    event redelivered (the checkpoint does not advance past it) until it+    succeeds;+  * __retry exhaustion__: once the configured 'retryMaxAttempts' is exceeded the+    event is dead-lettered with 'DeadLetterMaxAttempts' and later events+    continue.++All three use an 'AllStreams' subscription (the FSM 'DeliverBatch' delivery+path). Events are appended and the publisher is awaited before subscribing, so+delivery happens during catch-up.+-}+module Test.SubscriptionRetryDeadLetter (spec) where++import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (atomicModifyIORef', modifyIORef', newIORef, readIORef)+import Data.Int (Int32, Int64)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Kiroku.Store+import Kiroku.Store.SQL qualified as SQL+import Test.Helpers (makeEvent, waitForPublisher, waitWithTimeout, withTestStore)+import Test.Hspec++posOf :: RecordedEvent -> Int64+posOf e = case e ^. #globalPosition of GlobalPosition p -> p++readCheckpoint :: KirokuStore -> Text -> IO (Maybe Int64)+readCheckpoint store subName = do+    result <- Pool.use (store ^. #pool) (Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt)+    case result of+        Left err -> error ("readCheckpoint failed: " <> show err)+        Right mPos -> pure mPos++readDeadLetters :: KirokuStore -> Text -> IO [SQL.DeadLetterRecord]+readDeadLetters store subName = do+    result <- Pool.use (store ^. #pool) (Session.statement (subName, 0 :: Int32) SQL.readDeadLettersStmt)+    case result of+        Left err -> error ("readDeadLetters failed: " <> show err)+        Right v -> pure (V.toList v)++-- Append three single-event streams so global positions are 1, 2, 3.+appendThree :: KirokuStore -> IO ()+appendThree store =+    mapM_+        ( \i -> do+            let sn = StreamName ("rdl-" <> T.pack (show (i :: Int)))+            Right _ <- runStoreIO store $ appendToStream sn NoStream [makeEvent "E" (Aeson.object [])]+            pure ()+        )+        [1 .. 3]++spec :: Spec+spec = describe "subscription dispositions — retry / dead-letter (EP-40)" $ do+    it "dead-letters one event, advances the checkpoint, and keeps delivering" $ do+        withTestStore $ \store -> do+            appendThree store+            waitForPublisher store (GlobalPosition 3)+            delivered <- newIORef ([] :: [Int64])+            let subName = SubscriptionName "rdl-deadletter"+                handler' evt = do+                    let p = posOf evt+                    modifyIORef' delivered (p :)+                    case p of+                        2 -> pure (DeadLetter (DeadLetterPoison "boom"))+                        3 -> pure Stop+                        _ -> pure Continue+                cfg = (defaultSubscriptionConfig subName AllStreams handler'){batchSize = 100}+            handle <- subscribe store cfg+            result <- waitWithTimeout 20_000_000 handle+            case result of+                Left timeout -> expectationFailure timeout+                Right (Left e) -> expectationFailure ("expected a clean stop, got: " <> show e)+                Right (Right ()) -> pure ()+            ds <- reverse <$> readIORef delivered+            -- Each event delivered once; event 2 was dead-lettered (not retried).+            ds `shouldBe` [1, 2, 3]+            dls <- readDeadLetters store "rdl-deadletter"+            map SQL.deadLetterGlobalPosition dls `shouldBe` [2]+            -- Checkpoint advanced to the last processed event (the Stop at 3).+            cp <- readCheckpoint store "rdl-deadletter"+            cp `shouldBe` Just 3++    it "retries one event until it succeeds without advancing past it" $ do+        withTestStore $ \store -> do+            appendThree store+            waitForPublisher store (GlobalPosition 3)+            delivered <- newIORef ([] :: [Int64])+            pos2Count <- newIORef (0 :: Int)+            let subName = SubscriptionName "rdl-retry"+                handler' evt = do+                    let p = posOf evt+                    modifyIORef' delivered (p :)+                    case p of+                        2 -> do+                            c <- atomicModifyIORef' pos2Count (\x -> (x + 1, x + 1))+                            -- Retry the first two deliveries, succeed on the third.+                            if c <= 2 then pure (Retry (RetryDelay 0)) else pure Continue+                        3 -> pure Stop+                        _ -> pure Continue+                cfg = (defaultSubscriptionConfig subName AllStreams handler'){batchSize = 100}+            handle <- subscribe store cfg+            result <- waitWithTimeout 20_000_000 handle+            case result of+                Left timeout -> expectationFailure timeout+                Right (Left e) -> expectationFailure ("expected a clean stop, got: " <> show e)+                Right (Right ()) -> pure ()+            ds <- reverse <$> readIORef delivered+            -- Event 2 delivered three times (two retries + success); 1 and 3 once each.+            length (filter (== 2) ds) `shouldBe` 3+            ds `shouldBe` [1, 2, 2, 2, 3]+            -- No dead letters; the retry succeeded.+            dls <- readDeadLetters store "rdl-retry"+            dls `shouldSatisfy` null+            cp <- readCheckpoint store "rdl-retry"+            cp `shouldBe` Just 3++    it "dead-letters after exhausting the retry budget and continues" $ do+        withTestStore $ \store -> do+            appendThree store+            waitForPublisher store (GlobalPosition 3)+            delivered <- newIORef ([] :: [Int64])+            let subName = SubscriptionName "rdl-exhaust"+                handler' evt = do+                    let p = posOf evt+                    modifyIORef' delivered (p :)+                    case p of+                        2 -> pure (Retry (RetryDelay 0)) -- always retry → exhausts the budget+                        3 -> pure Stop+                        _ -> pure Continue+                cfg =+                    (defaultSubscriptionConfig subName AllStreams handler')+                        { batchSize = 100+                        , retryPolicy = RetryPolicy{retryMaxAttempts = 3}+                        }+            handle <- subscribe store cfg+            result <- waitWithTimeout 20_000_000 handle+            case result of+                Left timeout -> expectationFailure timeout+                Right (Left e) -> expectationFailure ("expected a clean stop, got: " <> show e)+                Right (Right ()) -> pure ()+            ds <- reverse <$> readIORef delivered+            -- Event 2 delivered exactly retryMaxAttempts (3) times, then dead-lettered.+            length (filter (== 2) ds) `shouldBe` 3+            ds `shouldBe` [1, 2, 2, 2, 3]+            dls <- readDeadLetters store "rdl-exhaust"+            map SQL.deadLetterGlobalPosition dls `shouldBe` [2]+            map SQL.deadLetterAttemptCount dls `shouldBe` [3]+            -- Later events still processed; checkpoint advanced to the end.+            cp <- readCheckpoint store "rdl-exhaust"+            cp `shouldBe` Just 3
+ test/Test/SubscriptionState.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Regression tests for ExecPlan 41 M4 — observable FSM state and the+no-missed-events / monotonic-checkpoint invariants under the FSM driver.++The first spec reads the worker's current state through the new+'Kiroku.Store.Subscription.Types.currentState' handle accessor: while a handler+blocks on its first catch-up event the worker is observably @CatchingUp@, and+once it has caught up it is observably @Live@.++The second spec proves the FSM driver preserves the core delivery invariant: with+events appended both before and after the subscription starts, every event is+delivered exactly once in strictly increasing 'GlobalPosition' across the+catch-up → live boundary, and the durable checkpoint advances to the last+position (a monotonic, no-gap result).+-}+module Test.SubscriptionState (spec) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int32)+import Data.Text qualified as T+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Kiroku.Store+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Subscription.Fsm (SubscriptionState (..))+import Kiroku.Store.Subscription.Types (SubscriptionConfigM (..))+import Test.Helpers (caughtUpEventHandler, makeEvent, waitForPublisher, waitForSubscriptionLive, waitWithTimeout, withTestStoreSettings)+import Test.Hspec++isCatchingUp :: SubscriptionState -> Bool+isCatchingUp CatchingUp{} = True+isCatchingUp _ = False++isLive :: SubscriptionState -> Bool+isLive Live{} = True+isLive _ = False++-- Poll an FSM-state read until the predicate holds or the budget runs out.+-- The read is the handle's 'currentState', which is @Maybe SubscriptionState@:+-- @Nothing@ (not currently live) is treated as "not yet in the wanted state".+waitUntilState :: Int -> IO (Maybe SubscriptionState) -> (SubscriptionState -> Bool) -> IO Bool+waitUntilState budget readSt p+    | budget <= 0 = pure False+    | otherwise = do+        s <- readSt+        if maybe False p s+            then pure True+            else threadDelay 20_000 >> waitUntilState (budget - 20_000) readSt p++readCheckpoint :: KirokuStore -> T.Text -> IO (Maybe Int)+readCheckpoint store subName = do+    result <- Pool.use (store ^. #pool) (Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt)+    case result of+        Left err -> error ("readCheckpoint failed: " <> show err)+        Right mPos -> pure (fmap fromIntegral mPos)++spec :: Spec+spec = describe "subscription FSM — observable state (EP-41 M4)" $ do+    it "reports CatchingUp while blocked in catch-up and Live once caught up" $ do+        caughtUp <- newEmptyMVar+        firstSeen <- newEmptyMVar+        release <- newEmptyMVar+        seen <- newTVarIO (0 :: Int)+        let subName = SubscriptionName "state-readout-test"+            observe = caughtUpEventHandler subName caughtUp Nothing+            handler' _evt = do+                n <- atomically $ do+                    c <- readTVar seen+                    writeTVar seen (c + 1)+                    pure (c + 1)+                if n == 1+                    then putMVar firstSeen () >> takeMVar release+                    else pure ()+                pure Continue+            cfg =+                SubscriptionConfig+                    { name = subName+                    , target = AllStreams+                    , handler = handler'+                    , batchSize = 100+                    , queueCapacity = 16+                    , overflowPolicy = PauseAndResume+                    , consumerGroup = Nothing+                    , consumerGroupGuard = False+                    , retryPolicy = defaultRetryPolicy+                    , eventTypeFilter = AllEventTypes+                    , selector = Nothing+                    }+        withTestStoreSettings (& #eventHandler .~ Just observe) $ \store -> do+            Right _ <- runStoreIO store $ appendToStream (StreamName "st-1") NoStream [makeEvent "A" (Aeson.object [])]+            Right _ <- runStoreIO store $ appendToStream (StreamName "st-2") NoStream [makeEvent "B" (Aeson.object [])]+            Right _ <- runStoreIO store $ appendToStream (StreamName "st-3") NoStream [makeEvent "C" (Aeson.object [])]+            waitForPublisher store (GlobalPosition 3)+            handle <- subscribe store cfg+            -- Worker is now blocked inside the handler on the first catch-up event.+            takeMVar firstSeen+            Just st <- currentState handle+            st `shouldSatisfy` isCatchingUp+            -- Release: catch-up completes, the worker goes live.+            putMVar release ()+            waitForSubscriptionLive caughtUp+            becameLive <- waitUntilState 5_000_000 (currentState handle) isLive+            becameLive `shouldBe` True+            cancel handle++    it "delivers every event exactly once in order across the catch-up to live boundary" $ do+        delivered <- newIORef ([] :: [GlobalPosition])+        seen <- newTVarIO (0 :: Int)+        let subName = SubscriptionName "no-missed-test"+            handler' evt = do+                modifyIORef' delivered ((evt ^. #globalPosition) :)+                n <- atomically $ do+                    c <- readTVar seen+                    writeTVar seen (c + 1)+                    pure (c + 1)+                if n >= 10 then pure Stop else pure Continue+            cfg =+                SubscriptionConfig+                    { name = subName+                    , target = AllStreams+                    , handler = handler'+                    , batchSize = 100+                    , queueCapacity = 16+                    , overflowPolicy = PauseAndResume+                    , consumerGroup = Nothing+                    , consumerGroupGuard = False+                    , retryPolicy = defaultRetryPolicy+                    , eventTypeFilter = AllEventTypes+                    , selector = Nothing+                    }+        withTestStoreSettings Prelude.id $ \store -> do+            -- Five events before subscribing (delivered during catch-up).+            let appendAt i =+                    runStoreIO store $+                        appendToStream (StreamName ("nm-" <> T.pack (show (i :: Int)))) NoStream [makeEvent "E" (Aeson.object [])]+            mapM_ (\i -> appendAt i >> pure ()) [1 .. 5]+            waitForPublisher store (GlobalPosition 5)+            handle <- subscribe store cfg+            -- Five more after (delivered live).+            mapM_ (\i -> appendAt i >> pure ()) [6 .. 10]+            result <- waitWithTimeout 20_000_000 handle+            case result of+                Left timeout -> expectationFailure timeout+                Right (Left e) -> expectationFailure ("subscription failed: " <> show e)+                Right (Right ()) -> pure ()+            ds <- reverse <$> readIORef delivered+            ds `shouldBe` map GlobalPosition [1 .. 10]+            cp <- readCheckpoint store "no-missed-test"+            cp `shouldBe` Just 10
+ test/Test/Transaction.hs view
@@ -0,0 +1,285 @@+{- | Tests for "Kiroku.Store.Transaction" — the transactional escape+hatch and append combinators that let callers compose store operations+with arbitrary 'Hasql.Transaction.Transaction' work in one ACID+transaction.+-}+module Test.Transaction (spec) where++import Contravariant.Extras (contrazip2)+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int64)+import Data.Text (Text)+import Data.Time.Clock (getCurrentTime)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool (Pool)+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable, unpreparable)+import Hasql.Transaction qualified as Tx+import Kiroku.Store+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec++spec :: Spec+spec = around withTestStore $ do+    describe "runTransaction" $ do+        it "executes a no-op Tx.statement and returns its result" $ \store -> do+            result <-+                runStoreIO store $+                    runTransaction $+                        Tx.statement () selectOneStmt+            case result of+                Right n -> n `shouldBe` (1 :: Int)+                Left err -> expectationFailure ("Expected Right 1, got: " <> show err)++    describe "appendToStreamTx (driven inside runTransaction)" $ do+        it "appends events and a side-table row in one atomic transaction" $ \store -> do+            createSideTable (store ^. #pool)+            let evt = makeEvent "Created" (Aeson.object [("x", Aeson.Number 1)])+            prepared <- prepareEventsIO [evt]+            now <- getCurrentTime+            result <- runStoreIO store $ runTransaction $ do+                outcome <- appendToStreamTx (StreamName "txn-success-1") NoStream prepared now+                case outcome of+                    Left c -> pure (Left c)+                    Right ar -> do+                        let StreamId sid = ar ^. #streamId+                        Tx.statement (sid, "hello") insertSideRowStmt+                        pure (Right ar)+            case result of+                Right (Right ar) -> do+                    (ar ^. #streamVersion) `shouldBe` StreamVersion 1+                    rows <- countSideTable (store ^. #pool)+                    rows `shouldBe` 1+                other ->+                    expectationFailure+                        ("Expected Right (Right AppendResult), got: " <> show other)++        it "rolls back the append and the side row when the body condemns" $ \store -> do+            createSideTable (store ^. #pool)+            let evt = makeEvent "Created" (Aeson.object [])+            prepared <- prepareEventsIO [evt]+            now <- getCurrentTime+            result <- runStoreIO store $ runTransaction $ do+                outcome <- appendToStreamTx (StreamName "txn-condemn-1") NoStream prepared now+                case outcome of+                    Right ar -> do+                        let StreamId sid = ar ^. #streamId+                        Tx.statement (sid, "should-not-persist") insertSideRowStmt+                        Tx.condemn+                    Left _ -> Tx.condemn+            result `shouldBe` Right ()+            mInfo <- runStoreIO store $ getStream (StreamName "txn-condemn-1")+            mInfo `shouldBe` Right Nothing+            rows <- countSideTable (store ^. #pool)+            rows `shouldBe` 0++        it "returns Left on version conflict; the caller's branch sees no AppendResult" $ \store -> do+            createSideTable (store ^. #pool)+            -- Pre-populate the stream so the ExactVersion check below mismatches.+            _ <-+                runStoreIO store $+                    appendToStream+                        (StreamName "txn-conflict-1")+                        NoStream+                        [makeEvent "Created" (Aeson.object [])]+            prepared <- prepareEventsIO [makeEvent "Updated" (Aeson.object [])]+            now <- getCurrentTime+            result <- runStoreIO store $ runTransaction $ do+                outcome <-+                    appendToStreamTx+                        (StreamName "txn-conflict-1")+                        (ExactVersion (StreamVersion 99))+                        prepared+                        now+                case outcome of+                    Right _ -> do+                        Tx.statement (0 :: Int64, "should-not-run") insertSideRowStmt+                        pure outcome+                    Left _ -> pure outcome+            case result of+                Right (Left (WrongExpectedVersionConflict _ _ _)) -> pure ()+                other ->+                    expectationFailure+                        ("Expected Right (Left WrongExpectedVersionConflict), got: " <> show other)+            rows <- countSideTable (store ^. #pool)+            rows `shouldBe` 0++    describe "runTransactionAppending" $ do+        it "commits 3 events and a side-table row in one ACID transaction" $ \store -> do+            createSideTable (store ^. #pool)+            let evts =+                    [ makeEvent "Created" (Aeson.object [("i", Aeson.Number 1)])+                    , makeEvent "Updated" (Aeson.object [("i", Aeson.Number 2)])+                    , makeEvent "Closed" (Aeson.object [("i", Aeson.Number 3)])+                    ]+            result <-+                runStoreIO store $+                    runTransactionAppending+                        (StreamName "txn-wrapper-success-1")+                        NoStream+                        evts+                        ( \ar -> do+                            let StreamId sid = ar ^. #streamId+                            Tx.statement (sid, "projection") insertSideRowStmt+                            pure ar+                        )+            case result of+                Right (Right ar) ->+                    (ar ^. #streamVersion) `shouldBe` StreamVersion 3+                other ->+                    expectationFailure+                        ("Expected Right (Right AppendResult), got: " <> show other)+            -- Verify both the events and the side row landed.+            rows <- countSideTable (store ^. #pool)+            rows `shouldBe` 1+            mInfo <- runStoreIO store $ getStream (StreamName "txn-wrapper-success-1")+            case mInfo of+                Right (Just info) -> (info ^. #version) `shouldBe` StreamVersion 3+                other -> expectationFailure ("Expected stream with version 3, got: " <> show other)++        it "rolls back the append and the side row when the callback condemns" $ \store -> do+            createSideTable (store ^. #pool)+            result <-+                runStoreIO store $+                    runTransactionAppending+                        (StreamName "txn-wrapper-condemn-1")+                        NoStream+                        [makeEvent "Created" (Aeson.object [])]+                        ( \ar -> do+                            let StreamId sid = ar ^. #streamId+                            Tx.statement (sid, "should-not-persist") insertSideRowStmt+                            Tx.condemn+                            pure ar+                        )+            -- The callback ran and returned, so the wrapper sees Right; but the+            -- transaction was condemned, so neither write committed.+            case result of+                Right (Right _) -> pure ()+                other ->+                    expectationFailure+                        ("Expected Right (Right AppendResult), got: " <> show other)+            mInfo <- runStoreIO store $ getStream (StreamName "txn-wrapper-condemn-1")+            mInfo `shouldBe` Right Nothing+            rows <- countSideTable (store ^. #pool)+            rows `shouldBe` 0++        it "skips the callback and surfaces the version conflict" $ \store -> do+            createSideTable (store ^. #pool)+            -- Pre-populate the stream so ExactVersion 99 will mismatch.+            _ <-+                runStoreIO store $+                    appendToStream+                        (StreamName "txn-wrapper-conflict-1")+                        NoStream+                        [makeEvent "Created" (Aeson.object [])]+            calledRef <- newIORef (0 :: Int)+            result <-+                runStoreIO store $+                    runTransactionAppending+                        (StreamName "txn-wrapper-conflict-1")+                        (ExactVersion (StreamVersion 99))+                        [makeEvent "Updated" (Aeson.object [])]+                        ( \ar -> do+                            -- Tx.Transaction has no MonadIO; the IORef bump can't go+                            -- here. Instead, write a side row whose absence asserts+                            -- non-invocation.+                            let StreamId sid = ar ^. #streamId+                            Tx.statement (sid, "should-not-run") insertSideRowStmt+                            pure ar+                        )+            -- Bump the ref outside the Tx; assertion below proves the guard+            -- works: if the callback HAD run, the side row would exist.+            modifyIORef' calledRef (+ 1)+            n <- readIORef calledRef+            n `shouldBe` 1+            case result of+                Right (Left (WrongExpectedVersion _ _ _)) -> pure ()+                other ->+                    expectationFailure+                        ("Expected Right (Left WrongExpectedVersion), got: " <> show other)+            rows <- countSideTable (store ^. #pool)+            rows `shouldBe` 0++        it "rejects $all before opening any transaction" $ \store -> do+            createSideTable (store ^. #pool)+            result <-+                runStoreIO store $+                    runTransactionAppending+                        (StreamName "$all")+                        AnyVersion+                        [makeEvent "Should" (Aeson.object [])]+                        ( \ar -> do+                            let StreamId sid = ar ^. #streamId+                            Tx.statement (sid, "should-never-run") insertSideRowStmt+                            pure ar+                        )+            case result of+                Right (Left (ReservedStreamName (StreamName "$all"))) -> pure ()+                other ->+                    expectationFailure+                        ("Expected Right (Left (ReservedStreamName \"$all\")), got: " <> show other)+            rows <- countSideTable (store ^. #pool)+            rows `shouldBe` 0++-- ---------------------------------------------------------------------------+-- Local statements and pool-side helpers+-- ---------------------------------------------------------------------------++{- | Trivial @SELECT 1@ used to verify 'runTransaction' wiring without+depending on any schema state.+-}+selectOneStmt :: Statement () Int+selectOneStmt =+    preparable+        "SELECT 1::int4"+        E.noParams+        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int4)))++-- | DDL for the projection-row side table used by transaction tests.+createSideTableStmt :: Statement () ()+createSideTableStmt =+    unpreparable+        "CREATE TABLE IF NOT EXISTS test_side_table \+        \(id BIGINT PRIMARY KEY, payload TEXT NOT NULL)"+        E.noParams+        D.noResult++{- | Insert a row into the side table. The @id@ doubles as the foreign+key onto the stream the transaction appended to.+-}+insertSideRowStmt :: Statement (Int64, Text) ()+insertSideRowStmt =+    preparable+        "INSERT INTO test_side_table (id, payload) VALUES ($1, $2)"+        ( contrazip2+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++-- | Count rows in the side table.+countSideTableStmt :: Statement () Int64+countSideTableStmt =+    preparable+        "SELECT COUNT(*) FROM test_side_table"+        E.noParams+        (D.singleRow (D.column (D.nonNullable D.int8)))++createSideTable :: Pool -> IO ()+createSideTable pool = do+    r <- Pool.use pool (Session.statement () createSideTableStmt)+    case r of+        Left err -> error ("createSideTable failed: " <> show err)+        Right () -> pure ()++countSideTable :: Pool -> IO Int64+countSideTable pool = do+    r <- Pool.use pool (Session.statement () countSideTableStmt)+    case r of+        Left err -> error ("countSideTable failed: " <> show err)+        Right n -> pure n