diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 "", 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 .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. diff --git a/bench/Explain.hs b/bench/Explain.hs new file mode 100644 --- /dev/null +++ b/bench/Explain.hs @@ -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 (...) @ 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 (...) @ 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 diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 + } diff --git a/bench/ShibuyaOverhead.hs b/bench/ShibuyaOverhead.hs new file mode 100644 --- /dev/null +++ b/bench/ShibuyaOverhead.hs @@ -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 + } diff --git a/kiroku-store.cabal b/kiroku-store.cabal new file mode 100644 --- /dev/null +++ b/kiroku-store.cabal @@ -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 diff --git a/src/Kiroku/Store.hs b/src/Kiroku/Store.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store.hs @@ -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 diff --git a/src/Kiroku/Store/Append.hs b/src/Kiroku/Store/Append.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Append.hs @@ -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) diff --git a/src/Kiroku/Store/Causation.hs b/src/Kiroku/Store/Causation.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Causation.hs @@ -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)) diff --git a/src/Kiroku/Store/Connection.hs b/src/Kiroku/Store/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Connection.hs @@ -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 \, 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 \.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 \.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 <> "\"" diff --git a/src/Kiroku/Store/Effect.hs b/src/Kiroku/Store/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Effect.hs @@ -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. +-} diff --git a/src/Kiroku/Store/Effect/Resource.hs b/src/Kiroku/Store/Effect/Resource.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Effect/Resource.hs @@ -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) diff --git a/src/Kiroku/Store/Error.hs b/src/Kiroku/Store/Error.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Error.hs @@ -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 diff --git a/src/Kiroku/Store/Lifecycle.hs b/src/Kiroku/Store/Lifecycle.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Lifecycle.hs @@ -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) diff --git a/src/Kiroku/Store/Link.hs b/src/Kiroku/Store/Link.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Link.hs @@ -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) diff --git a/src/Kiroku/Store/Notification.hs b/src/Kiroku/Store/Notification.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Notification.hs @@ -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 @\.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 diff --git a/src/Kiroku/Store/Observability.hs b/src/Kiroku/Store/Observability.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Observability.hs @@ -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) diff --git a/src/Kiroku/Store/Read.hs b/src/Kiroku/Store/Read.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Read.hs @@ -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] diff --git a/src/Kiroku/Store/SQL.hs b/src/Kiroku/Store/SQL.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/SQL.hs @@ -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 + """ diff --git a/src/Kiroku/Store/Settings.hs b/src/Kiroku/Store/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Settings.hs @@ -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 diff --git a/src/Kiroku/Store/Subscription.hs b/src/Kiroku/Store/Subscription.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Subscription.hs @@ -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 diff --git a/src/Kiroku/Store/Subscription/Effect.hs b/src/Kiroku/Store/Subscription/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Subscription/Effect.hs @@ -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 diff --git a/src/Kiroku/Store/Subscription/EventPublisher.hs b/src/Kiroku/Store/Subscription/EventPublisher.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Subscription/EventPublisher.hs @@ -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 diff --git a/src/Kiroku/Store/Subscription/Fsm.hs b/src/Kiroku/Store/Subscription/Fsm.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Subscription/Fsm.hs @@ -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, []) diff --git a/src/Kiroku/Store/Subscription/Stream.hs b/src/Kiroku/Store/Subscription/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Subscription/Stream.hs @@ -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) diff --git a/src/Kiroku/Store/Subscription/Types.hs b/src/Kiroku/Store/Subscription/Types.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Subscription/Types.hs @@ -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) diff --git a/src/Kiroku/Store/Subscription/Worker.hs b/src/Kiroku/Store/Subscription/Worker.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Subscription/Worker.hs @@ -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 () diff --git a/src/Kiroku/Store/Transaction.hs b/src/Kiroku/Store/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Transaction.hs @@ -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) diff --git a/src/Kiroku/Store/Types.hs b/src/Kiroku/Store/Types.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Store/Types.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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"] diff --git a/test/Test/CatchupDbErrorNoPrematureSwitch.hs b/test/Test/CatchupDbErrorNoPrematureSwitch.hs new file mode 100644 --- /dev/null +++ b/test/Test/CatchupDbErrorNoPrematureSwitch.hs @@ -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 diff --git a/test/Test/CategoryIdleNoSpin.hs b/test/Test/CategoryIdleNoSpin.hs new file mode 100644 --- /dev/null +++ b/test/Test/CategoryIdleNoSpin.hs @@ -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 diff --git a/test/Test/Causation.hs b/test/Test/Causation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Causation.hs @@ -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) diff --git a/test/Test/Concurrency.hs b/test/Test/Concurrency.hs new file mode 100644 --- /dev/null +++ b/test/Test/Concurrency.hs @@ -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 diff --git a/test/Test/ConsumerGroup.hs b/test/Test/ConsumerGroup.hs new file mode 100644 --- /dev/null +++ b/test/Test/ConsumerGroup.hs @@ -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 diff --git a/test/Test/ConsumerGroupEffect.hs b/test/Test/ConsumerGroupEffect.hs new file mode 100644 --- /dev/null +++ b/test/Test/ConsumerGroupEffect.hs @@ -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] diff --git a/test/Test/ConsumerGroupSql.hs b/test/Test/ConsumerGroupSql.hs new file mode 100644 --- /dev/null +++ b/test/Test/ConsumerGroupSql.hs @@ -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 diff --git a/test/Test/EventTypeFilter.hs b/test/Test/EventTypeFilter.hs new file mode 100644 --- /dev/null +++ b/test/Test/EventTypeFilter.hs @@ -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 diff --git a/test/Test/FailureInjection.hs b/test/Test/FailureInjection.hs new file mode 100644 --- /dev/null +++ b/test/Test/FailureInjection.hs @@ -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 diff --git a/test/Test/Helpers.hs b/test/Test/Helpers.hs new file mode 100644 --- /dev/null +++ b/test/Test/Helpers.hs @@ -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 diff --git a/test/Test/InterpreterHooks.hs b/test/Test/InterpreterHooks.hs new file mode 100644 --- /dev/null +++ b/test/Test/InterpreterHooks.hs @@ -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 diff --git a/test/Test/Properties.hs b/test/Test/Properties.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties.hs @@ -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" diff --git a/test/Test/PublisherRestartNoRebroadcast.hs b/test/Test/PublisherRestartNoRebroadcast.hs new file mode 100644 --- /dev/null +++ b/test/Test/PublisherRestartNoRebroadcast.hs @@ -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 diff --git a/test/Test/ReadStream.hs b/test/Test/ReadStream.hs new file mode 100644 --- /dev/null +++ b/test/Test/ReadStream.hs @@ -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) diff --git a/test/Test/StreamNameLookup.hs b/test/Test/StreamNameLookup.hs new file mode 100644 --- /dev/null +++ b/test/Test/StreamNameLookup.hs @@ -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 diff --git a/test/Test/SubscriptionPauseResume.hs b/test/Test/SubscriptionPauseResume.hs new file mode 100644 --- /dev/null +++ b/test/Test/SubscriptionPauseResume.hs @@ -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) diff --git a/test/Test/SubscriptionReconnect.hs b/test/Test/SubscriptionReconnect.hs new file mode 100644 --- /dev/null +++ b/test/Test/SubscriptionReconnect.hs @@ -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 diff --git a/test/Test/SubscriptionRegistry.hs b/test/Test/SubscriptionRegistry.hs new file mode 100644 --- /dev/null +++ b/test/Test/SubscriptionRegistry.hs @@ -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 diff --git a/test/Test/SubscriptionRetryDeadLetter.hs b/test/Test/SubscriptionRetryDeadLetter.hs new file mode 100644 --- /dev/null +++ b/test/Test/SubscriptionRetryDeadLetter.hs @@ -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 diff --git a/test/Test/SubscriptionState.hs b/test/Test/SubscriptionState.hs new file mode 100644 --- /dev/null +++ b/test/Test/SubscriptionState.hs @@ -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 diff --git a/test/Test/Transaction.hs b/test/Test/Transaction.hs new file mode 100644 --- /dev/null +++ b/test/Test/Transaction.hs @@ -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