diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,53 @@ # Changelog +## 0.12.0.0 — 2026-10-26 + +### Breaking Changes + +- `SubscriptionTarget` gains `CategoryNamespace Text`; update exhaustive matches. + Apply migration 0016 from kiroku-store-migrations 0.7.2.0 with affected workers + stopped before using namespace subscriptions. Older binaries must not manage + namespace bindings. +- `KirokuEvent` gains `KirokuEventSubscriptionTargetMismatch`; update exhaustive + observers. +- In the exposed low-level modules, `Notifier` gains `namespaceRegistry`; + complete record constructors must supply it. FSM `Input` gains + `NamespaceWindowFetched` and `NamespaceWindowCompleted`, and FSM `Effect` gains + `DeliverNamespaceWindow`; update exhaustive custom drivers. + +### New Features + +- Add exact-category/colon-boundary namespace fan-in, including future categories + and consumer groups. Workers scan bounded global windows, decode matching + payloads only, checkpoint completed scans, and share selective namespace wakes. +- Expose namespace registration and notification helpers and bounded namespace + window/checkpoint SQL statements for low-level integrations. + +### Bug Fixes + +- Invalid stall intervals emit one crashed `Stopped` before `wait` returns. + Target refusals emit their typed detail event followed by one crashed stop. +- Preserve the initial event filter and selector decision across decode retries, + including recovery to an excluded rewritten type. +- Low-level checkpoint initialization inherits uniform sibling size and binding + under the topology lock, preserving existing rows and missing-position policies. +- Avoid payload probes for empty namespace windows. + +### Other Changes + +- Sparse namespace replay traverses global history independently per worker; + namespace checkpoints can advance beyond the last delivered matching event. +- Retain the namespace cohort's explicit practical performance acceptance: + 20 verified comparison trials, five pairs per case. The statistical + zero-slowdown verdicts remain inconclusive; historical replay throughput was + not measured. See `bench/results/ep54-kenshou/README.md` and `acceptance.json`. +- Tighten append workload measurement validation and retain the inspection + cohort's accepted write-cost evidence. +- Correct omitted source-compatibility changes in the 0.10.0.0 and 0.11.0.0 notes. +- Require [shibuya-core](mori://shinzui/shibuya/packages/shibuya-core) + `>=0.12 && <0.13` in the Shibuya overhead benchmark and initialize its deliveries + with `DeliveryCurrent`. + ## 0.11.0.1 — 2026-10-20 ### Bug Fixes @@ -41,7 +89,19 @@ - Byte-ordered stream browsing with exact category, literal prefix and exclusive name cursors; paged category enumeration and canonical event lookup by id. +### Erratum — 2026-10-25 +The published 0.11.0.0 notes omitted this source-compatibility break; the Hackage +copy cannot be updated: + +- `SubscriptionDeadLetter` and `SubscriptionDeadLetterQuery` add exported record + selectors `eventId`, `globalPosition`, `after` and `limit` through `Kiroku.Store` + under `DuplicateRecordFields`. Bare uses of those names on `RecordedEvent` or + `HistoryRetentionInventoryQuery` can now fail with ambiguous-occurrence errors. + Disambiguate field access or narrow imports; the repository's `Worker.hs` needed + `hiding (eventId, globalPosition)` on its conflicting import. + + ## 0.10.0.0 — 2026-10-10 ### Breaking Changes @@ -84,6 +144,37 @@ `DuplicateEvent` with a parseable caller ID. `ux_stream_events_stream_version` returns `UnexpectedServerError "23505"` with the original message for an invariant failure. Unknown append constraints retain the expected-version fallback. + +### Erratum — 2026-10-25 + +The published 0.10.0.0 notes omitted or only implied the following breaking +changes; the Hackage copy cannot be updated: + +- `SubscriptionConfigM` also gains `targetBindingPolicy` (default `AdoptUnbound`), + and `batchSize` changes from `Int32` to validated `BatchSize`. Complete record + constructors must supply the new field; construct batch sizes with `mkBatchSize`. +- `subscriptionStream` and `subscriptionAckStream` take validated + `StreamBufferSize` in place of their previous numeric buffer-capacity parameter; + use `mkStreamBufferSize`. +- `StoreError.EventDecodeFailed` and + `DeadLetterReason.DeadLetterDecodeFailure`, mentioned above as features, also + require updates to exhaustive matches. Observer matches must additionally + handle the new `KirokuEvent.KirokuEventSubscriptionTargetBound` constructor. +- `InvalidConsumerGroup` and `InvalidStreamBufferSize` lose their `Exception` + instances. Handle construction failures as `Left` values from the validated + constructors; `subscribe`, `subscriptionAckStream` and + `kirokuConsumerGroupProcessors` no longer throw those errors. +- Exposed `Kiroku.Store.Subscription.Fsm` constructors change payloads: + `ConnectionLost` carries a `GlobalPosition`, and `BatchFetched` and + `DeliverBatch` carry `DecodedBatch`. +- In exposed `Kiroku.Store.Subscription.EventPublisher`, `subscribePublisher` + returns a `TBQueue DecodedBatch` in its result. Exposed + `Kiroku.Store.Subscription.Worker.LiveFromPublisherQueue` likewise takes a + `TBQueue DecodedBatch`. +- In exposed `Kiroku.Store.SQL`, `saveCheckpointMemberStmt` takes the six-tuple + `(Text, Int32, Int64, Int32, Text, Maybe Text)`. `DeadLetterParams` gains + `dlTargetKind`, `dlTargetCategory` and `dlGroupSize`; update direct callers and + complete record constructors. ## 0.9.0.1 — 2026-09-25 diff --git a/bench/CheckpointTargetCost.hs b/bench/CheckpointTargetCost.hs --- a/bench/CheckpointTargetCost.hs +++ b/bench/CheckpointTargetCost.hs @@ -1,10 +1,9 @@ {-# LANGUAGE MultilineStrings #-} {-# LANGUAGE OverloadedRecordDot #-} -{- | Small supplementary EP-2 comparison of the changed checkpoint-save path. -No acceptance threshold: local ratios retain their uncertainty. The control -statement and row layout are from 23a03a1b8b56773a140d0683c4c8d4d34b9d7e36. --} +-- | Small supplementary EP-2 comparison of the changed checkpoint-save path. +-- No acceptance threshold: local ratios retain their uncertainty. The control +-- statement and row layout are from 23a03a1b8b56773a140d0683c4c8d4d34b9d7e36. module Main where import Contravariant.Extras (contrazip4) @@ -27,60 +26,60 @@ main :: IO () main = do - original <- ephemeralConfig - let keys = ["fsync", "synchronous_commit", "full_page_writes", "shared_buffers", "wal_level"] - durable = original{Pg.postgresSettings = filter (\(key, _) -> key `notElem` keys) original.postgresSettings <> [("fsync", "on"), ("synchronous_commit", "on"), ("full_page_writes", "on"), ("shared_buffers", "128MB"), ("wal_level", "replica")]} - result <- Pg.withCachedConfig durable Pg.defaultCacheConfig $ \database -> do - let connection = Pg.connectionString database - migrateTestDatabase connection - withStore (defaultConnectionSettings connection) measure - either (fail . show) pure result + original <- ephemeralConfig + let keys = ["fsync", "synchronous_commit", "full_page_writes", "shared_buffers", "wal_level"] + durable = original {Pg.postgresSettings = filter (\(key, _) -> key `notElem` keys) original.postgresSettings <> [("fsync", "on"), ("synchronous_commit", "on"), ("full_page_writes", "on"), ("shared_buffers", "128MB"), ("wal_level", "replica")]} + result <- Pg.withCachedConfig durable Pg.defaultCacheConfig $ \database -> do + let connection = Pg.connectionString database + migrateTestDatabase connection + withStore (defaultConnectionSettings connection) measure + either (fail . show) pure result measure :: KirokuStore -> IO () measure store = do - settings <- use store $ Session.statement () (preparable "SELECT current_setting('server_version_num')::int4 >= 180000 AND current_setting('server_version_num')::int4 < 190000 AND current_setting('fsync') = 'on' AND current_setting('synchronous_commit') = 'on' AND current_setting('full_page_writes') = 'on'" E.noParams (D.singleRow (D.column (D.nonNullable D.bool)))) - if settings then pure () else fail "requires durable PostgreSQL 18" - use store $ - Session.script - """ - CREATE SCHEMA ep2_control; - CREATE TABLE ep2_control.subscriptions ( - subscription_id BIGSERIAL PRIMARY KEY, - subscription_name TEXT NOT NULL, - stream_name TEXT NOT NULL DEFAULT '$all', - last_seen BIGINT NOT NULL DEFAULT 0, - consumer_group_member INT NOT NULL DEFAULT 0, - consumer_group_size INT NOT NULL DEFAULT 1, - created_at TIMESTAMPTZ NOT NULL DEFAULT now(), - updated_at TIMESTAMPTZ NOT NULL DEFAULT now() - ); - CREATE UNIQUE INDEX ON ep2_control.subscriptions (subscription_name, consumer_group_member); - """ - controlCounter <- newIORef 0 - candidateCounter <- newIORef 0 - let save candidate = do - p <- atomicModifyIORef' (if candidate then candidateCounter else controlCounter) (\n -> (n + 1, n + 1)) - let m = fromIntegral (p `mod` 4) - if candidate - then use store $ Session.statement ("target-cost", m, p, 4, "performance") SQL.saveCategoryCheckpointMemberStmt - else use store $ Session.statement ("target-cost", m, p, 4) controlSave - trial pair candidate = do - walBefore <- use store (Session.statement () walPosition) - start <- getMonotonicTimeNSec - replicateM_ 2000 (save candidate) - end <- getMonotonicTimeNSec - walAfter <- use store (Session.statement () walPosition) - putStrLn $ show pair <> "," <> (if candidate then "candidate" else "control") <> ",2000," <> show (fromIntegral (end - start) / 2000 :: Double) <> "," <> show (fromIntegral (walAfter - walBefore) / 2000 :: Double) - replicateM_ 200 (save False >> save True) - putStrLn "pair,arm,saves,ns_per_save,wal_bytes_per_save" - forM_ [1 .. 3 :: Int] $ \pair -> - if odd pair - then trial pair False >> trial pair True - else trial pair True >> trial pair False - -- Every completed save advances one durable member; both arms do equal work. - expected <- use store $ Session.statement () (preparable "SELECT count(*) = 4 AND sum(last_seen) = 24794 FROM ep2_control.subscriptions" E.noParams (D.singleRow (D.column (D.nonNullable D.bool)))) - actual <- use store $ Session.statement () (preparable "SELECT count(*) = 4 AND sum(last_seen) = 24794 AND bool_and(target_kind = 'category' AND target_category = 'performance') FROM kiroku.subscriptions WHERE subscription_name = 'target-cost'" E.noParams (D.singleRow (D.column (D.nonNullable D.bool)))) - if expected && actual then putStrLn "durable equal-work checks: passed" else fail "durable equal-work checks failed" + settings <- use store $ Session.statement () (preparable "SELECT current_setting('server_version_num')::int4 >= 180000 AND current_setting('server_version_num')::int4 < 190000 AND current_setting('fsync') = 'on' AND current_setting('synchronous_commit') = 'on' AND current_setting('full_page_writes') = 'on'" E.noParams (D.singleRow (D.column (D.nonNullable D.bool)))) + if settings then pure () else fail "requires durable PostgreSQL 18" + use store $ + Session.script + """ + CREATE SCHEMA ep2_control; + CREATE TABLE ep2_control.subscriptions ( + subscription_id BIGSERIAL PRIMARY KEY, + subscription_name TEXT NOT NULL, + stream_name TEXT NOT NULL DEFAULT '$all', + last_seen BIGINT NOT NULL DEFAULT 0, + consumer_group_member INT NOT NULL DEFAULT 0, + consumer_group_size INT NOT NULL DEFAULT 1, + created_at TIMESTAMPTZ NOT NULL DEFAULT now(), + updated_at TIMESTAMPTZ NOT NULL DEFAULT now() + ); + CREATE UNIQUE INDEX ON ep2_control.subscriptions (subscription_name, consumer_group_member); + """ + controlCounter <- newIORef 0 + candidateCounter <- newIORef 0 + let save candidate = do + p <- atomicModifyIORef' (if candidate then candidateCounter else controlCounter) (\n -> (n + 1, n + 1)) + let m = fromIntegral (p `mod` 4) + if candidate + then use store $ Session.statement ("target-cost", m, p, 4, "performance") SQL.saveCategoryCheckpointMemberStmt + else use store $ Session.statement ("target-cost", m, p, 4) controlSave + trial pair candidate = do + walBefore <- use store (Session.statement () walPosition) + start <- getMonotonicTimeNSec + replicateM_ 2000 (save candidate) + end <- getMonotonicTimeNSec + walAfter <- use store (Session.statement () walPosition) + putStrLn $ show pair <> "," <> (if candidate then "candidate" else "control") <> ",2000," <> show (fromIntegral (end - start) / 2000 :: Double) <> "," <> show (fromIntegral (walAfter - walBefore) / 2000 :: Double) + replicateM_ 200 (save False >> save True) + putStrLn "pair,arm,saves,ns_per_save,wal_bytes_per_save" + forM_ [1 .. 3 :: Int] $ \pair -> + if odd pair + then trial pair False >> trial pair True + else trial pair True >> trial pair False + -- Every completed save advances one durable member; both arms do equal work. + expected <- use store $ Session.statement () (preparable "SELECT count(*) = 4 AND sum(last_seen) = 24794 FROM ep2_control.subscriptions" E.noParams (D.singleRow (D.column (D.nonNullable D.bool)))) + actual <- use store $ Session.statement () (preparable "SELECT count(*) = 4 AND sum(last_seen) = 24794 AND bool_and(target_kind = 'category' AND target_category = 'performance') FROM kiroku.subscriptions WHERE subscription_name = 'target-cost'" E.noParams (D.singleRow (D.column (D.nonNullable D.bool)))) + if expected && actual then putStrLn "durable equal-work checks: passed" else fail "durable equal-work checks failed" use :: KirokuStore -> Session.Session a -> IO a use store session = Pool.use (store ^. #pool) session >>= either (fail . show) pure @@ -90,12 +89,12 @@ controlSave :: Statement (Text, Int32, Int64, Int32) () controlSave = - preparable - """ - INSERT INTO ep2_control.subscriptions (subscription_name, consumer_group_member, last_seen, updated_at, consumer_group_size) - VALUES ($1, $2, $3, now(), $4) - ON CONFLICT (subscription_name, consumer_group_member) - DO UPDATE SET last_seen = GREATEST(subscriptions.last_seen, EXCLUDED.last_seen), updated_at = now(), consumer_group_size = EXCLUDED.consumer_group_size - """ - (contrazip4 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.int4)) (E.param (E.nonNullable E.int8)) (E.param (E.nonNullable E.int4))) - D.noResult + preparable + """ + INSERT INTO ep2_control.subscriptions (subscription_name, consumer_group_member, last_seen, updated_at, consumer_group_size) + VALUES ($1, $2, $3, now(), $4) + ON CONFLICT (subscription_name, consumer_group_member) + DO UPDATE SET last_seen = GREATEST(subscriptions.last_seen, EXCLUDED.last_seen), updated_at = now(), consumer_group_size = EXCLUDED.consumer_group_size + """ + (contrazip4 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.int4)) (E.param (E.nonNullable E.int8)) (E.param (E.nonNullable E.int4))) + D.noResult diff --git a/bench/Explain.hs b/bench/Explain.hs --- a/bench/Explain.hs +++ b/bench/Explain.hs @@ -1,27 +1,26 @@ {-# LANGUAGE MultilineStrings #-} -{- | PostgreSQL-side append profiling harness. - -Two modes: - - * default — boots a cached ephemeral PostgreSQL via 'Pg.withCachedConfig', 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@. --} +-- | PostgreSQL-side append profiling harness. +-- +-- Two modes: +-- +-- * default — boots a cached ephemeral PostgreSQL via 'Pg.withCachedConfig', 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) @@ -61,179 +60,173 @@ -- --------------------------------------------------------------------------- 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) + { 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)) + ((^. #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, category, 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, category) - SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category - 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 - """ + """ + 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, category, 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, category) + SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category + 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. --} +-- | 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))) + unpreparable + sql + appendParamsEncoder + (D.rowList (D.column (D.nonNullable D.text))) where sql = - "EXPLAIN (ANALYZE, BUFFERS, TIMING, FORMAT TEXT)\n" - <> appendAnyVersionSQL + "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. --} +-- | 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)))) + unpreparable + sql + appendParamsEncoder + (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right)))) where sql = - "EXPLAIN (ANALYZE, BUFFERS, TIMING, FORMAT JSON)\n" - <> appendAnyVersionSQL + "EXPLAIN (ANALYZE, BUFFERS, TIMING, FORMAT JSON)\n" + <> appendAnyVersionSQL -{- | One-event 'AppendParams' for an @AnyVersion@ append against a fresh -stream name. --} +-- | 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) - } + 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. --} +-- | 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 + 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. --} +-- | 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 + 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\/@). --} +-- | 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 + 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 + 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" @@ -256,174 +249,172 @@ 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 ===" - config <- ephemeralConfig - result <- Pg.withCachedConfig config Pg.defaultCacheConfig $ \db -> do - let settings = defaultConnectionSettings (Pg.connectionString db) - withStore settings $ \store -> do - paramsText <- mkSampleParams - paramsJson <- mkSampleParams + 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 ===" + config <- ephemeralConfig + result <- Pg.withCachedConfig config Pg.defaultCacheConfig $ \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 "=== 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 ("=== 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 () + 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. --} +-- | 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 res1 = case r1 of - Right ok -> ok - Left e -> error ("AnyVersion append failed: " <> show e) - -- 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 + let sn = StreamName "explain-auto" + -- AnyVersion append: hits the appendAnyVersionSQL CTE. + r1 <- runStoreIO store $ appendToStream sn AnyVersion [mkEvent "Created"] + forceOk "AnyVersion" r1 + let res1 = case r1 of + Right ok -> ok + Left e -> error ("AnyVersion append failed: " <> show e) + -- 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 + 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 () + 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'") - ] - base <- ephemeralConfig - let cfg = - base - <> 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 + 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'") + ] + base <- ephemeralConfig + let cfg = + base + <> 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. --} +-- | 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 + r <- Pool.use (store ^. #pool) session + case r of + Left e -> error ("Hasql.Pool.use failed: " <> show e) + Right a -> pure a -- --------------------------------------------------------------------------- -- main @@ -431,8 +422,8 @@ main :: IO () main = do - hSetBuffering stdout LineBuffering - args <- getArgs - if "--auto-explain" `elem` args - then runAutoExplain - else runExplainAnalyze + hSetBuffering stdout LineBuffering + args <- getArgs + if "--auto-explain" `elem` args + then runAutoExplain + else runExplainAnalyze diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -32,992 +32,985 @@ 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, category, 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, category) - SELECT ne.event_id, 0, au.initial_global_version + 1, su.stream_id, su.initial_version + 1, su.category - 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, category, 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, category) - SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category - 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, category, 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, category) - SELECT $2::uuid, 0, au.initial_global_version + 1, su.stream_id, su.initial_version + 1, su.category - 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, category, 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, category) - SELECT $2::uuid, 0, au.initial_global_version + 1, si.stream_id, si.initial_version + 1, si.category - 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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) - -seedCheckpointInventoryStmt :: Statement Int32 () -seedCheckpointInventoryStmt = - preparable - """ - INSERT INTO subscriptions ( - subscription_name, - consumer_group_member, - last_seen, - updated_at - ) - SELECT 'inventory-' || lpad(n::text, 8, '0'), - 0, - 0, - now() - FROM generate_series(1, $1::int4) AS n - """ - (E.param (E.nonNullable E.int4)) - D.noResult - -seedCheckpointInventory :: KirokuStore -> Int32 -> IO () -seedCheckpointInventory store rowCount = do - result <- Pool.use (store ^. #pool) $ Session.statement rowCount seedCheckpointInventoryStmt - case result of - Left err -> error ("Checkpoint inventory benchmark setup failed: " <> show err) - Right () -> pure () - -forceCheckpointInventory :: Either StoreError SubscriptionCheckpointInventory -> IO () -forceCheckpointInventory (Left err) = error ("Checkpoint inventory benchmark failed: " <> show err) -forceCheckpointInventory (Right (SubscriptionCheckpointInventory (GlobalPosition storePos) rows)) = do - let !checksum = V.foldl' forceCheckpoint (fromIntegral storePos) rows - checksum `seq` pure () - where - forceCheckpoint !acc (SubscriptionCheckpoint (SubscriptionName name) member (GlobalPosition position) updatedAt) = - updatedAt `seq` - acc - + T.length name - + fromIntegral member - + fromIntegral position - -runCheckpointInventoryBenchmark :: KirokuStore -> IO () -runCheckpointInventoryBenchmark store = - runStoreIO store subscriptionCheckpointInventory >>= forceCheckpointInventory - -withInventoryBenchmarkStores :: (KirokuStore -> KirokuStore -> IO a) -> IO a -withInventoryBenchmarkStores action = - withSharedMigratedPostgres $ - withMigratedTestDatabase $ \inventory100Connection -> - withMigratedTestDatabase $ \inventory10000Connection -> - withStore (defaultConnectionSettings inventory100Connection) $ \inventory100Store -> - withStore (defaultConnectionSettings inventory10000Connection) $ \inventory10000Store -> do - seedCheckpointInventory inventory100Store 100 - seedCheckpointInventory inventory10000Store 10_000 - action inventory100Store inventory10000Store - -{- | A store seeded with 'categoryScalingFixtureSql': categories @performance@ -(200 streams), @idle@ (20,000 single-event streams), and @noise@, head at -'categoryScalingHead'. Must run inside 'withSharedMigratedPostgres'. --} -withCategoryScalingStore :: (KirokuStore -> IO a) -> IO a -withCategoryScalingStore action = - withMigratedTestDatabase $ \connection -> - withStore (defaultConnectionSettings connection) $ \store -> do - seeded <- Pool.use (store ^. #pool) (Session.script categoryScalingFixtureSql) - case seeded of - Left err -> error ("Category-scaling benchmark setup failed: " <> show err) - Right () -> action store - --- | Run the plain category read 10 times at one cursor and limit. -runCategoryPolls :: KirokuStore -> Text -> Int64 -> Int32 -> IO () -runCategoryPolls store category cursor limit = - mapM_ - ( \_ -> - Pool.use (store ^. #pool) (Session.statement (cursor, category, limit) SQL.readCategoryForwardStmt) - >>= forceCategoryPoll - ) - [1 .. 10 :: Int] - --- | Run the consumer-group category read 10 times for one member. -runGroupCategoryPolls :: KirokuStore -> Text -> Int64 -> Int32 -> Int32 -> Int32 -> IO () -runGroupCategoryPolls store category cursor member size limit = - mapM_ - ( \_ -> - Pool.use (store ^. #pool) (Session.statement (cursor, category, member, size, limit) SQL.readCategoryForwardConsumerGroupStmt) - >>= forceCategoryPoll - ) - [1 .. 10 :: Int] - -forceCategoryPoll :: Either Pool.UsageError (V.Vector RecordedEvent) -> IO () -forceCategoryPoll (Right events) = V.length events `seq` pure () -forceCategoryPoll (Left err) = error ("Category-scaling benchmark read failed: " <> show err) - -main :: IO () -main = do - -- Start ephemeral PostgreSQL once for all benchmarks - config <- ephemeralConfig - result <- Pg.withCachedConfig config Pg.defaultCacheConfig $ \db -> do - migrateTestDatabase (Pg.connectionString db) - 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) - - withInventoryBenchmarkStores $ \inventory100Store inventory10000Store -> - withCategoryScalingStore $ \scalingStore -> - 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 res0 = case r0 of - Right ok -> ok - Left e -> error ("Sequential append failed: " <> show e) - 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 - ] - , -- BUG-2: a caught-up category poll must not cost work - -- proportional to the number of streams in the category. - -- Each cell runs the statement 10 times. - bgroup - "category-scaling" - [ bench "plain caught-up poll (200 streams)" $ - whnfIO $ - runCategoryPolls scalingStore "performance" categoryScalingHead 100 - , bench "plain caught-up poll (20000 streams)" $ - whnfIO $ - runCategoryPolls scalingStore "idle" categoryScalingHead 100 - , bench "group caught-up poll (20000 streams)" $ - whnfIO $ - runGroupCategoryPolls scalingStore "idle" categoryScalingHead 1 2 100 - , bench "plain page from 0 (20000 streams)" $ - whnfIO $ - runCategoryPolls scalingStore "idle" 0 100 - , bench "exhausted category (200 streams)" $ - -- performance ends at 20,000; 60,000 other rows follow. - whnfIO $ - runCategoryPolls scalingStore "performance" 20_000 100 - ] - , bgroup - "subscription-checkpoint-inventory" - [ bench "100 rows" $ whnfIO $ runCheckpointInventoryBenchmark inventory100Store - , bench "10000 rows" $ whnfIO $ runCheckpointInventoryBenchmark inventory10000Store - ] - ] - 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 - } + { 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, category, 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, category) + SELECT ne.event_id, 0, au.initial_global_version + 1, su.stream_id, su.initial_version + 1, su.category + 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, category, 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, category) + SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category + 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, category, 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, category) + SELECT $2::uuid, 0, au.initial_global_version + 1, su.stream_id, su.initial_version + 1, su.category + 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, category, 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, category) + SELECT $2::uuid, 0, au.initial_global_version + 1, si.stream_id, si.initial_version + 1, si.category + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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) + +seedCheckpointInventoryStmt :: Statement Int32 () +seedCheckpointInventoryStmt = + preparable + """ + INSERT INTO subscriptions ( + subscription_name, + consumer_group_member, + last_seen, + updated_at + ) + SELECT 'inventory-' || lpad(n::text, 8, '0'), + 0, + 0, + now() + FROM generate_series(1, $1::int4) AS n + """ + (E.param (E.nonNullable E.int4)) + D.noResult + +seedCheckpointInventory :: KirokuStore -> Int32 -> IO () +seedCheckpointInventory store rowCount = do + result <- Pool.use (store ^. #pool) $ Session.statement rowCount seedCheckpointInventoryStmt + case result of + Left err -> error ("Checkpoint inventory benchmark setup failed: " <> show err) + Right () -> pure () + +forceCheckpointInventory :: Either StoreError SubscriptionCheckpointInventory -> IO () +forceCheckpointInventory (Left err) = error ("Checkpoint inventory benchmark failed: " <> show err) +forceCheckpointInventory (Right (SubscriptionCheckpointInventory (GlobalPosition storePos) rows)) = do + let !checksum = V.foldl' forceCheckpoint (fromIntegral storePos) rows + checksum `seq` pure () + where + forceCheckpoint !acc (SubscriptionCheckpoint (SubscriptionName name) member (GlobalPosition position) updatedAt) = + updatedAt `seq` + acc + + T.length name + + fromIntegral member + + fromIntegral position + +runCheckpointInventoryBenchmark :: KirokuStore -> IO () +runCheckpointInventoryBenchmark store = + runStoreIO store subscriptionCheckpointInventory >>= forceCheckpointInventory + +withInventoryBenchmarkStores :: (KirokuStore -> KirokuStore -> IO a) -> IO a +withInventoryBenchmarkStores action = + withSharedMigratedPostgres $ + withMigratedTestDatabase $ \inventory100Connection -> + withMigratedTestDatabase $ \inventory10000Connection -> + withStore (defaultConnectionSettings inventory100Connection) $ \inventory100Store -> + withStore (defaultConnectionSettings inventory10000Connection) $ \inventory10000Store -> do + seedCheckpointInventory inventory100Store 100 + seedCheckpointInventory inventory10000Store 10_000 + action inventory100Store inventory10000Store + +-- | A store seeded with 'categoryScalingFixtureSql': categories @performance@ +-- (200 streams), @idle@ (20,000 single-event streams), and @noise@, head at +-- 'categoryScalingHead'. Must run inside 'withSharedMigratedPostgres'. +withCategoryScalingStore :: (KirokuStore -> IO a) -> IO a +withCategoryScalingStore action = + withMigratedTestDatabase $ \connection -> + withStore (defaultConnectionSettings connection) $ \store -> do + seeded <- Pool.use (store ^. #pool) (Session.script categoryScalingFixtureSql) + case seeded of + Left err -> error ("Category-scaling benchmark setup failed: " <> show err) + Right () -> action store + +-- | Run the plain category read 10 times at one cursor and limit. +runCategoryPolls :: KirokuStore -> Text -> Int64 -> Int32 -> IO () +runCategoryPolls store category cursor limit = + mapM_ + ( \_ -> + Pool.use (store ^. #pool) (Session.statement (cursor, category, limit) SQL.readCategoryForwardStmt) + >>= forceCategoryPoll + ) + [1 .. 10 :: Int] + +-- | Run the consumer-group category read 10 times for one member. +runGroupCategoryPolls :: KirokuStore -> Text -> Int64 -> Int32 -> Int32 -> Int32 -> IO () +runGroupCategoryPolls store category cursor member size limit = + mapM_ + ( \_ -> + Pool.use (store ^. #pool) (Session.statement (cursor, category, member, size, limit) SQL.readCategoryForwardConsumerGroupStmt) + >>= forceCategoryPoll + ) + [1 .. 10 :: Int] + +forceCategoryPoll :: Either Pool.UsageError (V.Vector RecordedEvent) -> IO () +forceCategoryPoll (Right events) = V.length events `seq` pure () +forceCategoryPoll (Left err) = error ("Category-scaling benchmark read failed: " <> show err) + +main :: IO () +main = do + -- Start ephemeral PostgreSQL once for all benchmarks + config <- ephemeralConfig + result <- Pg.withCachedConfig config Pg.defaultCacheConfig $ \db -> do + migrateTestDatabase (Pg.connectionString db) + 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) + + withInventoryBenchmarkStores $ \inventory100Store inventory10000Store -> + withCategoryScalingStore $ \scalingStore -> + 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 res0 = case r0 of + Right ok -> ok + Left e -> error ("Sequential append failed: " <> show e) + 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 + ], + -- BUG-2: a caught-up category poll must not cost work + -- proportional to the number of streams in the category. + -- Each cell runs the statement 10 times. + bgroup + "category-scaling" + [ bench "plain caught-up poll (200 streams)" $ + whnfIO $ + runCategoryPolls scalingStore "performance" categoryScalingHead 100, + bench "plain caught-up poll (20000 streams)" $ + whnfIO $ + runCategoryPolls scalingStore "idle" categoryScalingHead 100, + bench "group caught-up poll (20000 streams)" $ + whnfIO $ + runGroupCategoryPolls scalingStore "idle" categoryScalingHead 1 2 100, + bench "plain page from 0 (20000 streams)" $ + whnfIO $ + runCategoryPolls scalingStore "idle" 0 100, + bench "exhausted category (200 streams)" $ + -- performance ends at 20,000; 60,000 other rows follow. + whnfIO $ + runCategoryPolls scalingStore "performance" 20_000 100 + ], + bgroup + "subscription-checkpoint-inventory" + [ bench "100 rows" $ whnfIO $ runCheckpointInventoryBenchmark inventory100Store, + bench "10000 rows" $ whnfIO $ runCheckpointInventoryBenchmark inventory10000Store + ] + ] + 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/RegressionGate.hs b/bench/RegressionGate.hs --- a/bench/RegressionGate.hs +++ b/bench/RegressionGate.hs @@ -2,17 +2,21 @@ module Main where +import Control.Exception (finally) import Control.Lens ((^.)) -import Control.Monad (forM, unless) +import Control.Monad (forM, replicateM_, unless) import Data.Aeson qualified as Aeson import Data.Generics.Labels () -import Data.IORef (IORef, atomicModifyIORef', newIORef) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) import Data.Int (Int32, Int64) +import Data.List (intercalate) import Data.Maybe (isNothing) import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Encoding (decodeUtf8Lenient) import Data.Time.Clock (getCurrentTime) import Data.Vector qualified as V +import GHC.Clock (getMonotonicTime) import Hasql.Decoders qualified as D import Hasql.Pool qualified as Pool import Hasql.Session qualified as Session @@ -22,135 +26,391 @@ import Hasql.Transaction.Sessions qualified as TxSessions import Kiroku.Store import Kiroku.Store.SQL qualified as SQL +import Kiroku.Store.Subscription.EventPublisher qualified as Publisher import Kiroku.Test.Fixtures.CategoryScaling (categoryScalingFixtureSql, categoryScalingHead) import Kiroku.Test.Postgres (withMigratedTestDatabase, withSharedMigratedPostgres) -import Test.Tasty (localOption) +import System.Environment (lookupEnv) +import System.Mem (performGC) +import Test.Tasty (localOption, withResource) import Test.Tasty.Bench main :: IO () -main = - withSharedMigratedPostgres $ - withMigratedTestDatabase $ \controlConnectionString -> - withMigratedTestDatabase $ \candidateConnectionString -> - withStore (defaultConnectionSettings controlConnectionString) $ \controlStore -> - withStore (defaultConnectionSettings candidateConnectionString) $ \candidateStore -> - withAppendCategoryStores $ \appendControlStore appendCandidateStore -> - withCategoryScalingStore $ \scalingStore -> do - let fourStreams = namedStreams "workload-gate-4" 4 - eightStreams = namedStreams "workload-gate-8" 8 - seedStreams controlStore (fourStreams <> eightStreams) - seedStreams candidateStore (fourStreams <> eightStreams) +main = do + mode <- lookupEnv "KIROKU_GATE_DIAGNOSE" + withSharedMigratedPostgres $ + withMigratedTestDatabase $ \controlConnectionString -> + withMigratedTestDatabase $ \candidateConnectionString -> + withStore (defaultConnectionSettings controlConnectionString) $ \controlStore -> + withStore (defaultConnectionSettings candidateConnectionString) $ \candidateStore -> + withAppendCategoryStores $ \appendControlStore appendCandidateStore appendWarmStore -> + withCategoryScalingStore $ \scalingStore -> do + let fourStreams = namedStreams "workload-gate-4" 4 + eightStreams = namedStreams "workload-gate-8" 8 + seedStreams controlStore (fourStreams <> eightStreams) + seedStreams candidateStore (fourStreams <> eightStreams) - runSequentialMultiAppend controlStore fourStreams - runProductionMultiAppend candidateStore fourStreams - runSequentialMultiAppend controlStore eightStreams - runProductionMultiAppend candidateStore eightStreams + runSequentialMultiAppend controlStore fourStreams + runProductionMultiAppend candidateStore fourStreams + runSequentialMultiAppend controlStore eightStreams + runProductionMultiAppend candidateStore eightStreams - appendControlCounter <- newIORef 0 - appendCandidateCounter <- newIORef 0 - runAppendWorkload preCategoryAppendAnyVersion appendControlStore appendControlCounter - runAppendWorkload SQL.appendAnyVersion appendCandidateStore appendCandidateCounter + (controlStatement, candidateStatement) <- diagnosticStatements mode appendControlStore appendCandidateStore + appendWarmCounter <- newIORef 0 + appendControlCounter <- newIORef 0 + appendCandidateCounter <- newIORef 0 + -- Prime each growing table before ANALYZE so prepared plans + -- see a populated store rather than the empty migration template. + mapM_ + ( \_ -> do + runAppendWorkload controlStatement appendControlStore appendControlCounter + runAppendWorkload candidateStatement appendCandidateStore appendCandidateCounter + runAppendWorkload SQL.appendAnyVersion appendWarmStore appendWarmCounter + ) + [1 .. 20 :: Int] - defaultMain - [ localOption WallTime $ - bgroup - "append-multi-stream" - [ bench "sequential-control-4" $ - whnfIO (runSequentialMultiAppend controlStore fourStreams) - , bcompareWithin 0 0.90 "sequential-control-4" $ - bench "production-pipeline-4" $ - whnfIO (runProductionMultiAppend candidateStore fourStreams) - , bench "sequential-control-8" $ - whnfIO (runSequentialMultiAppend controlStore eightStreams) - , bcompareWithin 0 0.90 "sequential-control-8" $ - bench "production-pipeline-8" $ - whnfIO (runProductionMultiAppend candidateStore eightStreams) - ] - , -- BUG-2 / plan 91 G4: carrying the category onto each $all - -- row (migration 0012) adds a column and one partial-index - -- insert per event. The control runs the pre-0012 append on - -- a database without the index or CHECK. - localOption WallTime $ - bgroup - "append-category-column" - [ bench "control-append-40" $ - whnfIO (runAppendWorkload preCategoryAppendAnyVersion appendControlStore appendControlCounter) - , bcompareWithin 0 1.05 "control-append-40" $ - bench "candidate-append-40" $ - whnfIO (runAppendWorkload SQL.appendAnyVersion appendCandidateStore appendCandidateCounter) - ] - , -- BUG-2 / plan 91 G3: the index-range category reads against - -- the LATERAL statements they replaced, on one database seeded - -- with the category-scaling fixture. The unpartitioned read - -- must not be slower where LATERAL was already cheap, and both - -- caught-up polls on 20,000 streams must be 5x faster. - localOption WallTime $ - bgroup - "category-read" - [ bench "control-exhausted-category" $ - whnfIO (runPlainReads lateralCategoryRead scalingStore "performance" categoryScalingHead) - , bcompareWithin 0 1.05 "control-exhausted-category" $ - bench "candidate-exhausted-category" $ - whnfIO (runPlainReads SQL.readCategoryForwardStmt scalingStore "performance" categoryScalingHead) - , bench "control-page-200-streams-from-0" $ - whnfIO (runPlainReads lateralCategoryRead scalingStore "performance" 0) - , bcompareWithin 0 1.05 "control-page-200-streams-from-0" $ - bench "candidate-page-200-streams-from-0" $ - whnfIO (runPlainReads SQL.readCategoryForwardStmt scalingStore "performance" 0) - , bench "control-page-20000-streams-from-0" $ - whnfIO (runPlainReads lateralCategoryRead scalingStore "idle" 0) - , bcompareWithin 0 1.05 "control-page-20000-streams-from-0" $ - bench "candidate-page-20000-streams-from-0" $ - whnfIO (runPlainReads SQL.readCategoryForwardStmt scalingStore "idle" 0) - , bench "control-plain-caught-up-20000-streams" $ - whnfIO (runPlainReads lateralCategoryRead scalingStore "idle" categoryScalingHead) - , bcompareWithin 0 0.20 "control-plain-caught-up-20000-streams" $ - bench "candidate-plain-caught-up-20000-streams" $ - whnfIO (runPlainReads SQL.readCategoryForwardStmt scalingStore "idle" categoryScalingHead) - , bench "control-group-caught-up-20000-streams" $ - whnfIO (runGroupReads lateralCategoryGroupRead scalingStore "idle" categoryScalingHead) - , bcompareWithin 0 0.20 "control-group-caught-up-20000-streams" $ - bench "candidate-group-caught-up-20000-streams" $ - whnfIO (runGroupReads SQL.readCategoryForwardConsumerGroupStmt scalingStore "idle" categoryScalingHead) - ] - ] + -- Settle fixture writes and refresh plans before measurement. + runSetupScript scalingStore "CHECKPOINT" + mapM_ + (\store -> runSetupScript store "VACUUM (ANALYZE)") + [controlStore, candidateStore, appendControlStore, appendCandidateStore, appendWarmStore, scalingStore] + case mode of + Nothing -> + defaultMain + [ -- ADR-10: the user accepted migration 0012's write cost. + -- Protect the accepted implementation against later SQL + -- regressions, keeping the historical comparison diagnostic. + localOption (RelStDev 0.01) $ + localOption WallTime $ + bgroup + "append-accepted-category" + [ -- Keep this group first: the disposable cell absorbs + -- post-setup effects without growing either append arm. + localOption (RelStDev 0.05) $ + bench "warm-append-40" $ + whnfIO (runAppendWorkload SQL.appendAnyVersion appendWarmStore appendWarmCounter), + bench "accepted-control-append-40x32" $ + whnfIO (replicateM_ 32 (runAppendWorkload controlStatement appendControlStore appendControlCounter)), + bcompareWithin 0.5 1.05 "accepted-control-append-40x32" $ + bench "candidate-append-40x32" $ + whnfIO (replicateM_ 32 (runAppendWorkload candidateStatement appendCandidateStore appendCandidateCounter)) + ], + withResource + (warmPipelineStores controlStore candidateStore fourStreams eightStreams) + (const (pure ())) + $ \_ -> + localOption WallTime $ + bgroup + "append-multi-stream" + [ localOption (RelStDev 0.01) $ + bench "sequential-control-4" $ + whnfIO (runSequentialMultiAppend controlStore fourStreams), + bcompareWithin 0.5 0.90 "sequential-control-4" $ + localOption (RelStDev 0.01) $ + bench "production-pipeline-4" $ + whnfIO (runProductionMultiAppend candidateStore fourStreams), + bench "sequential-control-8" $ + whnfIO (runSequentialMultiAppend controlStore eightStreams), + bcompareWithin 0.5 0.90 "sequential-control-8" $ + bench "production-pipeline-8" $ + whnfIO (runProductionMultiAppend candidateStore eightStreams) + ], + -- BUG-2 / plan 91 G3: the index-range category reads against + -- the LATERAL statements they replaced, on one database seeded + -- with the category-scaling fixture. The unpartitioned read + -- must not be slower where LATERAL was already cheap, and both + -- caught-up polls on 20,000 streams must be 5x faster. + localOption WallTime $ + bgroup + "category-read" + [ bench "control-exhausted-category" $ + whnfIO (runPlainReads lateralCategoryRead scalingStore "performance" categoryScalingHead), + bcompareWithin 0 1.05 "control-exhausted-category" $ + bench "candidate-exhausted-category" $ + whnfIO (runPlainReads SQL.readCategoryForwardStmt scalingStore "performance" categoryScalingHead), + bench "control-page-200-streams-from-0" $ + whnfIO (runPlainReads lateralCategoryRead scalingStore "performance" 0), + bcompareWithin 0 1.05 "control-page-200-streams-from-0" $ + bench "candidate-page-200-streams-from-0" $ + whnfIO (runPlainReads SQL.readCategoryForwardStmt scalingStore "performance" 0), + bench "control-page-20000-streams-from-0" $ + whnfIO (runPlainReads lateralCategoryRead scalingStore "idle" 0), + bcompareWithin 0 1.05 "control-page-20000-streams-from-0" $ + bench "candidate-page-20000-streams-from-0" $ + whnfIO (runPlainReads SQL.readCategoryForwardStmt scalingStore "idle" 0), + bench "control-plain-caught-up-20000-streams" $ + whnfIO (runPlainReads lateralCategoryRead scalingStore "idle" categoryScalingHead), + bcompareWithin 0 0.20 "control-plain-caught-up-20000-streams" $ + bench "candidate-plain-caught-up-20000-streams" $ + whnfIO (runPlainReads SQL.readCategoryForwardStmt scalingStore "idle" categoryScalingHead), + bench "control-group-caught-up-20000-streams" $ + whnfIO (runGroupReads lateralCategoryGroupRead scalingStore "idle" categoryScalingHead), + bcompareWithin 0 0.20 "control-group-caught-up-20000-streams" $ + bench "candidate-group-caught-up-20000-streams" $ + whnfIO (runGroupReads SQL.readCategoryForwardConsumerGroupStmt scalingStore "idle" categoryScalingHead) + ] + ] + `finally` do + counts <- mapM readIORef [appendControlCounter, appendCandidateCounter] + putStrLn ("append workload counts including setup: " <> show counts) + Just "explain-combined-links" -> runAppendExplainDiagnostic True controlStatement candidateStatement appendControlStore appendCandidateStore + Just "explain" -> runAppendExplainDiagnostic False controlStatement candidateStatement appendControlStore appendCandidateStore + Just label -> runPairedAppendDiagnostic label controlStatement candidateStatement appendControlStore appendCandidateStore appendControlCounter appendCandidateCounter + +runSetupScript :: KirokuStore -> Text -> IO () +runSetupScript store script = do + result <- Pool.use (store ^. #pool) (Session.script script) + case result of + Left err -> error ("workload gate quiescence failed: " <> show err) + Right () -> pure () + +-- | Refresh a group whose pools/plans have been idle during the append cells. +-- No resource thunk reaches STM, and all setup stays outside measured actions. +warmPipelineStores :: KirokuStore -> KirokuStore -> [(StreamName, Text)] -> [(StreamName, Text)] -> IO () +warmPipelineStores control candidate fourStreams eightStreams = do + replicateM_ 20 $ do + runSequentialMultiAppend control fourStreams + runProductionMultiAppend candidate fourStreams + runSequentialMultiAppend control eightStreams + runProductionMultiAppend candidate eightStreams + mapM_ (\store -> runSetupScript store "VACUUM (ANALYZE)") [control, candidate] + runSequentialMultiAppend control fourStreams + runProductionMultiAppend candidate fourStreams + runSequentialMultiAppend control eightStreams + runProductionMultiAppend candidate eightStreams + +-- | Diagnostic comparisons retain the default gate's SQL and bounds. Each +-- invocation gets fresh stores. The A/A mode tests the harness with identical +-- SQL and schema; the other modes separate column/statement from index/CHECK cost. +diagnosticStatements :: + Maybe String -> + KirokuStore -> + KirokuStore -> + IO (Statement SQL.AppendParams (Maybe AppendResult), Statement SQL.AppendParams (Maybe AppendResult)) +diagnosticStatements mode control candidate = case mode of + Nothing -> pure (acceptedCategoryAppendAnyVersion, SQL.appendAnyVersion) + Just "paired-accepted" -> pure (acceptedCategoryAppendAnyVersion, SQL.appendAnyVersion) + Just "paired" -> historical + Just "explain" -> historical + Just "paired-aa" -> do + runSetupScript control dropCategoryIndexAndCheck + runSetupScript candidate dropCategoryIndexAndCheck + pure (preCategoryAppendAnyVersion, preCategoryAppendAnyVersion) + Just "paired-column" -> do + runSetupScript control dropCategoryIndexAndCheck + runSetupScript candidate dropCategoryIndexAndCheck + pure (preCategoryAppendAnyVersion, SQL.appendAnyVersion) + Just "paired-index-check" -> do + runSetupScript control dropCategoryIndexAndCheck + pure (SQL.appendAnyVersion, SQL.appendAnyVersion) + Just "paired-no-publisher" -> do + -- Diagnostic upper bound only: there are no subscribers in this fixture. + -- Stopping this worker is not a production optimization or valid subscriber mode. + Publisher.stopPublisher (candidate ^. #publisher) + pure (SQL.appendAnyVersion, SQL.appendAnyVersion) + Just "paired-combined-links" -> pure (SQL.appendAnyVersion, combinedLinksAppend) + Just "explain-combined-links" -> pure (SQL.appendAnyVersion, combinedLinksAppend) + Just invalid -> error ("unknown KIROKU_GATE_DIAGNOSE mode: " <> invalid) + where + historical = do + runSetupScript control dropCategoryIndexAndCheck + pure (preCategoryAppendAnyVersion, SQL.appendAnyVersion) + dropCategoryIndexAndCheck = + "DROP INDEX kiroku.ix_stream_events_all_by_category; ALTER TABLE kiroku.stream_events DROP CONSTRAINT ck_stream_events_all_category;" + +-- | Benchmark-only hypothesis: one junction INSERT instead of two. This +-- preserves the production bind parameters, row values and result decoder. +combinedLinksAppend :: Statement SQL.AppendParams (Maybe AppendResult) +combinedLinksAppend = Statement.preparable sql SQL.appendParamsEncoder SQL.appendResultDecoder + where + production = Statement.toSql SQL.appendAnyVersion + -- The exact production SQL is extracted below using stable CTE boundaries; + -- fail rather than silently producing a different candidate after an edit. + sql = combineJunctionInserts production + +combineJunctionInserts :: Text -> Text +combineJunctionInserts production = + let (beforeSource, sourceAndRest) = T.breakOn " source_links AS (" production + (_, allUpdateAndRest) = T.breakOn " all_update AS (" sourceAndRest + (allUpdate, allLinksAndResult) = T.breakOn " all_links AS (" allUpdateAndRest + (_, result) = T.breakOn "SELECT su.stream_id," allLinksAndResult + combined = + """ + event_links AS ( + INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version, category) + SELECT ne.event_id, su.stream_id, su.initial_version + ne.idx, su.stream_id, su.initial_version + ne.idx, NULL::text + FROM new_events ne + CROSS JOIN stream_upsert su + UNION ALL + SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category + FROM new_events ne + CROSS JOIN all_update au + CROSS JOIN stream_upsert su + ) + """ + in if T.null beforeSource || T.null allUpdate || T.null result + then error "combined-links prototype could not identify production CTE boundaries" + else beforeSource <> allUpdate <> combined <> "\n" <> result + +-- | Twelve alternating pairs of equal-sized, growing workloads. Every round +-- starts at the same logical stream/event counts in both databases. These are +-- diagnostic samples, never a substitute passing result for the tasty gate. +runPairedAppendDiagnostic :: + String -> + Statement SQL.AppendParams (Maybe AppendResult) -> + Statement SQL.AppendParams (Maybe AppendResult) -> + KirokuStore -> + KirokuStore -> + IORef Int -> + IORef Int -> + IO () +runPairedAppendDiagnostic label controlStatement candidateStatement control candidate controlCounter candidateCounter = do + putStrLn "PAIR,variant,pair,first,control_ns,candidate_ns,control_before,candidate_before,control_after,candidate_after,pre_gc" + mapM_ runPair [1 .. 12 :: Int] + verifyCounts "control" control controlCounter + verifyCounts "candidate" candidate candidateCounter + where + iterations = 32 + timed :: IO () -> IO Integer + timed action = do + -- Match tasty-bench: collect before the timer, rather than letting setup + -- garbage fall unpredictably into one arm of this diagnostic comparison. + performGC + start <- getMonotonicTime + action + end <- getMonotonicTime + pure (round ((end - start) * 1e9) :: Integer) + controlAction = replicateM_ iterations (runAppendWorkload controlStatement control controlCounter) + candidateAction = replicateM_ iterations (runAppendWorkload candidateStatement candidate candidateCounter) + runPair pair = do + beforeControl <- readIORef controlCounter + beforeCandidate <- readIORef candidateCounter + unless (beforeControl == beforeCandidate) $ error "diagnostic arms start at unequal workload counts" + (controlNs, candidateNs) <- + if odd pair + then do + c <- timed controlAction + n <- timed candidateAction + pure (c, n) + else do + n <- timed candidateAction + c <- timed controlAction + pure (c, n) + afterControl <- readIORef controlCounter + afterCandidate <- readIORef candidateCounter + unless (afterControl == beforeControl + iterations && afterCandidate == beforeCandidate + iterations) $ + error "diagnostic arms did not complete equal work" + putStrLn $ + intercalate + "," + [ "PAIR", + label, + show pair, + if odd pair then "control" else "candidate", + show controlNs, + show candidateNs, + show beforeControl, + show beforeCandidate, + show afterControl, + show afterCandidate, + "1" + ] + verifyCounts arm store counter = do + completed <- readIORef counter + let expectedEvents = fromIntegral (40 * completed) :: Int64 + expectedStreams = fromIntegral (20 * completed + 2) :: Int64 + result <- Pool.use (store ^. #pool) (Session.statement () diagnosticCounts) + case result of + Right counts@(streams, events, links, hotVersion, globalVersion) -> do + unless (counts == (expectedStreams, expectedEvents, 2 * expectedEvents, expectedEvents `div` 2, expectedEvents)) $ + error ("diagnostic database counts differ for " <> arm <> ": " <> show counts) + putStrLn $ intercalate "," ["COUNTS", label, arm, show streams, show events, show links, show hotVersion, show globalVersion] + Left err -> error ("diagnostic count verification failed: " <> show err) + +-- | Use the exact statements under comparison, rather than a copied EXPLAIN +-- query. These four plans show structure/buffers/WAL, not a latency estimate. +runAppendExplainDiagnostic :: + Bool -> + Statement SQL.AppendParams (Maybe AppendResult) -> + Statement SQL.AppendParams (Maybe AppendResult) -> + KirokuStore -> + KirokuStore -> + IO () +runAppendExplainDiagnostic timings controlStatement candidateStatement control candidate = do + mapM_ + ( \(arm, statement, store) -> do + mapM_ (explainOne arm statement store) [("fresh", "append-gate-explain-fresh"), ("hot", "append-gate-hot")] + rows <- Pool.use (store ^. #pool) (Session.statement () physicalRows) + case rows of + Right value -> putStrLn ("PHYSICAL," <> arm <> "," <> T.unpack value) + Left err -> error ("diagnostic physical row query failed: " <> show err) + ) + [("control", controlStatement, control), ("candidate", candidateStatement, candidate)] + where + jsonText = D.singleRow (D.column (D.nonNullable (D.jsonBytes (Right . decodeUtf8Lenient)))) + physicalRows = + Statement.unpreparable + "SELECT json_agg(row_to_json(x)) FROM (SELECT stream_id = 0 AS all_row, category IS NULL AS category_is_null, pg_column_size(se) AS row_bytes, count(*) AS samples FROM stream_events se GROUP BY 1,2,3 ORDER BY 1,2,3) x" + mempty + jsonText + explainOne arm statement store (kind, name) = do + enriched <- enrichEvents (store ^. #storeSettings) [makeEvent "AppendCategoryGate"] + prepared <- prepareEvents enriched + now <- getCurrentTime + let explain = + Statement.unpreparable + ("EXPLAIN (ANALYZE, BUFFERS, WAL, TIMING " <> (if timings then "ON" else "OFF") <> ", FORMAT JSON) " <> Statement.toSql statement) + SQL.appendParamsEncoder + jsonText + result <- Pool.use (store ^. #pool) (Session.statement (buildAppendParams name now prepared) explain) + case result of + Right value -> putStrLn ("PLAN," <> arm <> "," <> kind <> "," <> T.unpack value) + Left err -> error ("diagnostic EXPLAIN failed: " <> show err) + +diagnosticCounts :: Statement () (Int64, Int64, Int64, Int64, Int64) +diagnosticCounts = + Statement.unpreparable + "SELECT (SELECT count(*) FROM streams), (SELECT count(*) FROM events), (SELECT count(*) FROM stream_events), (SELECT stream_version FROM streams WHERE stream_name = 'append-gate-hot'), (SELECT stream_version FROM streams WHERE stream_id = 0)" + mempty + (D.singleRow ((,,,,) <$> int8 <*> int8 <*> int8 <*> int8 <*> int8)) + where + int8 = D.column (D.nonNullable D.int8) + -- | A migrated store seeded with 'categoryScalingFixtureSql'. withCategoryScalingStore :: (KirokuStore -> IO a) -> IO a withCategoryScalingStore action = - withMigratedTestDatabase $ \connectionString -> - withStore (defaultConnectionSettings connectionString) $ \store -> do - seeded <- Pool.use (store ^. #pool) (Session.script categoryScalingFixtureSql) - case seeded of - Left err -> error ("category-read gate setup failed: " <> show err) - Right () -> action store + withMigratedTestDatabase $ \connectionString -> + withStore (defaultConnectionSettings connectionString) $ \store -> do + seeded <- Pool.use (store ^. #pool) (Session.script categoryScalingFixtureSql) + case seeded of + Left err -> error ("category-read gate setup failed: " <> show err) + Right () -> action store -{- | Ten executions of an unpartitioned category read (limit 100). Ten, not a -hundred: a LATERAL control poll on 20,000 streams costs about 15 ms, and a -hundred per iteration exceeds tasty-bench's timeout. --} +-- | Ten executions of an unpartitioned category read (limit 100). Ten, not a +-- hundred: a LATERAL control poll on 20,000 streams costs about 15 ms, and a +-- hundred per iteration exceeds tasty-bench's timeout. runPlainReads :: - Statement (Int64, Text, Int32) (V.Vector RecordedEvent) -> - KirokuStore -> - Text -> - Int64 -> - IO () + Statement (Int64, Text, Int32) (V.Vector RecordedEvent) -> + KirokuStore -> + Text -> + Int64 -> + IO () runPlainReads statement store category cursor = - mapM_ - (\_ -> Pool.use (store ^. #pool) (Session.statement (cursor, category, 100) statement) >>= forceReads) - [1 .. 10 :: Int] + mapM_ + (\_ -> Pool.use (store ^. #pool) (Session.statement (cursor, category, 100) statement) >>= forceReads) + [1 .. 10 :: Int] -- | Ten executions of a consumer-group category read, member 1 of 2 (limit 100). runGroupReads :: - Statement (Int64, Text, Int32, Int32, Int32) (V.Vector RecordedEvent) -> - KirokuStore -> - Text -> - Int64 -> - IO () + Statement (Int64, Text, Int32, Int32, Int32) (V.Vector RecordedEvent) -> + KirokuStore -> + Text -> + Int64 -> + IO () runGroupReads statement store category cursor = - mapM_ - (\_ -> Pool.use (store ^. #pool) (Session.statement (cursor, category, 1, 2, 100) statement) >>= forceReads) - [1 .. 10 :: Int] + mapM_ + (\_ -> Pool.use (store ^. #pool) (Session.statement (cursor, category, 1, 2, 100) statement) >>= forceReads) + [1 .. 10 :: Int] forceReads :: Either Pool.UsageError (V.Vector RecordedEvent) -> IO () forceReads (Right events) = V.length events `seq` pure () @@ -159,246 +419,292 @@ -- | 'SQL.readCategoryForwardStmt' as it was before plan 91 (git 12d50d5). lateralCategoryRead :: Statement (Int64, Text, Int32) (V.Vector RecordedEvent) lateralCategoryRead = - Statement.preparable - lateralCategoryReadSQL - SQL.readCategoryEncoder - (D.rowVector SQL.recordedEventRow) + Statement.preparable + lateralCategoryReadSQL + SQL.readCategoryEncoder + (D.rowVector SQL.recordedEventRow) -- | 'SQL.readCategoryForwardConsumerGroupStmt' as it was before plan 91 (git 12d50d5). lateralCategoryGroupRead :: Statement (Int64, Text, Int32, Int32, Int32) (V.Vector RecordedEvent) lateralCategoryGroupRead = - Statement.preparable - lateralCategoryGroupReadSQL - SQL.readCategoryConsumerGroupEncoder - (D.rowVector SQL.recordedEventRow) + Statement.preparable + lateralCategoryGroupReadSQL + SQL.readCategoryConsumerGroupEncoder + (D.rowVector SQL.recordedEventRow) lateralCategoryReadSQL :: Text lateralCategoryReadSQL = - """ - 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 + """ + 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 + """ lateralCategoryGroupReadSQL :: Text lateralCategoryGroupReadSQL = - """ - 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 + """ + 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 + """ -{- | Two freshly migrated stores for the append-category-column gate. The -control database has the category index and CHECK from migration 0012 -dropped, so it pays exactly the pre-0012 write cost when driven by -'preCategoryAppendAnyVersion'; the candidate is left as migrated. --} -withAppendCategoryStores :: (KirokuStore -> KirokuStore -> IO a) -> IO a +-- | Three fully migrated stores: the frozen accepted control, current +-- production candidate, and disposable warm-up. Historical diagnostic modes +-- explicitly remove the category index/CHECK from the appropriate arm. +withAppendCategoryStores :: (KirokuStore -> KirokuStore -> KirokuStore -> IO a) -> IO a withAppendCategoryStores action = - withMigratedTestDatabase $ \controlConnectionString -> - withMigratedTestDatabase $ \candidateConnectionString -> - withStore (defaultConnectionSettings controlConnectionString) $ \controlStore -> - withStore (defaultConnectionSettings candidateConnectionString) $ \candidateStore -> do - dropped <- - Pool.use - (controlStore ^. #pool) - ( Session.script - """ - DROP INDEX kiroku.ix_stream_events_all_by_category; - ALTER TABLE kiroku.stream_events DROP CONSTRAINT ck_stream_events_all_category; - """ - ) - case dropped of - Left err -> error ("append-category control setup failed: " <> show err) - Right () -> action controlStore candidateStore + withMigratedTestDatabase $ \controlConnectionString -> + withMigratedTestDatabase $ \candidateConnectionString -> + withMigratedTestDatabase $ \warmConnectionString -> + withStore (defaultConnectionSettings warmConnectionString) $ \warmStore -> + withStore (defaultConnectionSettings controlConnectionString) $ \controlStore -> + withStore (defaultConnectionSettings candidateConnectionString) $ \candidateStore -> + action controlStore candidateStore warmStore -{- | One gate iteration: 20 single-event appends to fresh streams, then 20 to -one hot stream. Each store gets its own counter, so control and candidate -create the same stream names and do the same work. --} +-- | One gate iteration: 20 single-event appends to fresh streams, then 20 to +-- one hot stream. Each store gets its own counter, so control and candidate +-- create the same stream names and do the same work. runAppendWorkload :: - Statement SQL.AppendParams (Maybe AppendResult) -> - KirokuStore -> - IORef Int -> - IO () + Statement SQL.AppendParams (Maybe AppendResult) -> + KirokuStore -> + IORef Int -> + IO () runAppendWorkload statement store counter = do - iteration <- atomicModifyIORef' counter (\n -> (n + 1, n)) - now <- getCurrentTime - let freshNames = - [ "append-gate-" <> T.pack (show iteration) <> "-" <> T.pack (show index) - | index <- [1 .. 20 :: Int] - ] - names = freshNames <> replicate 20 "append-gate-hot" - mapM_ - ( \name -> do - enriched <- enrichEvents (store ^. #storeSettings) [makeEvent "AppendCategoryGate"] - prepared <- prepareEvents enriched - result <- - Pool.use (store ^. #pool) $ - Session.statement (buildAppendParams name now prepared) statement - case result of - Right (Just appendResult) -> forceAppendResults [appendResult] - Right Nothing -> error "append-category gate append returned no row" - Left err -> error ("append-category gate append failed: " <> show err) - ) - names + iteration <- atomicModifyIORef' counter (\n -> (n + 1, n)) + now <- getCurrentTime + let freshNames = + [ "append-gate-" <> T.pack (show iteration) <> "-" <> T.pack (show index) + | index <- [1 .. 20 :: Int] + ] + names = freshNames <> replicate 20 "append-gate-hot" + mapM_ + ( \name -> do + enriched <- enrichEvents (store ^. #storeSettings) [makeEvent "AppendCategoryGate"] + prepared <- prepareEvents enriched + result <- + Pool.use (store ^. #pool) $ + Session.statement (buildAppendParams name now prepared) statement + case result of + Right (Just appendResult) -> forceAppendResults [appendResult] + Right Nothing -> error "append-category gate append returned no row" + Left err -> error ("append-category gate append failed: " <> show err) + ) + names +-- | Frozen post-0012 append SQL from the user-accepted production source at +-- git 22ac4de. Keep this literal independent of SQL.appendAnyVersion so later +-- production changes are compared against the accepted implementation. +acceptedCategoryAppendAnyVersion :: Statement SQL.AppendParams (Maybe AppendResult) +acceptedCategoryAppendAnyVersion = + Statement.preparable acceptedCategoryAppendAnyVersionSQL SQL.appendParamsEncoder SQL.appendResultDecoder + +acceptedCategoryAppendAnyVersionSQL :: Text +acceptedCategoryAppendAnyVersionSQL = + """ + 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, category, 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, category) + SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category + 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 + """ + -- | 'SQL.appendAnyVersion' as it was before migration 0012 (git 12d50d5). preCategoryAppendAnyVersion :: Statement SQL.AppendParams (Maybe AppendResult) preCategoryAppendAnyVersion = - Statement.preparable - preCategoryAppendAnyVersionSQL - SQL.appendParamsEncoder - SQL.appendResultDecoder + Statement.preparable + preCategoryAppendAnyVersionSQL + SQL.appendParamsEncoder + SQL.appendResultDecoder preCategoryAppendAnyVersionSQL :: Text preCategoryAppendAnyVersionSQL = - """ - 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 - """ + """ + 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 + """ namedStreams :: Text -> Int -> [(StreamName, Text)] namedStreams prefix count = - [ ( StreamName (prefix <> "-" <> T.pack (show index)) - , "WorkloadGate" <> T.pack (show index) - ) - | index <- [1 .. count] - ] + [ ( StreamName (prefix <> "-" <> T.pack (show index)), + "WorkloadGate" <> T.pack (show index) + ) + | index <- [1 .. count] + ] seedStreams :: KirokuStore -> [(StreamName, Text)] -> IO () seedStreams store streams = - mapM_ - ( \(streamName, eventType) -> do - result <- runStoreIO store $ appendToStream streamName NoStream [makeEvent (eventType <> "Seed")] - forceStoreResults "seed append" (fmap pure result) - ) - streams + mapM_ + ( \(streamName, eventType) -> do + result <- runStoreIO store $ appendToStream streamName NoStream [makeEvent (eventType <> "Seed")] + forceStoreResults "seed append" (fmap pure result) + ) + streams runProductionMultiAppend :: KirokuStore -> [(StreamName, Text)] -> IO () runProductionMultiAppend store streams = do - result <- - runStoreIO store $ - appendMultiStream - [ (streamName, AnyVersion, [makeEvent eventType]) - | (streamName, eventType) <- streams - ] - forceStoreResults "production appendMultiStream" result + result <- + runStoreIO store $ + appendMultiStream + [ (streamName, AnyVersion, [makeEvent eventType]) + | (streamName, eventType) <- streams + ] + forceStoreResults "production appendMultiStream" result runSequentialMultiAppend :: KirokuStore -> [(StreamName, Text)] -> IO () runSequentialMultiAppend store streams = do - now <- getCurrentTime - preparedOps <- - forM streams $ \(streamName@(StreamName name), eventType) -> do - enriched <- enrichEvents (store ^. #storeSettings) [makeEvent eventType] - prepared <- prepareEvents enriched - pure (streamName, name, buildAppendParams name now prepared) - let names = V.fromList [name | (_, name, _) <- preparedOps] - transaction = do - Tx.statement names SQL.lockStreamsForMultiStmt - results <- - forM preparedOps $ \(_, _, params) -> - appendDispatchTx AnyVersion params - if any isNothing results - then Tx.condemn >> pure results - else pure results - result <- - Pool.use (store ^. #pool) $ - TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write transaction - case result of - Left err -> error ("sequential appendMultiStream control failed: " <> show err) - Right maybeResults -> do - unless (all isJustAppend maybeResults) $ - error "sequential appendMultiStream control returned an empty append result" - forceAppendResults [appendResult | Just appendResult <- maybeResults] + now <- getCurrentTime + preparedOps <- + forM streams $ \(streamName@(StreamName name), eventType) -> do + enriched <- enrichEvents (store ^. #storeSettings) [makeEvent eventType] + prepared <- prepareEvents enriched + pure (streamName, name, buildAppendParams name now prepared) + let names = V.fromList [name | (_, name, _) <- preparedOps] + transaction = do + Tx.statement names SQL.lockStreamsForMultiStmt + results <- + forM preparedOps $ \(_, _, params) -> + appendDispatchTx AnyVersion params + if any isNothing results + then Tx.condemn >> pure results + else pure results + result <- + Pool.use (store ^. #pool) $ + TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write transaction + case result of + Left err -> error ("sequential appendMultiStream control failed: " <> show err) + Right maybeResults -> do + unless (all isJustAppend maybeResults) $ + error "sequential appendMultiStream control returned an empty append result" + forceAppendResults [appendResult | Just appendResult <- maybeResults] makeEvent :: Text -> EventData makeEvent eventType = - EventData - { eventId = Nothing - , eventType = EventType eventType - , payload = Aeson.object [("workloadGate", Aeson.Bool True)] - , metadata = Nothing - , causationId = Nothing - , correlationId = Nothing - } + EventData + { eventId = Nothing, + eventType = EventType eventType, + payload = Aeson.object [("workloadGate", Aeson.Bool True)], + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } isJustAppend :: Maybe AppendResult -> Bool isJustAppend (Just _) = True @@ -410,8 +716,8 @@ forceAppendResults :: [AppendResult] -> IO () forceAppendResults = - mapM_ $ \result -> - (result ^. #streamId) `seq` - (result ^. #streamVersion) `seq` - (result ^. #globalPosition) `seq` - pure () + mapM_ $ \result -> + (result ^. #streamId) `seq` + (result ^. #streamVersion) `seq` + (result ^. #globalPosition) `seq` + pure () diff --git a/bench/ShibuyaOverhead.hs b/bench/ShibuyaOverhead.hs --- a/bench/ShibuyaOverhead.hs +++ b/bench/ShibuyaOverhead.hs @@ -1,16 +1,15 @@ -{- | 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. --} +-- | 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) @@ -35,7 +34,7 @@ import Shibuya.App (ProcessorId (..), defaultAppConfig, mkProcessor, runApp, stopApp) import Shibuya.Core.Ack (AckDecision (..)) import Shibuya.Core.AckHandle (AckHandle (..)) -import Shibuya.Core.Ingested (Ingested (..), Message) +import Shibuya.Core.Ingested (DeliveryStatus (..), Ingested (..), Message) import Shibuya.Core.Types (Cursor (..), Envelope (..), MessageId (..)) import Shibuya.Telemetry.Effect (runTracingNoop) import Streamly.Data.Fold qualified as Fold @@ -48,269 +47,270 @@ main :: IO () main = do - config <- ephemeralConfig - result <- Pg.withCachedConfig config Pg.defaultCacheConfig $ \db -> do - migrateTestDatabase (Pg.connectionString db) - let settings = defaultConnectionSettings (Pg.connectionString db) - withStore settings $ \store -> do - putStrLn "=== Kiroku Shibuya Adapter Overhead Benchmark ===" - printf " %d iterations per measurement\n\n" iterations + config <- ephemeralConfig + result <- Pg.withCachedConfig config Pg.defaultCacheConfig $ \db -> do + migrateTestDatabase (Pg.connectionString db) + 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] + mapM_ (runBenchmarkSuite store) [100, 1000, 5000] - case result of - Left err -> error ("Failed to start ephemeral PostgreSQL: " <> show err) - Right () -> pure () + 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 + printf "--- %d events ---\n\n" n - -- Pre-populate events - counter <- newIORef (0 :: Int) - let nextId = atomicModifyIORef' counter (\i -> (i + 1, i)) + -- 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 + 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]] + -- 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 + let bareMedian = median bareTimes + streamMedian = median streamTimes + shibuyaMedian = median shibuyaTimes - putRow " bare subscribe" n bareTimes - putRow " subscriptionStream" n streamTimes - putRow " shibuya adapter" n 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 "" + 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) + 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 = either (error . show) Prelude.id (mkBatchSize 500) - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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)) + 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 = either (error . show) Prelude.id (mkBatchSize 500), + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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)) + subId <- nextId + let subName = SubscriptionName ("stream-bench-" <> T.pack (show subId)) - let cfg = - SubscriptionConfig - { name = subName - , target = AllStreams - , handler = \_ -> pure Continue - , batchSize = either (error . show) Prelude.id (mkBatchSize 500) - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , retryPolicy = defaultRetryPolicy - , eventTypeFilter = AllEventTypes - , selector = Nothing - } + let cfg = + SubscriptionConfig + { name = subName, + target = AllStreams, + handler = \_ -> pure Continue, + batchSize = either (error . show) Prelude.id (mkBatchSize 500), + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + retryPolicy = defaultRetryPolicy, + eventTypeFilter = AllEventTypes, + selector = Nothing + } - t0 <- getCurrentTime - (stream, cancelStream) <- subscriptionStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 256)) - Stream.fold Fold.drain (Stream.take n stream) - cancelStream - t1 <- getCurrentTime - pure (realToFrac (diffUTCTime t1 t0)) + t0 <- getCurrentTime + (stream, cancelStream) <- subscriptionStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 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) + 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 = either (error . show) Prelude.id (mkBatchSize 500) - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , retryPolicy = defaultRetryPolicy - , eventTypeFilter = AllEventTypes - , selector = Nothing - } + t0 <- getCurrentTime + runEff $ runTracingNoop $ do + let cfg = + SubscriptionConfig + { name = subName, + target = AllStreams, + handler = \_ -> pure Continue, + batchSize = either (error . show) Prelude.id (mkBatchSize 500), + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + retryPolicy = defaultRetryPolicy, + eventTypeFilter = AllEventTypes, + selector = Nothing + } - (ioStream, cancelAction) <- liftIO $ subscriptionStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 256)) + (ioStream, cancelAction) <- liftIO $ subscriptionStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 256)) - let effStream = Stream.morphInner liftIO ioStream - ingestedStream = fmap (mkIngested cancelAction) effStream + let effStream = Stream.morphInner liftIO ioStream + ingestedStream = fmap (mkIngested cancelAction) effStream - let adapter = - Adapter - { adapterName = "kiroku-bench" - , source = ingestedStream - , shutdown = liftIO cancelAction - } + let adapter = + Adapter + { adapterName = "kiroku-bench", + source = ingestedStream, + shutdown = liftIO cancelAction + } - let handler :: (IOE :> es) => Message es RecordedEvent -> Eff es AckDecision - handler _ingested = do - liftIO $ atomically $ do - c <- readTVar countVar - writeTVar countVar (c + 1) - pure AckOk + let handler :: (IOE :> es) => Message es RecordedEvent -> Eff es AckDecision + handler _ingested = do + liftIO $ atomically $ do + c <- readTVar countVar + writeTVar countVar (c + 1) + pure AckOk - res <- runApp defaultAppConfig [(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 + res <- runApp defaultAppConfig [(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)) + 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 - , headers = Nothing - , attempt = Nothing - , attributes = HashMap.empty - , payload = event - } - , ack = - AckHandle - { finalize = \case - AckHalt _ -> liftIO cancelAction - _ -> pure () - } - , lease = Nothing - } + 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, + headers = Nothing, + attempt = Nothing, + attributes = HashMap.empty, + payload = event + }, + ack = + AckHandle + { finalize = \case + AckHalt _ -> liftIO cancelAction + _ -> pure () + }, + lease = Nothing, + deliveryStatus = pure DeliveryCurrent + } 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) + 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) + 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 + 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 + | 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 + | 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 + | p >= 0 = printf "+%.0f%%" p + | otherwise = printf "%.0f%%" p chunksOf :: Int -> [a] -> [[a]] chunksOf _ [] = [] @@ -318,11 +318,11 @@ makeEvent :: Text -> EventData makeEvent typ = - EventData - { eventId = Nothing - , eventType = EventType typ - , payload = Aeson.object [("benchmark", Aeson.Bool True)] - , metadata = Nothing - , causationId = Nothing - , correlationId = Nothing - } + EventData + { eventId = Nothing, + eventType = EventType typ, + payload = Aeson.object [("benchmark", Aeson.Bool True)], + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } diff --git a/bench/StreamHeadCost.hs b/bench/StreamHeadCost.hs --- a/bench/StreamHeadCost.hs +++ b/bench/StreamHeadCost.hs @@ -23,59 +23,59 @@ main :: IO () main = do - start <- getCurrentTime - withSharedMigratedPostgres $ withMigratedTestDatabase $ \connection -> - withStore (defaultConnectionSettings connection) $ \store -> do - sql store streamHeadFixtureSql - sql store "VACUUM (ANALYZE) stream_events" - details <- - Pool.use (store ^. #pool) $ - Session.statement () $ - preparable - "SELECT json_build_object('server', version(), 'shared_buffers', current_setting('shared_buffers'), 'work_mem', current_setting('work_mem'), 'jit', current_setting('jit'), 'plan_cache_mode', current_setting('plan_cache_mode'), 'streams', (SELECT count(*) FROM streams), 'events', (SELECT count(*) FROM events), 'junctions', (SELECT count(*) FROM stream_events))::text" - E.noParams - (D.singleRow (D.column (D.nonNullable D.text))) - either (error . show) (putStrLn . T.unpack) details - setup <- getCurrentTime - putStrLn ("setup_seconds=" <> show (diffUTCTime setup start)) - groups <- mapM (sizeGroup store) [("100", StreamName "bench-1"), ("100000", StreamName "long-1")] - warmed <- getCurrentTime - putStrLn ("warmup_seconds=" <> show (diffUTCTime warmed setup)) - defaultMain groups `finally` do - finished <- getCurrentTime - putStrLn ("measurement_seconds=" <> show (diffUTCTime finished warmed)) - putStrLn ("total_seconds=" <> show (diffUTCTime finished start)) + start <- getCurrentTime + withSharedMigratedPostgres $ withMigratedTestDatabase $ \connection -> + withStore (defaultConnectionSettings connection) $ \store -> do + sql store streamHeadFixtureSql + sql store "VACUUM (ANALYZE) stream_events" + details <- + Pool.use (store ^. #pool) $ + Session.statement () $ + preparable + "SELECT json_build_object('server', version(), 'shared_buffers', current_setting('shared_buffers'), 'work_mem', current_setting('work_mem'), 'jit', current_setting('jit'), 'plan_cache_mode', current_setting('plan_cache_mode'), 'streams', (SELECT count(*) FROM streams), 'events', (SELECT count(*) FROM events), 'junctions', (SELECT count(*) FROM stream_events))::text" + E.noParams + (D.singleRow (D.column (D.nonNullable D.text))) + either (error . show) (putStrLn . T.unpack) details + setup <- getCurrentTime + putStrLn ("setup_seconds=" <> show (diffUTCTime setup start)) + groups <- mapM (sizeGroup store) [("100", StreamName "bench-1"), ("100000", StreamName "long-1")] + warmed <- getCurrentTime + putStrLn ("warmup_seconds=" <> show (diffUTCTime warmed setup)) + defaultMain groups `finally` do + finished <- getCurrentTime + putStrLn ("measurement_seconds=" <> show (diffUTCTime finished warmed)) + putStrLn ("total_seconds=" <> show (diffUTCTime finished start)) sizeGroup :: KirokuStore -> (String, StreamName) -> IO Benchmark sizeGroup store (label, name) = do - Right (Just expected) <- runFrozen store (getStream name) - unless (expected ^. #version == StreamVersion (read label)) (error "invalid fixture version") - let validate result = case result of - Right (Just actual) -> unless (actual == expected) (error "unexpected metadata") - other -> error ("metadata read failed: " <> show other) - control = replicateM_ 100 (runFrozen store (getStream name) >>= validate) - production = replicateM_ 100 (runStoreIO store (getStream name) >>= validate) - -- Equality checks every StreamInfo field in successful calls in both arms. - control - production - let withHead = replicateM_ 100 $ do - result <- runStoreIO store (getStreamWithHead name) - case result of - Right (Just (actual, Just headPosition)) -> do - validate (Right (Just actual)) - unless - (headPosition == GlobalPosition (if label == "100" then 99001 else 200000)) - (error "unexpected originated head") - other -> error ("head read failed: " <> show other) - withHead - pure $ - bgroup - label - [ bench "control-metadata" (whnfIO control) - , bcompareWithin 0 1.10 ("$(NF-1) == \"" <> label <> "\" && $NF == \"control-metadata\"") $ - bench "production-metadata" (whnfIO production) - , bench "production-with-head" (whnfIO withHead) - ] + Right (Just expected) <- runFrozen store (getStream name) + unless (expected ^. #version == StreamVersion (read label)) (error "invalid fixture version") + let validate result = case result of + Right (Just actual) -> unless (actual == expected) (error "unexpected metadata") + other -> error ("metadata read failed: " <> show other) + control = replicateM_ 100 (runFrozen store (getStream name) >>= validate) + production = replicateM_ 100 (runStoreIO store (getStream name) >>= validate) + -- Equality checks every StreamInfo field in successful calls in both arms. + control + production + let withHead = replicateM_ 100 $ do + result <- runStoreIO store (getStreamWithHead name) + case result of + Right (Just (actual, Just headPosition)) -> do + validate (Right (Just actual)) + unless + (headPosition == GlobalPosition (if label == "100" then 99001 else 200000)) + (error "unexpected originated head") + other -> error ("head read failed: " <> show other) + withHead + pure $ + bgroup + label + [ bench "control-metadata" (whnfIO control), + bcompareWithin 0 1.10 ("$(NF-1) == \"" <> label <> "\" && $NF == \"control-metadata\"") $ + bench "production-metadata" (whnfIO production), + bench "production-with-head" (whnfIO withHead) + ] sql :: KirokuStore -> T.Text -> IO () sql store command = Pool.use (store ^. #pool) (Session.script command) >>= either (error . show) pure @@ -87,33 +87,33 @@ frozenInterpreter :: (IOE :> es, Error StoreError :> es) => KirokuStore -> Eff (Store : es) a -> Eff es a frozenInterpreter store = interpret_ $ \case - GetStream (StreamName name) -> frozenPool (store ^. #pool) (Session.statement name frozenStatement) - _ -> error "unexpected operation in frozen metadata control" + GetStream (StreamName name) -> frozenPool (store ^. #pool) (Session.statement name frozenStatement) + _ -> error "unexpected operation in frozen metadata control" frozenPool :: (IOE :> es, Error StoreError :> es) => Pool.Pool -> Session.Session a -> Eff es a frozenPool pool session = do - result <- liftIO (Pool.use pool session) - case result of - Left usageErr -> throwError (ConnectionError (T.pack (show usageErr))) - Right a -> pure a + result <- liftIO (Pool.use pool session) + case result of + Left usageErr -> throwError (ConnectionError (T.pack (show usageErr))) + Right a -> pure a frozenStatement :: Statement T.Text (Maybe StreamInfo) frozenStatement = - preparable - """ - SELECT stream_id, stream_name, stream_version, created_at, deleted_at, truncate_before - FROM streams - WHERE stream_name = $1 - """ - (E.param (E.nonNullable E.text)) - (D.rowMaybe frozenRow) + preparable + """ + SELECT stream_id, stream_name, stream_version, created_at, deleted_at, truncate_before + FROM streams + WHERE stream_name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.rowMaybe frozenRow) frozenRow :: D.Row StreamInfo frozenRow = - 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) - <*> (StreamVersion <$> D.column (D.nonNullable D.int8)) + 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) + <*> (StreamVersion <$> D.column (D.nonNullable D.int8)) diff --git a/bench/StreamHeadPaired.hs b/bench/StreamHeadPaired.hs --- a/bench/StreamHeadPaired.hs +++ b/bench/StreamHeadPaired.hs @@ -26,82 +26,82 @@ -- ABBA/BAAB schedule. Each CSV row is one batch; no adaptive early stopping. main :: IO () main = do - [schedulePath, outputPath, callsText] <- getArgs - let calls = read callsText :: Int - unless (calls > 0 && calls <= 10000 && calls `mod` 5 == 0) (error "invalid batch size") - schedule <- map (T.splitOn ",") . T.lines . T.pack <$> readFile schedulePath - start <- getCurrentTime - withSharedMigratedPostgres $ withMigratedTestDatabase $ \connection -> - withStore (defaultConnectionSettings connection) $ \store -> do - sql store streamHeadFixtureSql - sql store "VACUUM (ANALYZE) stream_events" - details <- - Pool.use (store ^. #pool) $ - Session.statement () $ - preparable - "SELECT json_build_object('server', version(), 'shared_buffers', current_setting('shared_buffers'), 'work_mem', current_setting('work_mem'), 'jit', current_setting('jit'), 'plan_cache_mode', current_setting('plan_cache_mode'), 'streams', (SELECT count(*) FROM streams), 'events', (SELECT count(*) FROM events), 'junctions', (SELECT count(*) FROM stream_events))::text" - E.noParams - (D.singleRow (D.column (D.nonNullable D.text))) - either (error . show) (putStrLn . T.unpack) details - setup <- getCurrentTime - putStrLn ("setup_seconds=" <> show (diffUTCTime setup start)) - small <- actions store (StreamName "bench-1") (StreamVersion 100) - large <- actions store (StreamName "long-1") (StreamVersion 100000) - let (frozenSmall, productionSmall) = small - (frozenLarge, productionLarge) = large - groups = - [ ("legacy-100", (frozenSmall, productionSmall, calls)) - , ("legacy-100000", (frozenLarge, productionLarge, calls)) - , ("aa-100", (productionSmall, productionSmall, calls)) - , ("aa-100000", (productionLarge, productionLarge, calls)) - , ("positive-20pct", (productionLarge, productionLarge, calls * 6 `div` 5)) + [schedulePath, outputPath, callsText] <- getArgs + let calls = read callsText :: Int + unless (calls > 0 && calls <= 10000 && calls `mod` 5 == 0) (error "invalid batch size") + schedule <- map (T.splitOn ",") . T.lines . T.pack <$> readFile schedulePath + start <- getCurrentTime + withSharedMigratedPostgres $ withMigratedTestDatabase $ \connection -> + withStore (defaultConnectionSettings connection) $ \store -> do + sql store streamHeadFixtureSql + sql store "VACUUM (ANALYZE) stream_events" + details <- + Pool.use (store ^. #pool) $ + Session.statement () $ + preparable + "SELECT json_build_object('server', version(), 'shared_buffers', current_setting('shared_buffers'), 'work_mem', current_setting('work_mem'), 'jit', current_setting('jit'), 'plan_cache_mode', current_setting('plan_cache_mode'), 'streams', (SELECT count(*) FROM streams), 'events', (SELECT count(*) FROM events), 'junctions', (SELECT count(*) FROM stream_events))::text" + E.noParams + (D.singleRow (D.column (D.nonNullable D.text))) + either (error . show) (putStrLn . T.unpack) details + setup <- getCurrentTime + putStrLn ("setup_seconds=" <> show (diffUTCTime setup start)) + small <- actions store (StreamName "bench-1") (StreamVersion 100) + large <- actions store (StreamName "long-1") (StreamVersion 100000) + let (frozenSmall, productionSmall) = small + (frozenLarge, productionLarge) = large + groups = + [ ("legacy-100", (frozenSmall, productionSmall, calls)), + ("legacy-100000", (frozenLarge, productionLarge, calls)), + ("aa-100", (productionSmall, productionSmall, calls)), + ("aa-100000", (productionLarge, productionLarge, calls)), + ("positive-20pct", (productionLarge, productionLarge, calls * 6 `div` 5)) + ] + -- Warm both actual implementations and connections before measurement. + forM_ [frozenSmall, productionSmall, frozenLarge, productionLarge] (replicateM_ 1000) + warmed <- getCurrentTime + putStrLn ("warmup_seconds=" <> show (diffUTCTime warmed setup)) + withFile outputPath WriteMode $ \out -> do + hSetBuffering out LineBuffering + hPutStrLn out "round,case,order,slot,arm,calls,start_ns,end_ns,duration_ns" + forM_ schedule $ \row -> case row of + [roundText, caseName, order] -> do + unless (order == "ABBA" || order == "BAAB") (error "invalid order") + (armA, armB, callsB) <- maybe (error "unknown case") pure (lookup caseName groups) + forM_ (zip [0 :: Int ..] (T.unpack order)) $ \(slot, arm) -> do + let count = if arm == 'A' then calls else callsB + action = if arm == 'A' then armA else armB + before <- getMonotonicTimeNSec + replicateM_ count action + after <- getMonotonicTimeNSec + hPutStrLn out $ + T.unpack $ + T.intercalate + "," + [ roundText, + caseName, + order, + T.pack (show slot), + T.singleton arm, + T.pack (show count), + T.pack (show before), + T.pack (show after), + T.pack (show (after - before)) ] - -- Warm both actual implementations and connections before measurement. - forM_ [frozenSmall, productionSmall, frozenLarge, productionLarge] (replicateM_ 1000) - warmed <- getCurrentTime - putStrLn ("warmup_seconds=" <> show (diffUTCTime warmed setup)) - withFile outputPath WriteMode $ \out -> do - hSetBuffering out LineBuffering - hPutStrLn out "round,case,order,slot,arm,calls,start_ns,end_ns,duration_ns" - forM_ schedule $ \row -> case row of - [roundText, caseName, order] -> do - unless (order == "ABBA" || order == "BAAB") (error "invalid order") - (armA, armB, callsB) <- maybe (error "unknown case") pure (lookup caseName groups) - forM_ (zip [0 :: Int ..] (T.unpack order)) $ \(slot, arm) -> do - let count = if arm == 'A' then calls else callsB - action = if arm == 'A' then armA else armB - before <- getMonotonicTimeNSec - replicateM_ count action - after <- getMonotonicTimeNSec - hPutStrLn out $ - T.unpack $ - T.intercalate - "," - [ roundText - , caseName - , order - , T.pack (show slot) - , T.singleton arm - , T.pack (show count) - , T.pack (show before) - , T.pack (show after) - , T.pack (show (after - before)) - ] - _ -> error "invalid schedule row" - finished <- getCurrentTime - putStrLn ("measurement_seconds=" <> show (diffUTCTime finished warmed)) - putStrLn ("total_seconds=" <> show (diffUTCTime finished start)) + _ -> error "invalid schedule row" + finished <- getCurrentTime + putStrLn ("measurement_seconds=" <> show (diffUTCTime finished warmed)) + putStrLn ("total_seconds=" <> show (diffUTCTime finished start)) -- The A/A arms receive the same IO action, including validation. The positive -- control repeats that same action 20% more times, without normalizing it away. actions :: KirokuStore -> StreamName -> StreamVersion -> IO (IO (), IO ()) actions store name version = do - Right (Just expected) <- runFrozen store (getStream name) - unless (expected ^. #version == version) (error "invalid fixture version") - let validate result = case result of - Right (Just actual) -> unless (actual == expected) (error "unexpected metadata") - other -> error ("metadata read failed: " <> show other) - pure (runFrozen store (getStream name) >>= validate, runStoreIO store (getStream name) >>= validate) + Right (Just expected) <- runFrozen store (getStream name) + unless (expected ^. #version == version) (error "invalid fixture version") + let validate result = case result of + Right (Just actual) -> unless (actual == expected) (error "unexpected metadata") + other -> error ("metadata read failed: " <> show other) + pure (runFrozen store (getStream name) >>= validate, runStoreIO store (getStream name) >>= validate) sql :: KirokuStore -> T.Text -> IO () sql store command = Pool.use (store ^. #pool) (Session.script command) >>= either (error . show) pure @@ -113,33 +113,33 @@ frozenInterpreter :: (IOE :> es, Error StoreError :> es) => KirokuStore -> Eff (Store : es) a -> Eff es a frozenInterpreter store = interpret_ $ \case - GetStream (StreamName name) -> frozenPool (store ^. #pool) (Session.statement name frozenStatement) - _ -> error "unexpected operation in frozen metadata control" + GetStream (StreamName name) -> frozenPool (store ^. #pool) (Session.statement name frozenStatement) + _ -> error "unexpected operation in frozen metadata control" frozenPool :: (IOE :> es, Error StoreError :> es) => Pool.Pool -> Session.Session a -> Eff es a frozenPool pool session = do - result <- liftIO (Pool.use pool session) - case result of - Left usageErr -> throwError (ConnectionError (T.pack (show usageErr))) - Right a -> pure a + result <- liftIO (Pool.use pool session) + case result of + Left usageErr -> throwError (ConnectionError (T.pack (show usageErr))) + Right a -> pure a frozenStatement :: Statement T.Text (Maybe StreamInfo) frozenStatement = - preparable - """ - SELECT stream_id, stream_name, stream_version, created_at, deleted_at, truncate_before - FROM streams - WHERE stream_name = $1 - """ - (E.param (E.nonNullable E.text)) - (D.rowMaybe frozenRow) + preparable + """ + SELECT stream_id, stream_name, stream_version, created_at, deleted_at, truncate_before + FROM streams + WHERE stream_name = $1 + """ + (E.param (E.nonNullable E.text)) + (D.rowMaybe frozenRow) frozenRow :: D.Row StreamInfo frozenRow = - 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) - <*> (StreamVersion <$> D.column (D.nonNullable D.int8)) + 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) + <*> (StreamVersion <$> D.column (D.nonNullable D.int8)) diff --git a/kiroku-store.cabal b/kiroku-store.cabal --- a/kiroku-store.cabal +++ b/kiroku-store.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: kiroku-store -version: 0.11.0.1 +version: 0.12.0.0 synopsis: High-performance PostgreSQL event store description: Kiroku is a PostgreSQL-backed event store for Haskell applications. It @@ -122,6 +122,7 @@ Test.HistoryRetention Test.HistoryRetentionMock Test.InterpreterHooks + Test.NamespaceQueryPlans Test.NotifyGuard Test.PerformanceStructure Test.Properties @@ -146,6 +147,7 @@ Test.SubscriptionCheckpointWorker Test.SubscriptionDeadLetters Test.SubscriptionDeadLettersMock + Test.SubscriptionNamespace Test.SubscriptionPauseResume Test.SubscriptionReconnect Test.SubscriptionRegistry @@ -258,7 +260,7 @@ , kiroku-store , kiroku-test-support , lens >=5.2 && <5.4 - , shibuya-core >=0.10 && <0.11 + , shibuya-core >=0.12 && <0.13 , stm >=2.5 && <2.6 , streamly >=0.11 , streamly-core >=0.3 && <0.4 diff --git a/src/Kiroku/Store.hs b/src/Kiroku/Store.hs --- a/src/Kiroku/Store.hs +++ b/src/Kiroku/Store.hs @@ -1,14 +1,13 @@ -{- | 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, +-- | 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, @@ -47,7 +46,8 @@ ConnectionStatus (..), ConnectionReadyForUseReason (..), ConnectionTerminationReason (..), -) where + ) +where import Hasql.Pool.Observation (ConnectionReadyForUseReason (..), ConnectionStatus (..), ConnectionTerminationReason (..), Observation (..)) import Kiroku.Store.Append diff --git a/src/Kiroku/Store/Append.hs b/src/Kiroku/Store/Append.hs --- a/src/Kiroku/Store/Append.hs +++ b/src/Kiroku/Store/Append.hs @@ -1,7 +1,8 @@ -module Kiroku.Store.Append ( - appendToStream, +module Kiroku.Store.Append + ( appendToStream, appendMultiStream, -) where + ) +where import Effectful (Eff, (:>)) import Effectful.Dispatch.Dynamic (send) @@ -9,103 +10,101 @@ 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. -* 'Kiroku.Store.Error.EmptyAppendBatch' — the supplied event list is - empty. - -Empty event lists: passing @[]@ is a programming mistake. The -interpreter rejects the call with 'Kiroku.Store.Error.EmptyAppendBatch' -before any database work. This avoids taking the global @$all@ row lock, -firing notifications, or creating an empty stream under 'NoStream'. --} +-- | 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. +-- * 'Kiroku.Store.Error.EmptyAppendBatch' — the supplied event list is +-- empty. +-- +-- Empty event lists: passing @[]@ is a programming mistake. The +-- interpreter rejects the call with 'Kiroku.Store.Error.EmptyAppendBatch' +-- before any database work. This avoids taking the global @$all@ row lock, +-- firing notifications, or creating an empty stream under 'NoStream'. appendToStream :: - (HasCallStack, Store :> es) => - StreamName -> - ExpectedVersion -> - [EventData] -> - Eff es AppendResult + (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 operation input @[]@ returns @[]@ without a database round trip. -Any per-stream empty event list is rejected with -'Kiroku.Store.Error.EmptyAppendBatch' before the transaction opens. --} +-- | 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 operation input @[]@ returns @[]@ without a database round trip. +-- Any per-stream empty event list is rejected with +-- 'Kiroku.Store.Error.EmptyAppendBatch' before the transaction opens. appendMultiStream :: - (HasCallStack, Store :> es) => - [(StreamName, ExpectedVersion, [EventData])] -> - Eff es [AppendResult] + (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 --- a/src/Kiroku/Store/Causation.hs +++ b/src/Kiroku/Store/Causation.hs @@ -1,25 +1,25 @@ -{- | 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, +-- | 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 + ) +where import Data.UUID (UUID) import Data.Vector (Vector) @@ -29,38 +29,35 @@ 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. --} +-- | 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) + (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. --} +-- | 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) + (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. --} +-- | 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) + (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 --- a/src/Kiroku/Store/Connection.hs +++ b/src/Kiroku/Store/Connection.hs @@ -1,10 +1,11 @@ -module Kiroku.Store.Connection ( - KirokuStore (..), +module Kiroku.Store.Connection + ( KirokuStore (..), ConnectionSettingsM (..), ConnectionSettings, defaultConnectionSettings, withStore, -) where + ) +where import Control.Concurrent.STM (TVar, newTVarIO) import Control.Exception (bracket, onException) @@ -35,90 +36,84 @@ -- | 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) + { -- | PostgreSQL connection string (libpq URI or key=value format). + -- Reaches libpq verbatim; no application-level parsing or + -- substitution. May contain a password. + connString :: !Text, + -- | Connection pool size (default: 10) + poolSize :: !Int, + -- | 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. + schema :: !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). + extraSearchPath :: ![Text], + -- | idle_in_transaction_session_timeout in seconds (default: 30) + idleInTransactionTimeout :: !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. + statementTimeout :: !(Maybe Int), + -- | Optional callback for pool connection lifecycle events + observationHandler :: !(Maybe (Observation -> 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). + eventHandler :: !(Maybe (KirokuEvent -> m ())), + -- | 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. + storeSettings :: !StoreSettings + } + deriving stock (Generic) -- | Connection settings defaulting to 'IO'. type ConnectionSettings = ConnectionSettingsM IO @@ -126,154 +121,149 @@ -- | 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 - } + 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. + { pool :: !Pool, + schema :: !Text, + notifier :: !Notifier, + publisher :: !EventPublisher, + -- | 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'. + eventHandler :: !(Maybe (KirokuEvent -> IO ())), + -- | 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. + storeSettings :: !StoreSettings, + -- | 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'. + subscriptionRegistry :: !(TVar (Map (SubscriptionName, Int32) (Unique, TVar SubscriptionState))) + } + deriving stock (Generic) -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. --} +-- | 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) + 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) + 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) + 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 - } + 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) + -- 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. --} +-- | 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 --- a/src/Kiroku/Store/Effect.hs +++ b/src/Kiroku/Store/Effect.hs @@ -1,709 +1,696 @@ {-# 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.Except qualified as Except -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (Value) -import Data.Generics.Labels () -import Data.Int (Int32) -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.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.Decoders qualified as D -import Hasql.Encoders qualified as E -import Hasql.Pipeline qualified as Pipeline -import Hasql.Pool (Pool) -import Hasql.Pool qualified as Pool -import Hasql.Session qualified as Session -import Hasql.Statement (Statement, unpreparable) -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, isTransientSerializationError, mapGenericUsageError, mapLinkUsageError, mapTransactionUsageError, mapUsageError, validateStreamName) -import Kiroku.Store.HistoryRetention.Internal qualified as HistoryRetention -import Kiroku.Store.HistoryRetention.Types -import Kiroku.Store.Observability (KirokuEvent (..), emitOrDrop) -import Kiroku.Store.SQL qualified as SQL -import Kiroku.Store.Settings (StoreSettings (..), enrichEvents) -import Kiroku.Store.Subscription.Checkpoint.SQL qualified as CheckpointSQL -import Kiroku.Store.Subscription.CheckpointInventory.SQL qualified as CheckpointInventorySQL -import Kiroku.Store.Subscription.DeadLetter.SQL qualified as DeadLetterSQL -import Kiroku.Store.Subscription.Types ( - CheckpointInitialization, - MissingCheckpointPolicy, - SubscriptionCheckpointInventory, - SubscriptionCheckpointMissing, - SubscriptionDeadLetterPage, - SubscriptionDeadLetterQuery, - SubscriptionName, - ) -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) - {- | Read the greatest position whose @$all@ junction still survives, or - zero when no event remains visible. Unlike - 'Kiroku.Store.Subscription.subscriptionCheckpointInventory', this is a - visibility cursor rather than the authoritative append frontier. - - Surfaced as 'Kiroku.Store.Read.visibleGlobalHeadPosition'. - -} - GetVisibleGlobalHeadPosition :: Store m GlobalPosition - GetStream :: StreamName -> Store m (Maybe StreamInfo) - {- | One-statement metadata and newest surviving originated head observation. - Outer 'Nothing' means absent; inner 'Nothing' means no originated events, - including link-only streams and @$all@. Logical lifecycle markers do not - hide the head. Custom exhaustive interpreters must handle this constructor. - -} - GetStreamWithHead :: StreamName -> Store m (Maybe (StreamInfo, Maybe GlobalPosition)) - {- | 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) - {- | Check whether an event id exists in a live stream without materializing - stream events. Soft-deleted streams behave as nonexistent, mirroring - 'Kiroku.Store.Read.readStreamForward'. - - Surfaced as 'Kiroku.Store.Read.eventExistsInStream'. - -} - EventExistsInStream :: StreamName -> EventId -> Store m Bool - {- | 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) - {- | Byte-ordered names; optional exact category, literal prefix and exclusive cursor. - Includes soft-deleted streams, excludes only the reserved stream row. - -} - ListStreams :: Maybe CategoryName -> Maybe Text -> Maybe StreamName -> BrowsePageSize -> Store m (Vector StreamInfo) - -- | Deployment-collation category order with an exclusive cursor. - ListCategories :: Maybe CategoryName -> BrowsePageSize -> Store m (Vector CategoryName) - -- | The canonical global-log event; absent after hard deletion. - GetEvent :: EventId -> Store m (Maybe RecordedEvent) - 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) - {- | Set a stream's logical truncate-before marker. Per-stream ordered - reads then return only events whose version is >= the marker; the @$all@ - global log, category reads, and subscriptions are unaffected. Reversible. - - Surfaced as 'Kiroku.Store.Lifecycle.setStreamTruncateBefore' / - 'Kiroku.Store.Lifecycle.clearStreamTruncateBefore'. - -} - SetStreamTruncateBefore :: StreamName -> StreamVersion -> Store m (Maybe StreamId) - {- | Read the global store position and all durable subscription checkpoint - rows from one PostgreSQL statement snapshot. - - Surfaced as - 'Kiroku.Store.Subscription.subscriptionCheckpointInventory'. - -} - GetSubscriptionCheckpointInventory :: Store m SubscriptionCheckpointInventory - -- | Read-only keyset page; no event decode hook or checkpoint write. - ListSubscriptionDeadLetters :: SubscriptionDeadLetterQuery -> Store m SubscriptionDeadLetterPage - {- | Resolve one exact subscription checkpoint key according to its - missing-row policy. Existing rows always take precedence. - - Surfaced as - 'Kiroku.Store.Subscription.initializeSubscriptionCheckpoint'. - -} - InitializeSubscriptionCheckpoint :: - SubscriptionName -> - Int32 -> - MissingCheckpointPolicy -> - Store m (Either SubscriptionCheckpointMissing CheckpointInitialization) - AcquireHistoryRetentionLease :: HistoryRetentionLeaseRequest -> Store m HistoryRetentionLease - RenewHistoryRetentionLease :: - HistoryRetentionLeaseHandle -> - HistoryRetentionLeaseDuration -> - Store m (Either HistoryRetentionRenewalError HistoryRetentionLease) - ReleaseHistoryRetentionLease :: - HistoryRetentionLeaseHandle -> - Store m HistoryRetentionReleaseResult - GetHistoryRetentionLeaseInventory :: - HistoryRetentionInventoryQuery -> - Store m (Vector HistoryRetentionLease) - PruneHistoryRetentionLeases :: UTCTime -> Store m HistoryRetentionPruneResult - {- | 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 - rejectInvalidApplicationStream name - case events of - [] -> throwError (EmptyAppendBatch (StreamName name)) - _ -> pure () - events' <- liftIO $ enrichEvents (store ^. #storeSettings) events - now <- liftIO getCurrentTime - prepared <- prepareEvents events' - let params = buildAppendParams name now prepared - let runOnce = - 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 - firstAttempt <- liftIO runOnce - result <- case firstAttempt of - -- Match hasql-transaction's retryable SQLSTATE set, but only once: - -- PostgreSQL rolls back the victim transaction and event ids were - -- prepared before the first attempt, so this retry is idempotent. - Left usageErr - | isTransientSerializationError usageErr -> - liftIO runOnce - _ -> - pure firstAttempt - 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 - decodeReadEvents (store ^. #storeSettings) evs - ReadStreamBackward (StreamName name) (StreamVersion startVer) limit -> do - let cursor = if startVer == 0 then maxBound else startVer - evs <- - usePool (store ^. #pool) $ - Session.statement (name, cursor, limit) SQL.readStreamBackwardStmt - decodeReadEvents (store ^. #storeSettings) evs - ReadAllForward (GlobalPosition startPos) limit -> do - evs <- - usePool (store ^. #pool) $ - Session.statement (startPos, limit) SQL.readAllForwardStmt - decodeReadEvents (store ^. #storeSettings) evs - ReadAllBackward (GlobalPosition startPos) limit -> do - let cursor = if startPos == 0 then maxBound else startPos - evs <- - usePool (store ^. #pool) $ - Session.statement (cursor, limit) SQL.readAllBackwardStmt - decodeReadEvents (store ^. #storeSettings) evs - GetVisibleGlobalHeadPosition -> - usePool (store ^. #pool) $ - Session.statement () SQL.visibleGlobalHeadPositionStmt - GetStreamWithHead (StreamName name) -> - usePool (store ^. #pool) $ - Session.statement name SQL.getStreamWithHeadStmt - 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 - EventExistsInStream (StreamName name) (EventId eid) -> - usePool (store ^. #pool) $ - Session.statement (name, eid) SQL.eventExistsInStreamStmt - LookupStreamNames [] -> - pure Map.empty - 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 - ) - ListStreams category prefix after limit -> - usePool (store ^. #pool) (SQL.listStreamsSession category prefix after limit) - ListCategories after limit -> - fmap (V.map CategoryName) $ - usePool (store ^. #pool) $ - Session.statement (fmap (\(CategoryName value) -> value) after, browsePageSizeValue limit) (SQL.listCategoriesStmt (not (isNothing after))) - GetEvent (EventId eid) -> do - found <- usePool (store ^. #pool) $ Session.statement eid SQL.getEventStmt - decoded <- decodeReadEvents (store ^. #storeSettings) (maybe V.empty V.singleton found) - pure (decoded V.!? 0) - LinkToStream (StreamName name) eventIds -> do - rejectInvalidApplicationStream name - let uuids = V.fromList [uid | EventId uid <- eventIds] - result <- - liftIO $ - Pool.use (store ^. #pool) $ - Session.statement (uuids, name) SQL.linkToStreamStmt - case result of - Left usageErr -> throwError (mapLinkUsageError (StreamName name) usageErr) - Right Nothing -> throwError (StreamNotFound (StreamName name)) - Right (Just r) -> pure r - ReadCategoryForward (CategoryName cat) (GlobalPosition startPos) limit -> do - evs <- - usePool (store ^. #pool) $ - Session.statement (startPos, cat, limit) SQL.readCategoryForwardStmt - decodeReadEvents (store ^. #storeSettings) evs - AppendMultiStream [] -> - pure [] - AppendMultiStream ops -> do - case firstStreamNameError ops of - Just err -> throwError err - Nothing -> pure () - case find (\(_, _, evts) -> null evts) ops of - Just (sn, _, _) -> throwError (EmptyAppendBatch 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 runOnce = - Pool.use (store ^. #pool) $ - runAppendMultiStreamPipeline names now preparedOps - firstAttempt <- liftIO runOnce - result <- case firstAttempt of - -- Match the single-stream append retry and hasql-transaction's - -- retryable SQLSTATE set. The failed transaction has rolled back, - -- and event ids were prepared before the first attempt, so retrying - -- once is idempotent. - Left usageErr - | isTransientSerializationError usageErr -> - liftIO runOnce - _ -> - pure firstAttempt - 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 - decodeReadEvents (store ^. #storeSettings) evs - SoftDeleteStream (StreamName name) -> do - rejectInvalidApplicationStream name - usePool (store ^. #pool) $ - Session.statement name SQL.softDeleteStreamStmt - HardDeleteStream (StreamName name) -> do - rejectInvalidApplicationStream name - let txn = do - Tx.sql "SET LOCAL kiroku.enable_hard_deletes = 'on'" - HistoryRetention.lockHistoryRetentionCoordinatorTx - mSid <- Tx.statement name SQL.findStreamIdStmt - case mSid of - Nothing -> pure (Right Nothing) - Just sid -> do - conflict <- HistoryRetention.activeHistoryRetentionConflictTx - case conflict of - Just active -> pure (Left active) - Nothing -> do - HistoryRetention.lockAffectedStreamsForHardDeleteTx sid - originated <- Tx.statement sid SQL.deleteAllRowsForOriginStmt - Tx.statement originated SQL.deleteJunctionsByEventIdsStmt - linkedIn <- Tx.statement sid SQL.deleteStreamOwnJunctionsStmt - let affected = originated <> linkedIn - Tx.statement affected SQL.deleteDeadLettersForOrphanedEventsStmt - Tx.statement affected SQL.deleteOrphanedEventsStmt - Tx.statement sid SQL.deleteStreamRowStmt - pure (Right (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 - Right (Just sid) -> - liftIO $ emitOrDrop (store ^. #eventHandler) (KirokuEventHardDeleteIssued (StreamName name) sid) - Right Nothing -> pure () - Left conflict -> do - liftIO $ - emitOrDrop - (store ^. #eventHandler) - (KirokuEventHardDeleteHistoryRetentionConflict (StreamName name) conflict) - throwError (HistoryRetentionActive (StreamName name) conflict) - pure (either (const Nothing) (\value -> value) result) - UndeleteStream (StreamName name) -> do - rejectInvalidApplicationStream name - usePool (store ^. #pool) $ - Session.statement name SQL.undeleteStreamStmt - SetStreamTruncateBefore (StreamName name) (StreamVersion v) -> do - rejectInvalidApplicationStream name - usePool (store ^. #pool) $ - Session.statement (name, v) SQL.setStreamTruncateBeforeStmt - ListSubscriptionDeadLetters query -> - usePool (store ^. #pool) (DeadLetterSQL.listSubscriptionDeadLettersSession query) - GetSubscriptionCheckpointInventory -> - usePool (store ^. #pool) $ - Session.statement () CheckpointInventorySQL.getSubscriptionCheckpointInventoryStmt - InitializeSubscriptionCheckpoint subscriptionName member policy -> - usePool (store ^. #pool) $ - CheckpointSQL.initializeSubscriptionCheckpointSession subscriptionName member policy - AcquireHistoryRetentionLease request -> do - lease <- runTxOnPool (store ^. #pool) TxSessions.transaction (HistoryRetention.acquireHistoryRetentionLeaseTx request) - let HistoryRetentionLease{leaseId, owner, protectedThrough, expiresAt} = lease - liftIO $ - emitOrDrop - (store ^. #eventHandler) - (KirokuEventHistoryRetentionLeaseAcquired leaseId owner protectedThrough expiresAt) - pure lease - RenewHistoryRetentionLease handle duration -> do - result <- - runTxOnPool - (store ^. #pool) - TxSessions.transaction - (HistoryRetention.renewHistoryRetentionLeaseTx handle duration) - case result of - Right lease -> - let HistoryRetentionLease{leaseId, owner, expiresAt} = lease - in liftIO $ - emitOrDrop - (store ^. #eventHandler) - (KirokuEventHistoryRetentionLeaseRenewed leaseId owner expiresAt) - Left _ -> pure () - pure result - ReleaseHistoryRetentionLease handle -> do - result <- - runTxOnPool - (store ^. #pool) - TxSessions.transaction - (HistoryRetention.releaseHistoryRetentionLeaseTx handle) - case result of - HistoryRetentionReleased HistoryRetentionLease{leaseId, owner, releasedAt = Just releasedAt} -> - liftIO $ - emitOrDrop - (store ^. #eventHandler) - (KirokuEventHistoryRetentionLeaseReleased leaseId owner releasedAt) - _ -> pure () - pure result - GetHistoryRetentionLeaseInventory query -> - runTxOnPool - (store ^. #pool) - TxSessions.transaction - (HistoryRetention.historyRetentionLeaseInventoryTx query) - PruneHistoryRetentionLeases cutoff -> do - result <- - runTxOnPool - (store ^. #pool) - TxSessions.transaction - (HistoryRetention.pruneHistoryRetentionLeasesTx cutoff) - liftIO $ emitOrDrop (store ^. #eventHandler) (KirokuEventHistoryRetentionLeasesPruned result) - pure result - 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 (mapGenericUsageError 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 (mapTransactionUsageError usageErr) - Right a -> pure a - -rejectInvalidApplicationStream :: - (Error StoreError :> es) => - Text -> - Eff es () -rejectInvalidApplicationStream name = - either throwError pure (validateStreamName (StreamName name)) - -firstStreamNameError :: [(StreamName, ExpectedVersion, [EventData])] -> Maybe StoreError -firstStreamNameError ops = - case find (isLeft . validateStreamName . streamNameOf) ops of - Just (sn, _, _) -> either Just (const Nothing) (validateStreamName sn) - Nothing -> Nothing - where - streamNameOf (sn, _, _) = sn - isLeft = either (const True) (const False) - --- --------------------------------------------------------------------------- --- 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 - } - -multiAppendBeginStmt :: Statement () () -multiAppendBeginStmt = unpreparable "BEGIN" E.noParams D.noResult - -multiAppendCommitStmt :: Statement () () -multiAppendCommitStmt = unpreparable "COMMIT" E.noParams D.noResult - -multiAppendRollbackStmt :: Statement () () -multiAppendRollbackStmt = unpreparable "ROLLBACK" E.noParams D.noResult - -runAppendMultiStreamPipeline :: - Vector Text -> - UTCTime -> - [(StreamName, ExpectedVersion, [PreparedEvent])] -> - Session.Session [Maybe AppendResult] -runAppendMultiStreamPipeline names now preparedOps = - Except.catchError body $ \err -> do - Session.statement () multiAppendRollbackStmt - Except.throwError err - where - body = do - results <- - Session.pipeline $ - Pipeline.statement () multiAppendBeginStmt - -- 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. - *> Pipeline.statement names SQL.lockStreamsForMultiStmt - *> traverse appendPrepared preparedOps - Session.statement () $ - if any isNothing results - then multiAppendRollbackStmt - else multiAppendCommitStmt - pure results - - appendPrepared (StreamName name, expected, prepared) = - appendDispatchPipeline expected (buildAppendParams name now prepared) - -appendDispatchPipeline :: ExpectedVersion -> SQL.AppendParams -> Pipeline.Pipeline (Maybe AppendResult) -appendDispatchPipeline expected params = case expected of - ExactVersion (StreamVersion v) -> - Pipeline.statement (params, v) SQL.appendExpectedVersion - StreamExists -> - Pipeline.statement params SQL.appendStreamExists - NoStream -> - Pipeline.statement params SQL.appendNoStream - AnyVersion -> - Pipeline.statement params SQL.appendAnyVersion - -{- | 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. --} - --- No hook preserves the direct read passthrough. Successful hooks map directly --- into a result vector, avoiding the subscription-specific wrapper/unwrapper. -decodeReadEvents :: (IOE :> es, Error StoreError :> es) => StoreSettings -> Vector RecordedEvent -> Eff es (Vector RecordedEvent) -decodeReadEvents settings events = case decodeHook settings of - Nothing -> pure events - Just hook -> V.mapM (\event -> liftIO (hook event) >>= either (throwError . EventDecodeFailed) pure) events +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.Except qualified as Except +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (Value) +import Data.Generics.Labels () +import Data.Int (Int32) +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.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.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Pipeline qualified as Pipeline +import Hasql.Pool (Pool) +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.Connection (KirokuStore (..)) +import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore) +import Kiroku.Store.Error (StoreError (..), attributeMultiStreamError, emptyResultError, isTransientSerializationError, mapGenericUsageError, mapLinkUsageError, mapTransactionUsageError, mapUsageError, validateStreamName) +import Kiroku.Store.HistoryRetention.Internal qualified as HistoryRetention +import Kiroku.Store.HistoryRetention.Types +import Kiroku.Store.Observability (KirokuEvent (..), emitOrDrop) +import Kiroku.Store.SQL qualified as SQL +import Kiroku.Store.Settings (StoreSettings (..), enrichEvents) +import Kiroku.Store.Subscription.Checkpoint.SQL qualified as CheckpointSQL +import Kiroku.Store.Subscription.CheckpointInventory.SQL qualified as CheckpointInventorySQL +import Kiroku.Store.Subscription.DeadLetter.SQL qualified as DeadLetterSQL +import Kiroku.Store.Subscription.Types + ( CheckpointInitialization, + MissingCheckpointPolicy, + SubscriptionCheckpointInventory, + SubscriptionCheckpointMissing, + SubscriptionDeadLetterPage, + SubscriptionDeadLetterQuery, + SubscriptionName, + ) +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) + -- | Read the greatest position whose @$all@ junction still survives, or + -- zero when no event remains visible. Unlike + -- 'Kiroku.Store.Subscription.subscriptionCheckpointInventory', this is a + -- visibility cursor rather than the authoritative append frontier. + -- + -- Surfaced as 'Kiroku.Store.Read.visibleGlobalHeadPosition'. + GetVisibleGlobalHeadPosition :: Store m GlobalPosition + GetStream :: StreamName -> Store m (Maybe StreamInfo) + -- | One-statement metadata and newest surviving originated head observation. + -- Outer 'Nothing' means absent; inner 'Nothing' means no originated events, + -- including link-only streams and @$all@. Logical lifecycle markers do not + -- hide the head. Custom exhaustive interpreters must handle this constructor. + GetStreamWithHead :: StreamName -> Store m (Maybe (StreamInfo, Maybe GlobalPosition)) + -- | 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) + -- | Check whether an event id exists in a live stream without materializing + -- stream events. Soft-deleted streams behave as nonexistent, mirroring + -- 'Kiroku.Store.Read.readStreamForward'. + -- + -- Surfaced as 'Kiroku.Store.Read.eventExistsInStream'. + EventExistsInStream :: StreamName -> EventId -> Store m Bool + -- | 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) + -- | Byte-ordered names; optional exact category, literal prefix and exclusive cursor. + -- Includes soft-deleted streams, excludes only the reserved stream row. + ListStreams :: Maybe CategoryName -> Maybe Text -> Maybe StreamName -> BrowsePageSize -> Store m (Vector StreamInfo) + -- | Deployment-collation category order with an exclusive cursor. + ListCategories :: Maybe CategoryName -> BrowsePageSize -> Store m (Vector CategoryName) + -- | The canonical global-log event; absent after hard deletion. + GetEvent :: EventId -> Store m (Maybe RecordedEvent) + 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) + -- | Set a stream's logical truncate-before marker. Per-stream ordered + -- reads then return only events whose version is >= the marker; the @$all@ + -- global log, category reads, and subscriptions are unaffected. Reversible. + -- + -- Surfaced as 'Kiroku.Store.Lifecycle.setStreamTruncateBefore' / + -- 'Kiroku.Store.Lifecycle.clearStreamTruncateBefore'. + SetStreamTruncateBefore :: StreamName -> StreamVersion -> Store m (Maybe StreamId) + -- | Read the global store position and all durable subscription checkpoint + -- rows from one PostgreSQL statement snapshot. + -- + -- Surfaced as + -- 'Kiroku.Store.Subscription.subscriptionCheckpointInventory'. + GetSubscriptionCheckpointInventory :: Store m SubscriptionCheckpointInventory + -- | Read-only keyset page; no event decode hook or checkpoint write. + ListSubscriptionDeadLetters :: SubscriptionDeadLetterQuery -> Store m SubscriptionDeadLetterPage + -- | Resolve one exact subscription checkpoint key according to its + -- missing-row policy. Existing rows always take precedence. + -- + -- Surfaced as + -- 'Kiroku.Store.Subscription.initializeSubscriptionCheckpoint'. + InitializeSubscriptionCheckpoint :: + SubscriptionName -> + Int32 -> + MissingCheckpointPolicy -> + Store m (Either SubscriptionCheckpointMissing CheckpointInitialization) + AcquireHistoryRetentionLease :: HistoryRetentionLeaseRequest -> Store m HistoryRetentionLease + RenewHistoryRetentionLease :: + HistoryRetentionLeaseHandle -> + HistoryRetentionLeaseDuration -> + Store m (Either HistoryRetentionRenewalError HistoryRetentionLease) + ReleaseHistoryRetentionLease :: + HistoryRetentionLeaseHandle -> + Store m HistoryRetentionReleaseResult + GetHistoryRetentionLeaseInventory :: + HistoryRetentionInventoryQuery -> + Store m (Vector HistoryRetentionLease) + PruneHistoryRetentionLeases :: UTCTime -> Store m HistoryRetentionPruneResult + -- | 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 + rejectInvalidApplicationStream name + case events of + [] -> throwError (EmptyAppendBatch (StreamName name)) + _ -> pure () + events' <- liftIO $ enrichEvents (store ^. #storeSettings) events + now <- liftIO getCurrentTime + prepared <- prepareEvents events' + let params = buildAppendParams name now prepared + let runOnce = + 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 + firstAttempt <- liftIO runOnce + result <- case firstAttempt of + -- Match hasql-transaction's retryable SQLSTATE set, but only once: + -- PostgreSQL rolls back the victim transaction and event ids were + -- prepared before the first attempt, so this retry is idempotent. + Left usageErr + | isTransientSerializationError usageErr -> + liftIO runOnce + _ -> + pure firstAttempt + 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 + decodeReadEvents (store ^. #storeSettings) evs + ReadStreamBackward (StreamName name) (StreamVersion startVer) limit -> do + let cursor = if startVer == 0 then maxBound else startVer + evs <- + usePool (store ^. #pool) $ + Session.statement (name, cursor, limit) SQL.readStreamBackwardStmt + decodeReadEvents (store ^. #storeSettings) evs + ReadAllForward (GlobalPosition startPos) limit -> do + evs <- + usePool (store ^. #pool) $ + Session.statement (startPos, limit) SQL.readAllForwardStmt + decodeReadEvents (store ^. #storeSettings) evs + ReadAllBackward (GlobalPosition startPos) limit -> do + let cursor = if startPos == 0 then maxBound else startPos + evs <- + usePool (store ^. #pool) $ + Session.statement (cursor, limit) SQL.readAllBackwardStmt + decodeReadEvents (store ^. #storeSettings) evs + GetVisibleGlobalHeadPosition -> + usePool (store ^. #pool) $ + Session.statement () SQL.visibleGlobalHeadPositionStmt + GetStreamWithHead (StreamName name) -> + usePool (store ^. #pool) $ + Session.statement name SQL.getStreamWithHeadStmt + 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 + EventExistsInStream (StreamName name) (EventId eid) -> + usePool (store ^. #pool) $ + Session.statement (name, eid) SQL.eventExistsInStreamStmt + LookupStreamNames [] -> + pure Map.empty + 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 + ) + ListStreams category prefix after limit -> + usePool (store ^. #pool) (SQL.listStreamsSession category prefix after limit) + ListCategories after limit -> + fmap (V.map CategoryName) $ + usePool (store ^. #pool) $ + Session.statement (fmap (\(CategoryName value) -> value) after, browsePageSizeValue limit) (SQL.listCategoriesStmt (not (isNothing after))) + GetEvent (EventId eid) -> do + found <- usePool (store ^. #pool) $ Session.statement eid SQL.getEventStmt + decoded <- decodeReadEvents (store ^. #storeSettings) (maybe V.empty V.singleton found) + pure (decoded V.!? 0) + LinkToStream (StreamName name) eventIds -> do + rejectInvalidApplicationStream name + let uuids = V.fromList [uid | EventId uid <- eventIds] + result <- + liftIO $ + Pool.use (store ^. #pool) $ + Session.statement (uuids, name) SQL.linkToStreamStmt + case result of + Left usageErr -> throwError (mapLinkUsageError (StreamName name) usageErr) + Right Nothing -> throwError (StreamNotFound (StreamName name)) + Right (Just r) -> pure r + ReadCategoryForward (CategoryName cat) (GlobalPosition startPos) limit -> do + evs <- + usePool (store ^. #pool) $ + Session.statement (startPos, cat, limit) SQL.readCategoryForwardStmt + decodeReadEvents (store ^. #storeSettings) evs + AppendMultiStream [] -> + pure [] + AppendMultiStream ops -> do + case firstStreamNameError ops of + Just err -> throwError err + Nothing -> pure () + case find (\(_, _, evts) -> null evts) ops of + Just (sn, _, _) -> throwError (EmptyAppendBatch 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 runOnce = + Pool.use (store ^. #pool) $ + runAppendMultiStreamPipeline names now preparedOps + firstAttempt <- liftIO runOnce + result <- case firstAttempt of + -- Match the single-stream append retry and hasql-transaction's + -- retryable SQLSTATE set. The failed transaction has rolled back, + -- and event ids were prepared before the first attempt, so retrying + -- once is idempotent. + Left usageErr + | isTransientSerializationError usageErr -> + liftIO runOnce + _ -> + pure firstAttempt + 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 + decodeReadEvents (store ^. #storeSettings) evs + SoftDeleteStream (StreamName name) -> do + rejectInvalidApplicationStream name + usePool (store ^. #pool) $ + Session.statement name SQL.softDeleteStreamStmt + HardDeleteStream (StreamName name) -> do + rejectInvalidApplicationStream name + let txn = do + Tx.sql "SET LOCAL kiroku.enable_hard_deletes = 'on'" + HistoryRetention.lockHistoryRetentionCoordinatorTx + mSid <- Tx.statement name SQL.findStreamIdStmt + case mSid of + Nothing -> pure (Right Nothing) + Just sid -> do + conflict <- HistoryRetention.activeHistoryRetentionConflictTx + case conflict of + Just active -> pure (Left active) + Nothing -> do + HistoryRetention.lockAffectedStreamsForHardDeleteTx sid + originated <- Tx.statement sid SQL.deleteAllRowsForOriginStmt + Tx.statement originated SQL.deleteJunctionsByEventIdsStmt + linkedIn <- Tx.statement sid SQL.deleteStreamOwnJunctionsStmt + let affected = originated <> linkedIn + Tx.statement affected SQL.deleteDeadLettersForOrphanedEventsStmt + Tx.statement affected SQL.deleteOrphanedEventsStmt + Tx.statement sid SQL.deleteStreamRowStmt + pure (Right (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 + Right (Just sid) -> + liftIO $ emitOrDrop (store ^. #eventHandler) (KirokuEventHardDeleteIssued (StreamName name) sid) + Right Nothing -> pure () + Left conflict -> do + liftIO $ + emitOrDrop + (store ^. #eventHandler) + (KirokuEventHardDeleteHistoryRetentionConflict (StreamName name) conflict) + throwError (HistoryRetentionActive (StreamName name) conflict) + pure (either (const Nothing) (\value -> value) result) + UndeleteStream (StreamName name) -> do + rejectInvalidApplicationStream name + usePool (store ^. #pool) $ + Session.statement name SQL.undeleteStreamStmt + SetStreamTruncateBefore (StreamName name) (StreamVersion v) -> do + rejectInvalidApplicationStream name + usePool (store ^. #pool) $ + Session.statement (name, v) SQL.setStreamTruncateBeforeStmt + ListSubscriptionDeadLetters query -> + usePool (store ^. #pool) (DeadLetterSQL.listSubscriptionDeadLettersSession query) + GetSubscriptionCheckpointInventory -> + usePool (store ^. #pool) $ + Session.statement () CheckpointInventorySQL.getSubscriptionCheckpointInventoryStmt + InitializeSubscriptionCheckpoint subscriptionName member policy -> + usePool (store ^. #pool) $ + CheckpointSQL.initializeSubscriptionCheckpointSession subscriptionName member policy + AcquireHistoryRetentionLease request -> do + lease <- runTxOnPool (store ^. #pool) TxSessions.transaction (HistoryRetention.acquireHistoryRetentionLeaseTx request) + let HistoryRetentionLease {leaseId, owner, protectedThrough, expiresAt} = lease + liftIO $ + emitOrDrop + (store ^. #eventHandler) + (KirokuEventHistoryRetentionLeaseAcquired leaseId owner protectedThrough expiresAt) + pure lease + RenewHistoryRetentionLease handle duration -> do + result <- + runTxOnPool + (store ^. #pool) + TxSessions.transaction + (HistoryRetention.renewHistoryRetentionLeaseTx handle duration) + case result of + Right lease -> + let HistoryRetentionLease {leaseId, owner, expiresAt} = lease + in liftIO $ + emitOrDrop + (store ^. #eventHandler) + (KirokuEventHistoryRetentionLeaseRenewed leaseId owner expiresAt) + Left _ -> pure () + pure result + ReleaseHistoryRetentionLease handle -> do + result <- + runTxOnPool + (store ^. #pool) + TxSessions.transaction + (HistoryRetention.releaseHistoryRetentionLeaseTx handle) + case result of + HistoryRetentionReleased HistoryRetentionLease {leaseId, owner, releasedAt = Just releasedAt} -> + liftIO $ + emitOrDrop + (store ^. #eventHandler) + (KirokuEventHistoryRetentionLeaseReleased leaseId owner releasedAt) + _ -> pure () + pure result + GetHistoryRetentionLeaseInventory query -> + runTxOnPool + (store ^. #pool) + TxSessions.transaction + (HistoryRetention.historyRetentionLeaseInventoryTx query) + PruneHistoryRetentionLeases cutoff -> do + result <- + runTxOnPool + (store ^. #pool) + TxSessions.transaction + (HistoryRetention.pruneHistoryRetentionLeasesTx cutoff) + liftIO $ emitOrDrop (store ^. #eventHandler) (KirokuEventHistoryRetentionLeasesPruned result) + pure result + 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 (mapGenericUsageError 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 (mapTransactionUsageError usageErr) + Right a -> pure a + +rejectInvalidApplicationStream :: + (Error StoreError :> es) => + Text -> + Eff es () +rejectInvalidApplicationStream name = + either throwError pure (validateStreamName (StreamName name)) + +firstStreamNameError :: [(StreamName, ExpectedVersion, [EventData])] -> Maybe StoreError +firstStreamNameError ops = + case find (isLeft . validateStreamName . streamNameOf) ops of + Just (sn, _, _) -> either Just (const Nothing) (validateStreamName sn) + Nothing -> Nothing + where + streamNameOf (sn, _, _) = sn + isLeft = either (const True) (const False) + +-- --------------------------------------------------------------------------- +-- 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 + } + +-- Cache transaction-control statements just like hasql-transaction; reparsing +-- them on every multi-stream call erodes the pipeline's round-trip savings. +multiAppendBeginStmt :: Statement () () +multiAppendBeginStmt = preparable "BEGIN" E.noParams D.noResult + +multiAppendCommitStmt :: Statement () () +multiAppendCommitStmt = preparable "COMMIT" E.noParams D.noResult + +multiAppendRollbackStmt :: Statement () () +multiAppendRollbackStmt = preparable "ROLLBACK" E.noParams D.noResult + +runAppendMultiStreamPipeline :: + Vector Text -> + UTCTime -> + [(StreamName, ExpectedVersion, [PreparedEvent])] -> + Session.Session [Maybe AppendResult] +runAppendMultiStreamPipeline names now preparedOps = + Except.catchError body $ \err -> do + Session.statement () multiAppendRollbackStmt + Except.throwError err + where + body = do + results <- + Session.pipeline $ + Pipeline.statement () multiAppendBeginStmt + -- 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. + *> Pipeline.statement names SQL.lockStreamsForMultiStmt + *> traverse appendPrepared preparedOps + Session.statement () $ + if any isNothing results + then multiAppendRollbackStmt + else multiAppendCommitStmt + pure results + + appendPrepared (StreamName name, expected, prepared) = + appendDispatchPipeline expected (buildAppendParams name now prepared) + +appendDispatchPipeline :: ExpectedVersion -> SQL.AppendParams -> Pipeline.Pipeline (Maybe AppendResult) +appendDispatchPipeline expected params = case expected of + ExactVersion (StreamVersion v) -> + Pipeline.statement (params, v) SQL.appendExpectedVersion + StreamExists -> + Pipeline.statement params SQL.appendStreamExists + NoStream -> + Pipeline.statement params SQL.appendNoStream + AnyVersion -> + Pipeline.statement params SQL.appendAnyVersion + +-- | 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. + +-- No hook preserves the direct read passthrough. Successful hooks map directly +-- into a result vector, avoiding the subscription-specific wrapper/unwrapper. +decodeReadEvents :: (IOE :> es, Error StoreError :> es) => StoreSettings -> Vector RecordedEvent -> Eff es (Vector RecordedEvent) +decodeReadEvents settings events = case decodeHook settings of + Nothing -> pure events + Just hook -> V.mapM (\event -> liftIO (hook event) >>= either (throwError . EventDecodeFailed) pure) events diff --git a/src/Kiroku/Store/Effect/Resource.hs b/src/Kiroku/Store/Effect/Resource.hs --- a/src/Kiroku/Store/Effect/Resource.hs +++ b/src/Kiroku/Store/Effect/Resource.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies #-} -module Kiroku.Store.Effect.Resource ( - -- * The KirokuStoreResource effect +module Kiroku.Store.Effect.Resource + ( -- * The KirokuStoreResource effect KirokuStoreResource, -- * Operations @@ -12,7 +12,8 @@ -- * Runner over an existing handle runKirokuStoreWith, -) where + ) +where import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, UnliftStrategy (..), withEffToIO, (:>)) import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, getStaticRep) @@ -22,18 +23,17 @@ -- 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. --} +-- | 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 @@ -43,34 +43,33 @@ -- | Retrieve the 'KirokuStore' handle from the effect stack. getKirokuStore :: (KirokuStoreResource :> es) => Eff es KirokuStore getKirokuStore = do - KirokuStoreResource store <- getStaticRep - pure store + 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 + (IOE :> es) => + ConnectionSettings -> + Eff (KirokuStoreResource : es) a -> + Eff es a withKirokuStore settings action = withEffToIO SeqUnlift $ \unlift -> - withStore settings $ \store -> - unlift (evalStaticRep (KirokuStoreResource store) action) - -{- | Install an /already acquired/ 'KirokuStore' into the effect stack. - -Unlike 'withKirokuStore', this neither acquires nor releases: the caller owns -the handle's lifetime. Use it when a process has opened exactly one store (the -documented arrangement) and needs to run several independent effectful actions -against it. Acquiring a store per action instead costs a connection pool, a -dedicated @LISTEN@ connection, and a publisher thread each time. + withStore settings $ \store -> + unlift (evalStaticRep (KirokuStoreResource store) action) -There is no bracket and no unlifting here, but @IOE@ is still required: -'KirokuStoreResource' is @Static WithSideEffects@, and 'evalStaticRep' demands -@IOE@ for any effect declared that way. --} +-- | Install an /already acquired/ 'KirokuStore' into the effect stack. +-- +-- Unlike 'withKirokuStore', this neither acquires nor releases: the caller owns +-- the handle's lifetime. Use it when a process has opened exactly one store (the +-- documented arrangement) and needs to run several independent effectful actions +-- against it. Acquiring a store per action instead costs a connection pool, a +-- dedicated @LISTEN@ connection, and a publisher thread each time. +-- +-- There is no bracket and no unlifting here, but @IOE@ is still required: +-- 'KirokuStoreResource' is @Static WithSideEffects@, and 'evalStaticRep' demands +-- @IOE@ for any effect declared that way. runKirokuStoreWith :: - (IOE :> es) => - KirokuStore -> - Eff (KirokuStoreResource : es) a -> - Eff es a + (IOE :> es) => + KirokuStore -> + Eff (KirokuStoreResource : es) a -> + Eff es a runKirokuStoreWith = evalStaticRep . KirokuStoreResource diff --git a/src/Kiroku/Store/Error.hs b/src/Kiroku/Store/Error.hs --- a/src/Kiroku/Store/Error.hs +++ b/src/Kiroku/Store/Error.hs @@ -1,5 +1,5 @@ -module Kiroku.Store.Error ( - StoreError (..), +module Kiroku.Store.Error + ( StoreError (..), maxStreamNameBytes, validateStreamName, @@ -17,7 +17,8 @@ isTransientSerializationError, -- Internal pure helper exposed for unit testing extractStreamNameFromDetail, -) where + ) +where import Control.Applicative ((<|>)) import Control.Exception (Exception) @@ -36,142 +37,127 @@ import Kiroku.Store.Settings (DecodeFailure) 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'). --} +-- | 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 placeholder. The append statement returns zero rows on a - version mismatch and the store does not issue an extra read to - recover the live version, so this field is 'StreamVersion' 0 on - every empty-CTE rejection. Callers needing the live version must - read the stream, for example with 'Kiroku.Store.Read.getStream'. - -} - WrongExpectedVersion !StreamName !ExpectedVersion !StreamVersion - | {- | The caller supplied an empty event batch to an append surface. - - Appending zero events is always a programming mistake: before this - guard existed, an empty batch silently took the global @$all@ row - lock, fired NOTIFY triggers, and under 'NoStream' even created an - empty stream. The interpreter rejects it before any pool work. - -} - EmptyAppendBatch !StreamName - | -- | The named stream does not exist (or has been soft-deleted). - StreamNotFound !StreamName - | {- | A supported hard delete found one or more active replay-history - retention leases and committed no destructive work. - -} - HistoryRetentionActive !StreamName !HistoryRetentionConflict - | {- | 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 stream name exceeds 'maxStreamNameBytes' bytes of UTF-8. - - The append notification payload embeds the stream name, and - PostgreSQL rejects @pg_notify@ payloads of 8,000 bytes or more. - Enforcing a much smaller byte bound before any database work - prevents an oversized stream name from failing late as an opaque - trigger/server error. The second field is the offending UTF-8 - byte length. - -} - StreamNameTooLong !StreamName !Int - | {- | 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. - - Append maps both @events_pkey@ and the composite - @stream_events_pkey@ to this constructor. - - 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) - | {- | A 'Kiroku.Store.Link.linkToStream' call tried to link an - event into a target stream that already contains it. - - Maps the @23505@ unique violation on @stream_events_pkey@, whose - key is @(event_id, stream_id)@. Carries 'Just' the offending event - id when PostgreSQL's detail string is parseable. - -} - EventAlreadyLinked !StreamName !(Maybe EventId) - | {- | A 'Kiroku.Store.Link.linkToStream' call referenced an event id - that does not exist. The link CTE surfaces this as a @23502@ - not-null violation on @stream_events.original_stream_id@ and the - whole batch rolls back. - -} - LinkSourceEventMissing !StreamName - | {- | 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 aborted the transaction with a class-40 - (transaction rollback) @SQLSTATE@: @40001@ serialization_failure - or @40P01@ deadlock_detected. The first 'Text' is the @SQLSTATE@ - code, the second is the human-readable message. - - __Retryable.__ PostgreSQL rolled the transaction back completely - and expects the client to run it again; nothing was committed. - The store already retries an append once on these codes before - surfacing them, so reaching a caller means the conflict repeated - — retry with backoff rather than escalating. - - Appends are safe to retry when the caller supplies - 'Kiroku.Store.Types.EventData.eventId' values, which makes the - retry idempotent; see the "Idempotent retries" note on - 'Kiroku.Store.Append.appendToStream'. - -} - TransientTransactionFailure !Text !Text - | {- | PostgreSQL raised a server error whose @SQLSTATE@ code is - outside the set this store recognises, or an append violated - @ux_stream_events_stream_version@ (@23505@), indicating an - internal stream-version invariant failure. 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 - | -- | A decode hook refused an event; the read returns no partial result. - EventDecodeFailed !DecodeFailure - deriving stock (Eq, Show, Generic) - deriving anyclass (Exception) + = -- | The actual stream version did not match the caller's + -- 'ExactVersion' expectation. The third field is the actual + -- version placeholder. The append statement returns zero rows on a + -- version mismatch and the store does not issue an extra read to + -- recover the live version, so this field is 'StreamVersion' 0 on + -- every empty-CTE rejection. Callers needing the live version must + -- read the stream, for example with 'Kiroku.Store.Read.getStream'. + WrongExpectedVersion !StreamName !ExpectedVersion !StreamVersion + | -- | The caller supplied an empty event batch to an append surface. + -- + -- Appending zero events is always a programming mistake: before this + -- guard existed, an empty batch silently took the global @$all@ row + -- lock, fired NOTIFY triggers, and under 'NoStream' even created an + -- empty stream. The interpreter rejects it before any pool work. + EmptyAppendBatch !StreamName + | -- | The named stream does not exist (or has been soft-deleted). + StreamNotFound !StreamName + | -- | A supported hard delete found one or more active replay-history + -- retention leases and committed no destructive work. + HistoryRetentionActive !StreamName !HistoryRetentionConflict + | -- | 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 stream name exceeds 'maxStreamNameBytes' bytes of UTF-8. + -- + -- The append notification payload embeds the stream name, and + -- PostgreSQL rejects @pg_notify@ payloads of 8,000 bytes or more. + -- Enforcing a much smaller byte bound before any database work + -- prevents an oversized stream name from failing late as an opaque + -- trigger/server error. The second field is the offending UTF-8 + -- byte length. + StreamNameTooLong !StreamName !Int + | -- | 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. + -- + -- Append maps both @events_pkey@ and the composite + -- @stream_events_pkey@ to this constructor. + -- + -- 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) + | -- | A 'Kiroku.Store.Link.linkToStream' call tried to link an + -- event into a target stream that already contains it. + -- + -- Maps the @23505@ unique violation on @stream_events_pkey@, whose + -- key is @(event_id, stream_id)@. Carries 'Just' the offending event + -- id when PostgreSQL's detail string is parseable. + EventAlreadyLinked !StreamName !(Maybe EventId) + | -- | A 'Kiroku.Store.Link.linkToStream' call referenced an event id + -- that does not exist. The link CTE surfaces this as a @23502@ + -- not-null violation on @stream_events.original_stream_id@ and the + -- whole batch rolls back. + LinkSourceEventMissing !StreamName + | -- | 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 aborted the transaction with a class-40 + -- (transaction rollback) @SQLSTATE@: @40001@ serialization_failure + -- or @40P01@ deadlock_detected. The first 'Text' is the @SQLSTATE@ + -- code, the second is the human-readable message. + -- + -- __Retryable.__ PostgreSQL rolled the transaction back completely + -- and expects the client to run it again; nothing was committed. + -- The store already retries an append once on these codes before + -- surfacing them, so reaching a caller means the conflict repeated + -- — retry with backoff rather than escalating. + -- + -- Appends are safe to retry when the caller supplies + -- 'Kiroku.Store.Types.EventData.eventId' values, which makes the + -- retry idempotent; see the "Idempotent retries" note on + -- 'Kiroku.Store.Append.appendToStream'. + TransientTransactionFailure !Text !Text + | -- | PostgreSQL raised a server error whose @SQLSTATE@ code is + -- outside the set this store recognises, or an append violated + -- @ux_stream_events_stream_version@ (@23505@), indicating an + -- internal stream-version invariant failure. 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 + | -- | A decode hook refused an event; the read returns no partial result. + EventDecodeFailed !DecodeFailure + deriving stock (Eq, Show, Generic) + deriving anyclass (Exception) -- | Maximum stream-name length in UTF-8 bytes. maxStreamNameBytes :: Int @@ -180,379 +166,364 @@ -- | Validate application stream names before any database work. validateStreamName :: StreamName -> Either StoreError () validateStreamName sn@(StreamName name) - | name == "$all" = Left (ReservedStreamName sn) - | byteLength > maxStreamNameBytes = Left (StreamNameTooLong sn byteLength) - | otherwise = Right () + | name == "$all" = Left (ReservedStreamName sn) + | byteLength > maxStreamNameBytes = Left (StreamNameTooLong sn byteLength) + | otherwise = Right () where byteLength = BS.length (TE.encodeUtf8 name) -{- | Map a hasql 'UsageError' to a 'StoreError'. - -Pattern matches on the error hierarchy: - UsageError -> SessionUsageError -> StatementSessionError -> ServerStatementError -> ServerError - UsageError -> SessionUsageError -> ScriptSessionError -> ServerError - -Scripts and statements share server classification. Connection establishment -and session connection loss use 'ConnectionLost'; acquisition timeout uses -'PoolAcquisitionTimeout'. Unsupported non-server errors retain 'ConnectionError'. - -PostgreSQL error code mapping: - 23505 (unique_violation) + events_pkey -> 'DuplicateEvent' - 23505 (unique_violation) + stream_events_pkey -> 'DuplicateEvent' - 23505 + ux_stream_events_stream_version -> 'UnexpectedServerError' - 23505 (unique_violation) + ix_streams_stream_name -> 'StreamAlreadyExists' - 23505 (unique_violation) + other -> 'WrongExpectedVersion' - 23503 (foreign_key_violation) -> 'StreamNotFound' - 40001 / 40P01 -> 'TransientTransactionFailure' - any other server code -> 'UnexpectedServerError' - -Constraint names are compared exactly, with the quoted message taking -precedence over a delimiter-aware detail fallback. Matching depends on the -four literal names above. 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/migrations@. --} +-- | Map a hasql 'UsageError' to a 'StoreError'. +-- +-- Pattern matches on the error hierarchy: +-- UsageError -> SessionUsageError -> StatementSessionError -> ServerStatementError -> ServerError +-- UsageError -> SessionUsageError -> ScriptSessionError -> ServerError +-- +-- Scripts and statements share server classification. Connection establishment +-- and session connection loss use 'ConnectionLost'; acquisition timeout uses +-- 'PoolAcquisitionTimeout'. Unsupported non-server errors retain 'ConnectionError'. +-- +-- PostgreSQL error code mapping: +-- 23505 (unique_violation) + events_pkey -> 'DuplicateEvent' +-- 23505 (unique_violation) + stream_events_pkey -> 'DuplicateEvent' +-- 23505 + ux_stream_events_stream_version -> 'UnexpectedServerError' +-- 23505 (unique_violation) + ix_streams_stream_name -> 'StreamAlreadyExists' +-- 23505 (unique_violation) + other -> 'WrongExpectedVersion' +-- 23503 (foreign_key_violation) -> 'StreamNotFound' +-- 40001 / 40P01 -> 'TransientTransactionFailure' +-- any other server code -> 'UnexpectedServerError' +-- +-- Constraint names are compared exactly, with the quoted message taking +-- precedence over a delimiter-aware detail fallback. Matching depends on the +-- four literal names above. 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/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 - -{- | Map a hasql 'UsageError' raised inside an opaque transaction body. + SessionUsageError sessionErr -> + mapSessionError streamName expected sessionErr + ConnectionUsageError connErr -> + ConnectionLost (T.pack (show connErr)) + AcquisitionTimeoutUsageError -> + PoolAcquisitionTimeout -The body has no stream context, so append duplicate violations are mapped -directly to 'DuplicateEvent'. Every other failure uses the generic mapper so -its SQLSTATE and server message survive without inventing stream context. --} +-- | Map a hasql 'UsageError' raised inside an opaque transaction body. +-- +-- The body has no stream context, so append duplicate violations are mapped +-- directly to 'DuplicateEvent'. Every other failure uses the generic mapper so +-- its SQLSTATE and server message survive without inventing stream context. mapTransactionUsageError :: UsageError -> StoreError mapTransactionUsageError usageErr = - case extractServerError usageErr of - Just (Errors.ServerError "23505" message detail _ _) - | uniqueConstraintName message detail == Just "events_pkey" -> - DuplicateEvent (EventId <$> (detail >>= extractUuidFromDetail)) - | uniqueConstraintName message detail == Just "stream_events_pkey" -> - DuplicateEvent (EventId <$> (detail >>= extractFirstUuidFromCompositeDetail)) - _ -> - mapGenericUsageError usageErr + case extractServerError usageErr of + Just (Errors.ServerError "23505" message detail _ _) + | uniqueConstraintName message detail == Just "events_pkey" -> + DuplicateEvent (EventId <$> (detail >>= extractUuidFromDetail)) + | uniqueConstraintName message detail == Just "stream_events_pkey" -> + DuplicateEvent (EventId <$> (detail >>= extractFirstUuidFromCompositeDetail)) + _ -> + mapGenericUsageError usageErr -- | Generic, non-append-shaped mapping for hasql pool usage errors. mapGenericUsageError :: UsageError -> StoreError mapGenericUsageError = \case - ConnectionUsageError connErr -> - ConnectionLost (T.pack (show connErr)) - AcquisitionTimeoutUsageError -> - PoolAcquisitionTimeout - SessionUsageError (Errors.ConnectionSessionError detail) -> - ConnectionLost detail - SessionUsageError sessionErr -> - case extractServerError (SessionUsageError sessionErr) of - Just (Errors.ServerError code message _ _ _) - | isTransientTransactionCode code -> - TransientTransactionFailure code message - | otherwise -> - UnexpectedServerError code message - Nothing -> - ConnectionError ("Session error: " <> T.pack (show sessionErr)) + ConnectionUsageError connErr -> + ConnectionLost (T.pack (show connErr)) + AcquisitionTimeoutUsageError -> + PoolAcquisitionTimeout + SessionUsageError (Errors.ConnectionSessionError detail) -> + ConnectionLost detail + SessionUsageError sessionErr -> + case extractServerError (SessionUsageError sessionErr) of + Just (Errors.ServerError code message _ _ _) + | isTransientTransactionCode code -> + TransientTransactionFailure code message + | otherwise -> + UnexpectedServerError code message + Nothing -> + ConnectionError ("Session error: " <> T.pack (show sessionErr)) -- | Map link-specific hasql failures to typed link errors. mapLinkUsageError :: StreamName -> UsageError -> StoreError mapLinkUsageError target usageErr = - case extractServerError usageErr of - Just (Errors.ServerError "23505" message detail _ _) - | uniqueConstraintName message detail == Just "stream_events_pkey" -> - EventAlreadyLinked target (extractCompositeEventId detail) - Just (Errors.ServerError "23502" _ _ _ _) -> - LinkSourceEventMissing target - _ -> - mapGenericUsageError usageErr + case extractServerError usageErr of + Just (Errors.ServerError "23505" message detail _ _) + | uniqueConstraintName message detail == Just "stream_events_pkey" -> + EventAlreadyLinked target (extractCompositeEventId detail) + Just (Errors.ServerError "23502" _ _ _ _) -> + LinkSourceEventMissing target + _ -> + mapGenericUsageError usageErr where extractCompositeEventId (Just d) = EventId <$> extractFirstUuidFromCompositeDetail d extractCompositeEventId Nothing = Nothing mapSessionError :: Text -> ExpectedVersion -> Errors.SessionError -> StoreError mapSessionError streamName expected = \case - Errors.StatementSessionError _ _ _ _ _ stmtErr -> - mapStatementError streamName expected stmtErr - Errors.ScriptSessionError _ serverErr -> - mapServerError streamName expected serverErr - Errors.ConnectionSessionError detail -> - ConnectionLost detail - other -> - ConnectionError ("Session error: " <> T.pack (show other)) + Errors.StatementSessionError _ _ _ _ _ stmtErr -> + mapStatementError streamName expected stmtErr + Errors.ScriptSessionError _ serverErr -> + mapServerError streamName expected serverErr + Errors.ConnectionSessionError detail -> + ConnectionLost detail + 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)) + 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) - | isTransientTransactionCode code = TransientTransactionFailure code message - | 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 extract one constraint name, preferring the quoted message over detail, -then compare it exactly. Composite link keys use their first UUID. A -stream-version index violation is an invariant failure, not a precondition -conflict, and preserves the SQLSTATE and original message. + | code == "23505" = mapUniqueViolation streamName expected message detail + | code == "23503" = StreamNotFound (StreamName streamName) + | isTransientTransactionCode code = TransientTransactionFailure code message + | otherwise = UnexpectedServerError code message -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. --} +-- | 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 extract one constraint name, preferring the quoted message over detail, +-- then compare it exactly. Composite link keys use their first UUID. A +-- stream-version index violation is an invariant failure, not a precondition +-- conflict, and preserves the SQLSTATE and original message. +-- +-- 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. mapUniqueViolation :: Text -> ExpectedVersion -> Text -> Maybe Text -> StoreError mapUniqueViolation streamName expected message detail = - case uniqueConstraintName message detail of - Just "events_pkey" -> DuplicateEvent (EventId <$> (detail >>= extractUuidFromDetail)) - Just "stream_events_pkey" -> DuplicateEvent (EventId <$> (detail >>= extractFirstUuidFromCompositeDetail)) - Just "ix_streams_stream_name" -> StreamAlreadyExists (StreamName streamName) - Just "ux_stream_events_stream_version" -> UnexpectedServerError "23505" message - _ -> - -- Generic unique violation — treat as version conflict - WrongExpectedVersion (StreamName streamName) expected (StreamVersion 0) + case uniqueConstraintName message detail of + Just "events_pkey" -> DuplicateEvent (EventId <$> (detail >>= extractUuidFromDetail)) + Just "stream_events_pkey" -> DuplicateEvent (EventId <$> (detail >>= extractFirstUuidFromCompositeDetail)) + Just "ix_streams_stream_name" -> StreamAlreadyExists (StreamName streamName) + Just "ux_stream_events_stream_version" -> UnexpectedServerError "23505" message + _ -> + -- Generic unique violation — treat as version conflict + WrongExpectedVersion (StreamName streamName) expected (StreamVersion 0) -{- | PostgreSQL's quoted constraint wins even when it is unknown. Legacy -detail-only errors may name an owned constraint as a complete identifier; -underscores and dollar signs are identifier characters, not delimiters. -This helper is used only after a failed statement has returned SQLSTATE 23505. --} +-- | PostgreSQL's quoted constraint wins even when it is unknown. Legacy +-- detail-only errors may name an owned constraint as a complete identifier; +-- underscores and dollar signs are identifier characters, not delimiters. +-- This helper is used only after a failed statement has returned SQLSTATE 23505. uniqueConstraintName :: Text -> Maybe Text -> Maybe Text uniqueConstraintName message detail = - quotedConstraint message <|> (detail >>= fromDetail) + quotedConstraint message <|> (detail >>= fromDetail) where quotedConstraint input = - case T.breakOn "unique constraint \"" input of - (_, rest) - | not (T.null rest) -> - let (name, closing) = T.breakOn "\"" (T.drop (T.length "unique constraint \"") rest) - in if T.null name || T.null closing then Nothing else Just name - _ -> Nothing + case T.breakOn "unique constraint \"" input of + (_, rest) + | not (T.null rest) -> + let (name, closing) = T.breakOn "\"" (T.drop (T.length "unique constraint \"") rest) + in if T.null name || T.null closing then Nothing else Just name + _ -> Nothing fromDetail input = - quotedConstraint input <|> find (`elem` ownedConstraints) (T.split (not . identifierChar) input) + quotedConstraint input <|> find (`elem` ownedConstraints) (T.split (not . identifierChar) input) identifierChar c = isAlphaNum c || c == '_' || c == '$' ownedConstraints = ["events_pkey", "stream_events_pkey", "ix_streams_stream_name", "ux_stream_events_stream_version"] -{- | 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'. --} +-- | 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 - stream-version placeholder. The append statement returns zero - rows on a version mismatch and the store does not issue an extra - read to recover the live version, so this field is - @'StreamVersion' 0@ on every empty-CTE rejection. - -} - WrongExpectedVersionConflict !StreamName !ExpectedVersion !StreamVersion - | -- | Mirror of 'EmptyAppendBatch'. - EmptyAppendBatchConflict !StreamName - | -- | Mirror of 'StreamNotFound'. - StreamNotFoundConflict !StreamName - | -- | Mirror of 'StreamAlreadyExists'. - StreamAlreadyExistsConflict !StreamName - deriving stock (Eq, Show, Generic) + = -- | Mirror of 'WrongExpectedVersion'. The third field is the + -- stream-version placeholder. The append statement returns zero + -- rows on a version mismatch and the store does not issue an extra + -- read to recover the live version, so this field is + -- @'StreamVersion' 0@ on every empty-CTE rejection. + WrongExpectedVersionConflict !StreamName !ExpectedVersion !StreamVersion + | -- | Mirror of 'EmptyAppendBatch'. + EmptyAppendBatchConflict !StreamName + | -- | 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. --} +-- | 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 - EmptyAppendBatchConflict sn -> EmptyAppendBatch sn - 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': + WrongExpectedVersionConflict sn ev sv -> WrongExpectedVersion sn ev sv + EmptyAppendBatchConflict sn -> EmptyAppendBatch sn + StreamNotFoundConflict sn -> StreamNotFound sn + StreamAlreadyExistsConflict sn -> StreamAlreadyExists sn - 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) --} +-- | 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. + ExactVersion v -> + WrongExpectedVersionConflict sn (ExactVersion v) (StreamVersion 0) + StreamExists -> + StreamNotFoundConflict sn + NoStream -> + StreamAlreadyExistsConflict sn + AnyVersion -> + StreamNotFoundConflict sn -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) --} +-- | 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) + appendConflictToStoreError + (emptyResultConflict (StreamName streamName) expected) -{- | Extract a UUID from a PostgreSQL detail string like: -"Key (event_id)=(01234567-89ab-7def-8012-34567890abcd) already exists." --} +-- | 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 + 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 the first UUID from a PostgreSQL composite-key detail string like: -"Key (event_id, stream_id)=(01234567-89ab-7def-8012-34567890abcd, 42) already exists." --} +-- | Extract the first UUID from a PostgreSQL composite-key detail string like: +-- "Key (event_id, stream_id)=(01234567-89ab-7def-8012-34567890abcd, 42) already exists." extractFirstUuidFromCompositeDetail :: Text -> Maybe UUID extractFirstUuidFromCompositeDetail detail = - case T.breakOn "=(" detail of - (_, rest) - | not (T.null rest) -> - let afterParen = T.drop 2 rest -- skip "=(" - uuidText = T.strip (T.takeWhile (\c -> c /= ',' && c /= ')') 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."@. + case T.breakOn "=(" detail of + (_, rest) + | not (T.null rest) -> + let afterParen = T.drop 2 rest -- skip "=(" + uuidText = T.strip (T.takeWhile (\c -> c /= ',' && c /= ')') afterParen) + in UUID.fromText uuidText + _ -> Nothing -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. --} +-- | 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. + 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 -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. --} +-- | 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 + -- | 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)) + -- 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) _ _) - | uniqueConstraintName message (Just detail) == Just "ix_streams_stream_name" - , Just sn <- extractStreamNameFromDetail detail - , Just (StreamName name, expected) <- lookupStream sn ops -> - mapUsageError name expected usageErr - _ -> - mapUsageError firstName firstExpected usageErr + case extractServerError usageErr of + Just (Errors.ServerError "23505" message (Just detail) _ _) + | uniqueConstraintName message (Just detail) == Just "ix_streams_stream_name", + 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 + | 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.ScriptSessionError _ serverErr) -> - Just serverErr - SessionUsageError (Errors.StatementSessionError _ _ _ _ _ stmtErr) -> - case stmtErr of - Errors.ServerStatementError serverErr -> Just serverErr - _ -> Nothing - _ -> Nothing - -{- | True for PostgreSQL class-40 (transaction rollback) @SQLSTATE@ codes: -@40001@ serialization_failure and @40P01@ deadlock_detected. + SessionUsageError (Errors.ScriptSessionError _ serverErr) -> + Just serverErr + SessionUsageError (Errors.StatementSessionError _ _ _ _ _ stmtErr) -> + case stmtErr of + Errors.ServerStatementError serverErr -> Just serverErr + _ -> Nothing + _ -> Nothing -These are the codes hasql-transaction retries, and the ones the store maps to -'TransientTransactionFailure'. Kept as one predicate so the retry decision and -the error classification can never drift apart. --} +-- | True for PostgreSQL class-40 (transaction rollback) @SQLSTATE@ codes: +-- @40001@ serialization_failure and @40P01@ deadlock_detected. +-- +-- These are the codes hasql-transaction retries, and the ones the store maps to +-- 'TransientTransactionFailure'. Kept as one predicate so the retry decision and +-- the error classification can never drift apart. isTransientTransactionCode :: Text -> Bool isTransientTransactionCode code = code == "40001" || code == "40P01" -- | True for PostgreSQL transient transaction aborts retried by hasql-transaction. isTransientSerializationError :: UsageError -> Bool isTransientSerializationError usageErr = - case extractServerError usageErr of - Just (Errors.ServerError code _ _ _ _) -> - isTransientTransactionCode code - Nothing -> - False + case extractServerError usageErr of + Just (Errors.ServerError code _ _ _ _) -> + isTransientTransactionCode code + Nothing -> + False diff --git a/src/Kiroku/Store/HistoryRetention.hs b/src/Kiroku/Store/HistoryRetention.hs --- a/src/Kiroku/Store/HistoryRetention.hs +++ b/src/Kiroku/Store/HistoryRetention.hs @@ -1,22 +1,21 @@ -{- | Durable replay-history retention and transaction-scoped stream guards. - -A lease protects the retained global event set from Kiroku hard delete and -authorized direct SQL deletion until its database-derived expiry. Transaction -combinators persist durable evidence but cannot emit process-local observability -events from inside an opaque caller-owned transaction. - -Lease duration is one second through one hour. Expiry is passive: a crashed -owner blocks destructive work only until PostgreSQL time reaches @expiresAt@. -The owner is an accidental-mutation guard, not an authorization credential; -database roles and grants remain the security boundary. Direct destructive SQL -receives SQLSTATE @KR001@ while any lease is active. - -When one transaction needs both a lease operation and a stream-history guard, -perform the lease operation first. This preserves Kiroku's coordinator-before- -stream-row lock order. --} -module Kiroku.Store.HistoryRetention ( - module Kiroku.Store.HistoryRetention.Types, +-- | Durable replay-history retention and transaction-scoped stream guards. +-- +-- A lease protects the retained global event set from Kiroku hard delete and +-- authorized direct SQL deletion until its database-derived expiry. Transaction +-- combinators persist durable evidence but cannot emit process-local observability +-- events from inside an opaque caller-owned transaction. +-- +-- Lease duration is one second through one hour. Expiry is passive: a crashed +-- owner blocks destructive work only until PostgreSQL time reaches @expiresAt@. +-- The owner is an accidental-mutation guard, not an authorization credential; +-- database roles and grants remain the security boundary. Direct destructive SQL +-- receives SQLSTATE @KR001@ while any lease is active. +-- +-- When one transaction needs both a lease operation and a stream-history guard, +-- perform the lease operation first. This preserves Kiroku's coordinator-before- +-- stream-row lock order. +module Kiroku.Store.HistoryRetention + ( module Kiroku.Store.HistoryRetention.Types, acquireHistoryRetentionLeaseTx, renewHistoryRetentionLeaseTx, releaseHistoryRetentionLeaseTx, @@ -29,7 +28,8 @@ pruneHistoryRetentionLeases, lockStreamHistoryForReplayTx, readStreamForwardTx, -) where + ) +where import Data.Int (Int32) import Data.Time.Clock (UTCTime) @@ -44,104 +44,98 @@ import Kiroku.Store.SQL qualified as SQL import Kiroku.Store.Types (RecordedEvent, StreamInfo, StreamName (..), StreamVersion (..)) -{- | Acquire a new lease and atomically capture the authoritative @$all@ -frontier as the inclusive @protectedThrough@ rebuild ceiling. PostgreSQL -supplies every timestamp. Rollback leaves no lease row. --} +-- | Acquire a new lease and atomically capture the authoritative @$all@ +-- frontier as the inclusive @protectedThrough@ rebuild ceiling. PostgreSQL +-- supplies every timestamp. Rollback leaves no lease row. acquireHistoryRetentionLeaseTx :: HistoryRetentionLeaseRequest -> Tx.Transaction HistoryRetentionLease acquireHistoryRetentionLeaseTx = Internal.acquireHistoryRetentionLeaseTx -{- | Renew a still-active lease without shortening its current expiry. -Unknown, wrong-owner, expired, and released leases return distinct typed -errors and are never resurrected. --} +-- | Renew a still-active lease without shortening its current expiry. +-- Unknown, wrong-owner, expired, and released leases return distinct typed +-- errors and are never resurrected. renewHistoryRetentionLeaseTx :: - HistoryRetentionLeaseHandle -> - HistoryRetentionLeaseDuration -> - Tx.Transaction (Either HistoryRetentionRenewalError HistoryRetentionLease) + HistoryRetentionLeaseHandle -> + HistoryRetentionLeaseDuration -> + Tx.Transaction (Either HistoryRetentionRenewalError HistoryRetentionLease) renewHistoryRetentionLeaseTx = Internal.renewHistoryRetentionLeaseTx -- | Release a live lease. Repetition is typed and does not rewrite the row. releaseHistoryRetentionLeaseTx :: - HistoryRetentionLeaseHandle -> - Tx.Transaction HistoryRetentionReleaseResult + HistoryRetentionLeaseHandle -> + Tx.Transaction HistoryRetentionReleaseResult releaseHistoryRetentionLeaseTx = Internal.releaseHistoryRetentionLeaseTx -{- | Read a deterministic, database-time-derived, bounded inventory. Active, -expired, and released state is derived at statement time; no expiry worker is -required. --} +-- | Read a deterministic, database-time-derived, bounded inventory. Active, +-- expired, and released state is derived at statement time; no expiry worker is +-- required. historyRetentionLeaseInventoryTx :: - HistoryRetentionInventoryQuery -> - Tx.Transaction (Vector HistoryRetentionLease) + HistoryRetentionInventoryQuery -> + Tx.Transaction (Vector HistoryRetentionLease) historyRetentionLeaseInventoryTx = Internal.historyRetentionLeaseInventoryTx -- | Remove only expired or released rows strictly older than the supplied cutoff. pruneHistoryRetentionLeasesTx :: UTCTime -> Tx.Transaction HistoryRetentionPruneResult pruneHistoryRetentionLeasesTx = Internal.pruneHistoryRetentionLeasesTx -{- | Acquire a lease through the mockable 'Store' effect. The production -interpreter emits the committed acquisition event after the transaction ends. --} +-- | Acquire a lease through the mockable 'Store' effect. The production +-- interpreter emits the committed acquisition event after the transaction ends. acquireHistoryRetentionLease :: (Store :> es) => HistoryRetentionLeaseRequest -> Eff es HistoryRetentionLease acquireHistoryRetentionLease request = send (AcquireHistoryRetentionLease request) -- | Renew a lease through the mockable 'Store' effect and emit only a committed success. renewHistoryRetentionLease :: - (Store :> es) => - HistoryRetentionLeaseHandle -> - HistoryRetentionLeaseDuration -> - Eff es (Either HistoryRetentionRenewalError HistoryRetentionLease) + (Store :> es) => + HistoryRetentionLeaseHandle -> + HistoryRetentionLeaseDuration -> + Eff es (Either HistoryRetentionRenewalError HistoryRetentionLease) renewHistoryRetentionLease handle duration = send (RenewHistoryRetentionLease handle duration) -- | Release a lease through the mockable 'Store' effect. Repeated release emits no false transition. releaseHistoryRetentionLease :: - (Store :> es) => - HistoryRetentionLeaseHandle -> - Eff es HistoryRetentionReleaseResult + (Store :> es) => + HistoryRetentionLeaseHandle -> + Eff es HistoryRetentionReleaseResult releaseHistoryRetentionLease handle = send (ReleaseHistoryRetentionLease handle) -- | Read the bounded durable inventory through the mockable 'Store' effect. historyRetentionLeaseInventory :: - (Store :> es) => - HistoryRetentionInventoryQuery -> - Eff es (Vector HistoryRetentionLease) + (Store :> es) => + HistoryRetentionInventoryQuery -> + Eff es (Vector HistoryRetentionLease) historyRetentionLeaseInventory query = send (GetHistoryRetentionLeaseInventory query) -- | Prune terminal rows through the mockable 'Store' effect. pruneHistoryRetentionLeases :: - (Store :> es) => - UTCTime -> - Eff es HistoryRetentionPruneResult + (Store :> es) => + UTCTime -> + Eff es HistoryRetentionPruneResult pruneHistoryRetentionLeases cutoff = send (PruneHistoryRetentionLeases cutoff) -{- | Lock one application's stream row in share mode until the surrounding -transaction ends. The returned metadata includes soft-delete and logical -truncate state so a repair can reject incomplete history before mutating its -target. @$all@ is reserved. - -When composing this guard with a lease operation, acquire or renew the lease -first and take this guard second. --} +-- | Lock one application's stream row in share mode until the surrounding +-- transaction ends. The returned metadata includes soft-delete and logical +-- truncate state so a repair can reject incomplete history before mutating its +-- target. @$all@ is reserved. +-- +-- When composing this guard with a lease operation, acquire or renew the lease +-- first and take this guard second. lockStreamHistoryForReplayTx :: - StreamName -> - Tx.Transaction (Either StreamHistoryUnavailable StreamInfo) + StreamName -> + Tx.Transaction (Either StreamHistoryUnavailable StreamInfo) lockStreamHistoryForReplayTx stream@(StreamName name) - | name == "$all" = pure (Left (StreamHistoryReserved stream)) - | otherwise = do - locked <- Tx.statement name HistoryRetentionSQL.lockStreamHistoryStmt - pure $ maybe (Left (StreamHistoryNotFound stream)) Right locked + | name == "$all" = pure (Left (StreamHistoryReserved stream)) + | otherwise = do + locked <- Tx.statement name HistoryRetentionSQL.lockStreamHistoryStmt + pure $ maybe (Left (StreamHistoryNotFound stream)) Right locked -{- | Read a page inside the caller's transaction using the production -exclusive-lower cursor and ascending-order statement. This function deliberately -does not run 'Kiroku.Store.Settings.decodeHook': 'Tx.Transaction' has no 'IO'. -The caller must take 'lockStreamHistoryForReplayTx' earlier in the same -transaction when stable one-stream history is required. --} +-- | Read a page inside the caller's transaction using the production +-- exclusive-lower cursor and ascending-order statement. This function deliberately +-- does not run 'Kiroku.Store.Settings.decodeHook': 'Tx.Transaction' has no 'IO'. +-- The caller must take 'lockStreamHistoryForReplayTx' earlier in the same +-- transaction when stable one-stream history is required. readStreamForwardTx :: - StreamName -> - StreamVersion -> - Int32 -> - Tx.Transaction (Vector RecordedEvent) + StreamName -> + StreamVersion -> + Int32 -> + Tx.Transaction (Vector RecordedEvent) readStreamForwardTx (StreamName name) (StreamVersion cursor) limit = - Tx.statement (name, cursor, limit) SQL.readStreamForwardStmt + Tx.statement (name, cursor, limit) SQL.readStreamForwardStmt diff --git a/src/Kiroku/Store/HistoryRetention/Internal.hs b/src/Kiroku/Store/HistoryRetention/Internal.hs --- a/src/Kiroku/Store/HistoryRetention/Internal.hs +++ b/src/Kiroku/Store/HistoryRetention/Internal.hs @@ -1,5 +1,5 @@ -module Kiroku.Store.HistoryRetention.Internal ( - acquireHistoryRetentionLeaseTx, +module Kiroku.Store.HistoryRetention.Internal + ( acquireHistoryRetentionLeaseTx, renewHistoryRetentionLeaseTx, releaseHistoryRetentionLeaseTx, historyRetentionLeaseInventoryTx, @@ -7,7 +7,8 @@ lockHistoryRetentionCoordinatorTx, activeHistoryRetentionConflictTx, lockAffectedStreamsForHardDeleteTx, -) where + ) +where import Data.Int (Int64) import Data.Time.Clock (UTCTime) @@ -18,74 +19,74 @@ import Kiroku.Store.HistoryRetention.Types acquireHistoryRetentionLeaseTx :: HistoryRetentionLeaseRequest -> Tx.Transaction HistoryRetentionLease -acquireHistoryRetentionLeaseTx HistoryRetentionLeaseRequest{owner, reason, duration} = - Tx.statement - ( historyRetentionLeaseOwnerText owner - , historyRetentionLeaseReasonText reason - , historyRetentionLeaseDurationValue duration - ) - SQL.acquireLeaseStmt +acquireHistoryRetentionLeaseTx HistoryRetentionLeaseRequest {owner, reason, duration} = + Tx.statement + ( historyRetentionLeaseOwnerText owner, + historyRetentionLeaseReasonText reason, + historyRetentionLeaseDurationValue duration + ) + SQL.acquireLeaseStmt renewHistoryRetentionLeaseTx :: - HistoryRetentionLeaseHandle -> - HistoryRetentionLeaseDuration -> - Tx.Transaction (Either HistoryRetentionRenewalError HistoryRetentionLease) -renewHistoryRetentionLeaseTx HistoryRetentionLeaseHandle{leaseId, owner = requestedOwner} duration = do - lockHistoryRetentionCoordinatorTx - current <- Tx.statement (leaseUuid leaseId) SQL.readLeaseForUpdateStmt - case current of - Nothing -> pure (Left HistoryRetentionRenewalUnknown) - Just HistoryRetentionLease{owner = actualOwner, state} - | actualOwner /= requestedOwner -> pure (Left HistoryRetentionRenewalOwnerMismatch) - | state == HistoryRetentionLeaseReleased -> pure (Left HistoryRetentionRenewalReleased) - | state == HistoryRetentionLeaseExpired -> pure (Left HistoryRetentionRenewalExpired) - | otherwise -> - Right - <$> Tx.statement - (leaseUuid leaseId, historyRetentionLeaseDurationValue duration) - SQL.renewLeaseStmt + HistoryRetentionLeaseHandle -> + HistoryRetentionLeaseDuration -> + Tx.Transaction (Either HistoryRetentionRenewalError HistoryRetentionLease) +renewHistoryRetentionLeaseTx HistoryRetentionLeaseHandle {leaseId, owner = requestedOwner} duration = do + lockHistoryRetentionCoordinatorTx + current <- Tx.statement (leaseUuid leaseId) SQL.readLeaseForUpdateStmt + case current of + Nothing -> pure (Left HistoryRetentionRenewalUnknown) + Just HistoryRetentionLease {owner = actualOwner, state} + | actualOwner /= requestedOwner -> pure (Left HistoryRetentionRenewalOwnerMismatch) + | state == HistoryRetentionLeaseReleased -> pure (Left HistoryRetentionRenewalReleased) + | state == HistoryRetentionLeaseExpired -> pure (Left HistoryRetentionRenewalExpired) + | otherwise -> + Right + <$> Tx.statement + (leaseUuid leaseId, historyRetentionLeaseDurationValue duration) + SQL.renewLeaseStmt releaseHistoryRetentionLeaseTx :: - HistoryRetentionLeaseHandle -> - Tx.Transaction HistoryRetentionReleaseResult -releaseHistoryRetentionLeaseTx HistoryRetentionLeaseHandle{leaseId, owner = requestedOwner} = do - lockHistoryRetentionCoordinatorTx - current <- Tx.statement (leaseUuid leaseId) SQL.readLeaseForUpdateStmt - case current of - Nothing -> pure HistoryRetentionReleaseUnknown - Just lease@HistoryRetentionLease{owner = actualOwner, state} - | actualOwner /= requestedOwner -> pure HistoryRetentionReleaseOwnerMismatch - | state == HistoryRetentionLeaseReleased -> pure (HistoryRetentionAlreadyReleased lease) - | state == HistoryRetentionLeaseExpired -> pure (HistoryRetentionReleaseExpired lease) - | otherwise -> - HistoryRetentionReleased - <$> Tx.statement (leaseUuid leaseId) SQL.releaseLeaseStmt + HistoryRetentionLeaseHandle -> + Tx.Transaction HistoryRetentionReleaseResult +releaseHistoryRetentionLeaseTx HistoryRetentionLeaseHandle {leaseId, owner = requestedOwner} = do + lockHistoryRetentionCoordinatorTx + current <- Tx.statement (leaseUuid leaseId) SQL.readLeaseForUpdateStmt + case current of + Nothing -> pure HistoryRetentionReleaseUnknown + Just lease@HistoryRetentionLease {owner = actualOwner, state} + | actualOwner /= requestedOwner -> pure HistoryRetentionReleaseOwnerMismatch + | state == HistoryRetentionLeaseReleased -> pure (HistoryRetentionAlreadyReleased lease) + | state == HistoryRetentionLeaseExpired -> pure (HistoryRetentionReleaseExpired lease) + | otherwise -> + HistoryRetentionReleased + <$> Tx.statement (leaseUuid leaseId) SQL.releaseLeaseStmt historyRetentionLeaseInventoryTx :: - HistoryRetentionInventoryQuery -> - Tx.Transaction (Vector HistoryRetentionLease) -historyRetentionLeaseInventoryTx HistoryRetentionInventoryQuery{limit} = - Tx.statement (historyRetentionInventoryLimitValue limit) SQL.leaseInventoryStmt + HistoryRetentionInventoryQuery -> + Tx.Transaction (Vector HistoryRetentionLease) +historyRetentionLeaseInventoryTx HistoryRetentionInventoryQuery {limit} = + Tx.statement (historyRetentionInventoryLimitValue limit) SQL.leaseInventoryStmt pruneHistoryRetentionLeasesTx :: - UTCTime -> - Tx.Transaction HistoryRetentionPruneResult + UTCTime -> + Tx.Transaction HistoryRetentionPruneResult pruneHistoryRetentionLeasesTx cutoff = do - lockHistoryRetentionCoordinatorTx - Tx.statement cutoff SQL.pruneLeasesStmt + lockHistoryRetentionCoordinatorTx + Tx.statement cutoff SQL.pruneLeasesStmt lockHistoryRetentionCoordinatorTx :: Tx.Transaction () lockHistoryRetentionCoordinatorTx = do - _ <- Tx.statement () SQL.lockCoordinatorStmt - pure () + _ <- Tx.statement () SQL.lockCoordinatorStmt + pure () activeHistoryRetentionConflictTx :: Tx.Transaction (Maybe HistoryRetentionConflict) activeHistoryRetentionConflictTx = Tx.statement () SQL.activeConflictStmt lockAffectedStreamsForHardDeleteTx :: Int64 -> Tx.Transaction () lockAffectedStreamsForHardDeleteTx streamId = do - _ <- Tx.statement streamId SQL.lockAffectedStreamsForHardDeleteStmt - pure () + _ <- Tx.statement streamId SQL.lockAffectedStreamsForHardDeleteStmt + pure () leaseUuid :: HistoryRetentionLeaseId -> UUID leaseUuid (HistoryRetentionLeaseId value) = value diff --git a/src/Kiroku/Store/HistoryRetention/SQL.hs b/src/Kiroku/Store/HistoryRetention/SQL.hs --- a/src/Kiroku/Store/HistoryRetention/SQL.hs +++ b/src/Kiroku/Store/HistoryRetention/SQL.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MultilineStrings #-} -module Kiroku.Store.HistoryRetention.SQL ( - acquireLeaseStmt, +module Kiroku.Store.HistoryRetention.SQL + ( acquireLeaseStmt, lockCoordinatorStmt, readLeaseForUpdateStmt, renewLeaseStmt, @@ -11,7 +11,8 @@ activeConflictStmt, lockStreamHistoryStmt, lockAffectedStreamsForHardDeleteStmt, -) where + ) +where import Contravariant.Extras (contrazip2, contrazip3) import Data.Int (Int32, Int64) @@ -27,250 +28,250 @@ acquireLeaseStmt :: Statement (Text, Text, DiffTime) HistoryRetentionLease acquireLeaseStmt = - preparable - """ - WITH coordinator AS MATERIALIZED ( - SELECT singleton - FROM history_retention_coordinator - WHERE singleton - FOR UPDATE - ), snapshot AS MATERIALIZED ( - SELECT streams.stream_version AS protected_through, - clock_timestamp() AS database_now - FROM streams - CROSS JOIN coordinator - WHERE streams.stream_id = 0 - ), inserted AS ( - INSERT INTO history_retention_leases - (owner, reason, protected_through, created_at, renewed_at, expires_at) - SELECT $1, $2, protected_through, database_now, database_now, database_now + $3 - FROM snapshot - RETURNING lease_id, owner, reason, protected_through, - created_at, renewed_at, expires_at, released_at - ) - SELECT lease_id, owner, reason, protected_through, - created_at, renewed_at, expires_at, released_at, - 'active'::text - FROM inserted - """ - (contrazip3 textParam textParam intervalParam) - (D.singleRow leaseRow) + preparable + """ + WITH coordinator AS MATERIALIZED ( + SELECT singleton + FROM history_retention_coordinator + WHERE singleton + FOR UPDATE + ), snapshot AS MATERIALIZED ( + SELECT streams.stream_version AS protected_through, + clock_timestamp() AS database_now + FROM streams + CROSS JOIN coordinator + WHERE streams.stream_id = 0 + ), inserted AS ( + INSERT INTO history_retention_leases + (owner, reason, protected_through, created_at, renewed_at, expires_at) + SELECT $1, $2, protected_through, database_now, database_now, database_now + $3 + FROM snapshot + RETURNING lease_id, owner, reason, protected_through, + created_at, renewed_at, expires_at, released_at + ) + SELECT lease_id, owner, reason, protected_through, + created_at, renewed_at, expires_at, released_at, + 'active'::text + FROM inserted + """ + (contrazip3 textParam textParam intervalParam) + (D.singleRow leaseRow) lockCoordinatorStmt :: Statement () Bool lockCoordinatorStmt = - preparable - """ - SELECT singleton - FROM history_retention_coordinator - WHERE singleton - FOR UPDATE - """ - E.noParams - (D.singleRow (column D.bool)) + preparable + """ + SELECT singleton + FROM history_retention_coordinator + WHERE singleton + FOR UPDATE + """ + E.noParams + (D.singleRow (column D.bool)) readLeaseForUpdateStmt :: Statement UUID (Maybe HistoryRetentionLease) readLeaseForUpdateStmt = - preparable - """ - SELECT lease_id, owner, reason, protected_through, - created_at, renewed_at, expires_at, released_at, - CASE - WHEN released_at IS NOT NULL THEN 'released' - WHEN expires_at <= clock_timestamp() THEN 'expired' - ELSE 'active' - END::text - FROM history_retention_leases - WHERE lease_id = $1 - FOR UPDATE - """ - uuidParam - (D.rowMaybe leaseRow) + preparable + """ + SELECT lease_id, owner, reason, protected_through, + created_at, renewed_at, expires_at, released_at, + CASE + WHEN released_at IS NOT NULL THEN 'released' + WHEN expires_at <= clock_timestamp() THEN 'expired' + ELSE 'active' + END::text + FROM history_retention_leases + WHERE lease_id = $1 + FOR UPDATE + """ + uuidParam + (D.rowMaybe leaseRow) renewLeaseStmt :: Statement (UUID, DiffTime) HistoryRetentionLease renewLeaseStmt = - preparable - """ - WITH renewal_time AS MATERIALIZED ( - SELECT clock_timestamp() AS database_now - ), renewed AS ( - UPDATE history_retention_leases - SET renewed_at = renewal_time.database_now, - expires_at = GREATEST( - history_retention_leases.expires_at, - renewal_time.database_now + $2 - ) - FROM renewal_time - WHERE lease_id = $1 - RETURNING lease_id, owner, reason, protected_through, - created_at, renewed_at, expires_at, released_at - ) - SELECT lease_id, owner, reason, protected_through, - created_at, renewed_at, expires_at, released_at, - 'active'::text - FROM renewed - """ - (contrazip2 uuidParam intervalParam) - (D.singleRow leaseRow) + preparable + """ + WITH renewal_time AS MATERIALIZED ( + SELECT clock_timestamp() AS database_now + ), renewed AS ( + UPDATE history_retention_leases + SET renewed_at = renewal_time.database_now, + expires_at = GREATEST( + history_retention_leases.expires_at, + renewal_time.database_now + $2 + ) + FROM renewal_time + WHERE lease_id = $1 + RETURNING lease_id, owner, reason, protected_through, + created_at, renewed_at, expires_at, released_at + ) + SELECT lease_id, owner, reason, protected_through, + created_at, renewed_at, expires_at, released_at, + 'active'::text + FROM renewed + """ + (contrazip2 uuidParam intervalParam) + (D.singleRow leaseRow) releaseLeaseStmt :: Statement UUID HistoryRetentionLease releaseLeaseStmt = - preparable - """ - WITH released AS ( - UPDATE history_retention_leases - SET released_at = clock_timestamp() - WHERE lease_id = $1 - RETURNING lease_id, owner, reason, protected_through, - created_at, renewed_at, expires_at, released_at - ) - SELECT lease_id, owner, reason, protected_through, - created_at, renewed_at, expires_at, released_at, - 'released'::text - FROM released - """ - uuidParam - (D.singleRow leaseRow) + preparable + """ + WITH released AS ( + UPDATE history_retention_leases + SET released_at = clock_timestamp() + WHERE lease_id = $1 + RETURNING lease_id, owner, reason, protected_through, + created_at, renewed_at, expires_at, released_at + ) + SELECT lease_id, owner, reason, protected_through, + created_at, renewed_at, expires_at, released_at, + 'released'::text + FROM released + """ + uuidParam + (D.singleRow leaseRow) leaseInventoryStmt :: Statement Int32 (Vector HistoryRetentionLease) leaseInventoryStmt = - preparable - """ - WITH inventory_time AS MATERIALIZED ( - SELECT clock_timestamp() AS database_now - ) - SELECT lease_id, owner, reason, protected_through, - created_at, renewed_at, expires_at, released_at, - CASE - WHEN released_at IS NOT NULL THEN 'released' - WHEN expires_at <= inventory_time.database_now THEN 'expired' - ELSE 'active' - END::text - FROM history_retention_leases - CROSS JOIN inventory_time - ORDER BY created_at, lease_id - LIMIT $1 - """ - int4Param - (D.rowVector leaseRow) + preparable + """ + WITH inventory_time AS MATERIALIZED ( + SELECT clock_timestamp() AS database_now + ) + SELECT lease_id, owner, reason, protected_through, + created_at, renewed_at, expires_at, released_at, + CASE + WHEN released_at IS NOT NULL THEN 'released' + WHEN expires_at <= inventory_time.database_now THEN 'expired' + ELSE 'active' + END::text + FROM history_retention_leases + CROSS JOIN inventory_time + ORDER BY created_at, lease_id + LIMIT $1 + """ + int4Param + (D.rowVector leaseRow) pruneLeasesStmt :: Statement UTCTime HistoryRetentionPruneResult pruneLeasesStmt = - preparable - """ - WITH released AS ( - DELETE FROM history_retention_leases - WHERE released_at IS NOT NULL - AND released_at < $1 - RETURNING 1 - ), expired AS ( - DELETE FROM history_retention_leases - WHERE released_at IS NULL - AND expires_at < $1 - RETURNING 1 - ) - SELECT (SELECT count(*) FROM expired), - (SELECT count(*) FROM released) - """ - timestamptzParam - ( D.singleRow - ( HistoryRetentionPruneResult - <$> column D.int8 - <*> column D.int8 - ) + preparable + """ + WITH released AS ( + DELETE FROM history_retention_leases + WHERE released_at IS NOT NULL + AND released_at < $1 + RETURNING 1 + ), expired AS ( + DELETE FROM history_retention_leases + WHERE released_at IS NULL + AND expires_at < $1 + RETURNING 1 + ) + SELECT (SELECT count(*) FROM expired), + (SELECT count(*) FROM released) + """ + timestamptzParam + ( D.singleRow + ( HistoryRetentionPruneResult + <$> column D.int8 + <*> column D.int8 ) + ) activeConflictStmt :: Statement () (Maybe HistoryRetentionConflict) activeConflictStmt = - preparable - """ - SELECT count(*), min(expires_at) - FROM history_retention_leases - WHERE released_at IS NULL - AND expires_at > clock_timestamp() - HAVING count(*) > 0 - """ - E.noParams - ( D.rowMaybe - ( HistoryRetentionConflict - <$> column D.int8 - <*> column D.timestamptz - ) + preparable + """ + SELECT count(*), min(expires_at) + FROM history_retention_leases + WHERE released_at IS NULL + AND expires_at > clock_timestamp() + HAVING count(*) > 0 + """ + E.noParams + ( D.rowMaybe + ( HistoryRetentionConflict + <$> column D.int8 + <*> column D.timestamptz ) + ) lockStreamHistoryStmt :: Statement Text (Maybe StreamInfo) lockStreamHistoryStmt = - preparable - """ - SELECT stream_id, stream_name, stream_version, - created_at, deleted_at, truncate_before - FROM streams - WHERE stream_name = $1 - FOR SHARE - """ - textParam - (D.rowMaybe streamInfoRow) + preparable + """ + SELECT stream_id, stream_name, stream_version, + created_at, deleted_at, truncate_before + FROM streams + WHERE stream_name = $1 + FOR SHARE + """ + textParam + (D.rowMaybe streamInfoRow) lockAffectedStreamsForHardDeleteStmt :: Statement Int64 (Vector Int64) lockAffectedStreamsForHardDeleteStmt = - preparable - """ - WITH affected_streams AS ( - SELECT $1::bigint AS stream_id - UNION - SELECT stream_events.stream_id - FROM stream_events - WHERE stream_events.original_stream_id = $1 - AND stream_events.stream_id <> 0 - ) - SELECT streams.stream_id - FROM streams - JOIN affected_streams USING (stream_id) - ORDER BY streams.stream_id - FOR UPDATE OF streams - """ - int8Param - (D.rowVector (column D.int8)) + preparable + """ + WITH affected_streams AS ( + SELECT $1::bigint AS stream_id + UNION + SELECT stream_events.stream_id + FROM stream_events + WHERE stream_events.original_stream_id = $1 + AND stream_events.stream_id <> 0 + ) + SELECT streams.stream_id + FROM streams + JOIN affected_streams USING (stream_id) + ORDER BY streams.stream_id + FOR UPDATE OF streams + """ + int8Param + (D.rowVector (column D.int8)) leaseRow :: D.Row HistoryRetentionLease leaseRow = - makeLease - <$> column D.uuid - <*> column D.text - <*> column D.text - <*> column D.int8 - <*> column D.timestamptz - <*> column D.timestamptz - <*> column D.timestamptz - <*> D.column (D.nullable D.timestamptz) - <*> column D.text + makeLease + <$> column D.uuid + <*> column D.text + <*> column D.text + <*> column D.int8 + <*> column D.timestamptz + <*> column D.timestamptz + <*> column D.timestamptz + <*> D.column (D.nullable D.timestamptz) + <*> column D.text makeLease :: UUID -> Text -> Text -> Int64 -> UTCTime -> UTCTime -> UTCTime -> Maybe UTCTime -> Text -> HistoryRetentionLease makeLease leaseUuid ownerText reasonText frontier created renewed expires released stateText = - HistoryRetentionLease - { leaseId = HistoryRetentionLeaseId leaseUuid - , owner = requireValidated (mkHistoryRetentionLeaseOwner ownerText) - , reason = requireValidated (mkHistoryRetentionLeaseReason reasonText) - , protectedThrough = GlobalPosition frontier - , createdAt = created - , renewedAt = renewed - , expiresAt = expires - , releasedAt = released - , state = case stateText of - "active" -> HistoryRetentionLeaseActive - "expired" -> HistoryRetentionLeaseExpired - "released" -> HistoryRetentionLeaseReleased - unexpected -> error ("unknown history retention lease state from database: " <> show unexpected) - } + HistoryRetentionLease + { leaseId = HistoryRetentionLeaseId leaseUuid, + owner = requireValidated (mkHistoryRetentionLeaseOwner ownerText), + reason = requireValidated (mkHistoryRetentionLeaseReason reasonText), + protectedThrough = GlobalPosition frontier, + createdAt = created, + renewedAt = renewed, + expiresAt = expires, + releasedAt = released, + state = case stateText of + "active" -> HistoryRetentionLeaseActive + "expired" -> HistoryRetentionLeaseExpired + "released" -> HistoryRetentionLeaseReleased + unexpected -> error ("unknown history retention lease state from database: " <> show unexpected) + } streamInfoRow :: D.Row StreamInfo streamInfoRow = - StreamInfo - <$> (StreamId <$> column D.int8) - <*> (StreamName <$> column D.text) - <*> (StreamVersion <$> column D.int8) - <*> column D.timestamptz - <*> D.column (D.nullable D.timestamptz) - <*> (StreamVersion <$> column D.int8) + StreamInfo + <$> (StreamId <$> column D.int8) + <*> (StreamName <$> column D.text) + <*> (StreamVersion <$> column D.int8) + <*> column D.timestamptz + <*> D.column (D.nullable D.timestamptz) + <*> (StreamVersion <$> column D.int8) requireValidated :: Either error value -> value requireValidated = either (const (error "database returned an invalid history retention lease")) (\value -> value) diff --git a/src/Kiroku/Store/HistoryRetention/Types.hs b/src/Kiroku/Store/HistoryRetention/Types.hs --- a/src/Kiroku/Store/HistoryRetention/Types.hs +++ b/src/Kiroku/Store/HistoryRetention/Types.hs @@ -1,5 +1,5 @@ -module Kiroku.Store.HistoryRetention.Types ( - HistoryRetentionLeaseId (..), +module Kiroku.Store.HistoryRetention.Types + ( HistoryRetentionLeaseId (..), HistoryRetentionLeaseOwner, HistoryRetentionLeaseReason, HistoryRetentionLeaseDuration, @@ -25,7 +25,8 @@ historyRetentionLeaseDurationValue, historyRetentionInventoryLimitValue, maxHistoryRetentionLeaseDuration, -) where + ) +where import Data.ByteString qualified as ByteString import Data.Int (Int32, Int64) @@ -38,131 +39,131 @@ -- | Database-generated identity of one durable retention lease. newtype HistoryRetentionLeaseId = HistoryRetentionLeaseId UUID - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) -- | Validated operational owner label (1 through 512 UTF-8 bytes). newtype HistoryRetentionLeaseOwner = HistoryRetentionLeaseOwner Text - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) -- | Validated human-readable reason (1 through 2,048 UTF-8 bytes). newtype HistoryRetentionLeaseReason = HistoryRetentionLeaseReason Text - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) -- | Requested remaining lifetime, from one second through one hour. newtype HistoryRetentionLeaseDuration = HistoryRetentionLeaseDuration DiffTime - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) data HistoryRetentionLeaseRequest = HistoryRetentionLeaseRequest - { owner :: !HistoryRetentionLeaseOwner - , reason :: !HistoryRetentionLeaseReason - , duration :: !HistoryRetentionLeaseDuration - } - deriving stock (Eq, Show, Generic) + { owner :: !HistoryRetentionLeaseOwner, + reason :: !HistoryRetentionLeaseReason, + duration :: !HistoryRetentionLeaseDuration + } + deriving stock (Eq, Show, Generic) data HistoryRetentionLeaseHandle = HistoryRetentionLeaseHandle - { leaseId :: !HistoryRetentionLeaseId - , owner :: !HistoryRetentionLeaseOwner - } - deriving stock (Eq, Show, Generic) + { leaseId :: !HistoryRetentionLeaseId, + owner :: !HistoryRetentionLeaseOwner + } + deriving stock (Eq, Show, Generic) data HistoryRetentionLeaseState - = HistoryRetentionLeaseActive - | HistoryRetentionLeaseExpired - | HistoryRetentionLeaseReleased - deriving stock (Eq, Ord, Show, Generic) + = HistoryRetentionLeaseActive + | HistoryRetentionLeaseExpired + | HistoryRetentionLeaseReleased + deriving stock (Eq, Ord, Show, Generic) data HistoryRetentionLease = HistoryRetentionLease - { leaseId :: !HistoryRetentionLeaseId - , owner :: !HistoryRetentionLeaseOwner - , reason :: !HistoryRetentionLeaseReason - , protectedThrough :: !GlobalPosition - , createdAt :: !UTCTime - , renewedAt :: !UTCTime - , expiresAt :: !UTCTime - , releasedAt :: !(Maybe UTCTime) - , state :: !HistoryRetentionLeaseState - } - deriving stock (Eq, Show, Generic) + { leaseId :: !HistoryRetentionLeaseId, + owner :: !HistoryRetentionLeaseOwner, + reason :: !HistoryRetentionLeaseReason, + protectedThrough :: !GlobalPosition, + createdAt :: !UTCTime, + renewedAt :: !UTCTime, + expiresAt :: !UTCTime, + releasedAt :: !(Maybe UTCTime), + state :: !HistoryRetentionLeaseState + } + deriving stock (Eq, Show, Generic) data HistoryRetentionRenewalError - = HistoryRetentionRenewalUnknown - | HistoryRetentionRenewalOwnerMismatch - | HistoryRetentionRenewalExpired - | HistoryRetentionRenewalReleased - deriving stock (Eq, Show, Generic) + = HistoryRetentionRenewalUnknown + | HistoryRetentionRenewalOwnerMismatch + | HistoryRetentionRenewalExpired + | HistoryRetentionRenewalReleased + deriving stock (Eq, Show, Generic) data HistoryRetentionReleaseResult - = HistoryRetentionReleased !HistoryRetentionLease - | HistoryRetentionAlreadyReleased !HistoryRetentionLease - | HistoryRetentionReleaseExpired !HistoryRetentionLease - | HistoryRetentionReleaseUnknown - | HistoryRetentionReleaseOwnerMismatch - deriving stock (Eq, Show, Generic) + = HistoryRetentionReleased !HistoryRetentionLease + | HistoryRetentionAlreadyReleased !HistoryRetentionLease + | HistoryRetentionReleaseExpired !HistoryRetentionLease + | HistoryRetentionReleaseUnknown + | HistoryRetentionReleaseOwnerMismatch + deriving stock (Eq, Show, Generic) data HistoryRetentionConflict = HistoryRetentionConflict - { activeLeaseCount :: !Int64 - , earliestExpiry :: !UTCTime - } - deriving stock (Eq, Show, Generic) + { activeLeaseCount :: !Int64, + earliestExpiry :: !UTCTime + } + deriving stock (Eq, Show, Generic) -- | Validated maximum number of inventory rows (1 through 1,000). newtype HistoryRetentionInventoryLimit = HistoryRetentionInventoryLimit Int32 - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) data HistoryRetentionInventoryQuery = HistoryRetentionInventoryQuery - { limit :: !HistoryRetentionInventoryLimit - } - deriving stock (Eq, Show, Generic) + { limit :: !HistoryRetentionInventoryLimit + } + deriving stock (Eq, Show, Generic) data HistoryRetentionPruneResult = HistoryRetentionPruneResult - { expiredPruned :: !Int64 - , releasedPruned :: !Int64 - } - deriving stock (Eq, Show, Generic) + { expiredPruned :: !Int64, + releasedPruned :: !Int64 + } + deriving stock (Eq, Show, Generic) data HistoryRetentionRequestError - = HistoryRetentionLeaseOwnerEmpty - | HistoryRetentionLeaseOwnerTooLong !Int - | HistoryRetentionLeaseReasonEmpty - | HistoryRetentionLeaseReasonTooLong !Int - | HistoryRetentionLeaseDurationOutOfRange !DiffTime - deriving stock (Eq, Show, Generic) + = HistoryRetentionLeaseOwnerEmpty + | HistoryRetentionLeaseOwnerTooLong !Int + | HistoryRetentionLeaseReasonEmpty + | HistoryRetentionLeaseReasonTooLong !Int + | HistoryRetentionLeaseDurationOutOfRange !DiffTime + deriving stock (Eq, Show, Generic) data HistoryRetentionInventoryError - = HistoryRetentionInventoryLimitOutOfRange !Int32 - deriving stock (Eq, Show, Generic) + = HistoryRetentionInventoryLimitOutOfRange !Int32 + deriving stock (Eq, Show, Generic) data StreamHistoryUnavailable - = StreamHistoryNotFound !StreamName - | StreamHistoryReserved !StreamName - deriving stock (Eq, Show, Generic) + = StreamHistoryNotFound !StreamName + | StreamHistoryReserved !StreamName + deriving stock (Eq, Show, Generic) mkHistoryRetentionLeaseOwner :: Text -> Either HistoryRetentionRequestError HistoryRetentionLeaseOwner mkHistoryRetentionLeaseOwner value - | bytes == 0 = Left HistoryRetentionLeaseOwnerEmpty - | bytes > 512 = Left (HistoryRetentionLeaseOwnerTooLong bytes) - | otherwise = Right (HistoryRetentionLeaseOwner value) + | bytes == 0 = Left HistoryRetentionLeaseOwnerEmpty + | bytes > 512 = Left (HistoryRetentionLeaseOwnerTooLong bytes) + | otherwise = Right (HistoryRetentionLeaseOwner value) where bytes = ByteString.length (Text.encodeUtf8 value) mkHistoryRetentionLeaseReason :: Text -> Either HistoryRetentionRequestError HistoryRetentionLeaseReason mkHistoryRetentionLeaseReason value - | bytes == 0 = Left HistoryRetentionLeaseReasonEmpty - | bytes > 2048 = Left (HistoryRetentionLeaseReasonTooLong bytes) - | otherwise = Right (HistoryRetentionLeaseReason value) + | bytes == 0 = Left HistoryRetentionLeaseReasonEmpty + | bytes > 2048 = Left (HistoryRetentionLeaseReasonTooLong bytes) + | otherwise = Right (HistoryRetentionLeaseReason value) where bytes = ByteString.length (Text.encodeUtf8 value) mkHistoryRetentionLeaseDuration :: DiffTime -> Either HistoryRetentionRequestError HistoryRetentionLeaseDuration mkHistoryRetentionLeaseDuration value - | value < secondsToDiffTime 1 = Left (HistoryRetentionLeaseDurationOutOfRange value) - | value > maxHistoryRetentionLeaseDuration = Left (HistoryRetentionLeaseDurationOutOfRange value) - | otherwise = Right (HistoryRetentionLeaseDuration value) + | value < secondsToDiffTime 1 = Left (HistoryRetentionLeaseDurationOutOfRange value) + | value > maxHistoryRetentionLeaseDuration = Left (HistoryRetentionLeaseDurationOutOfRange value) + | otherwise = Right (HistoryRetentionLeaseDuration value) mkHistoryRetentionInventoryLimit :: Int32 -> Either HistoryRetentionInventoryError HistoryRetentionInventoryLimit mkHistoryRetentionInventoryLimit value - | value < 1 || value > 1000 = Left (HistoryRetentionInventoryLimitOutOfRange value) - | otherwise = Right (HistoryRetentionInventoryLimit value) + | value < 1 || value > 1000 = Left (HistoryRetentionInventoryLimitOutOfRange value) + | otherwise = Right (HistoryRetentionInventoryLimit value) historyRetentionLeaseOwnerText :: HistoryRetentionLeaseOwner -> Text historyRetentionLeaseOwnerText (HistoryRetentionLeaseOwner value) = value diff --git a/src/Kiroku/Store/Lifecycle.hs b/src/Kiroku/Store/Lifecycle.hs --- a/src/Kiroku/Store/Lifecycle.hs +++ b/src/Kiroku/Store/Lifecycle.hs @@ -1,10 +1,11 @@ -module Kiroku.Store.Lifecycle ( - softDeleteStream, +module Kiroku.Store.Lifecycle + ( softDeleteStream, hardDeleteStream, undeleteStream, setStreamTruncateBefore, clearStreamTruncateBefore, -) where + ) +where import Effectful (Eff, (:>)) import Effectful.Dispatch.Dynamic (send) @@ -12,153 +13,148 @@ 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'. --} +-- | 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) + (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/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. - -Replay-history retention is an independent safety layer. While any -'Kiroku.Store.HistoryRetention.Types.HistoryRetentionLease' is active, -supported hard delete returns -'Kiroku.Store.Error.HistoryRetentionActive' before changing rows. A -GUC-enabled direct @DELETE@ or @TRUNCATE@ receives SQLSTATE @KR001@. There is -no ordinary bypass: release the lease or wait for its database-derived expiry. - -== 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. - -Before deletion, Kiroku locks the target and every stream containing a link to -one of the target's originated events in ascending internal ID order. This -serializes hard delete with -'Kiroku.Store.HistoryRetention.lockStreamHistoryForReplayTx' guards, including -a guard held on a linked stream. - -== 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 store event handler (see -'Kiroku.Store.Connection.ConnectionSettingsM.eventHandler') or -record an application-level event /before/ calling this function. --} +-- | 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/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. +-- +-- Replay-history retention is an independent safety layer. While any +-- 'Kiroku.Store.HistoryRetention.Types.HistoryRetentionLease' is active, +-- supported hard delete returns +-- 'Kiroku.Store.Error.HistoryRetentionActive' before changing rows. A +-- GUC-enabled direct @DELETE@ or @TRUNCATE@ receives SQLSTATE @KR001@. There is +-- no ordinary bypass: release the lease or wait for its database-derived expiry. +-- +-- == 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. +-- +-- Before deletion, Kiroku locks the target and every stream containing a link to +-- one of the target's originated events in ascending internal ID order. This +-- serializes hard delete with +-- 'Kiroku.Store.HistoryRetention.lockStreamHistoryForReplayTx' guards, including +-- a guard held on a linked stream. +-- +-- == 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 store event handler (see +-- 'Kiroku.Store.Connection.ConnectionSettingsM.eventHandler') or +-- record an application-level event /before/ calling this function. hardDeleteStream :: - (HasCallStack, Store :> es) => - StreamName -> - Eff es (Maybe StreamId) + (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'. --} +-- | 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) + (HasCallStack, Store :> es) => + StreamName -> + Eff es (Maybe StreamId) undeleteStream name = send (UndeleteStream name) -{- | Set the logical truncate-before marker for a stream. After this call, -'Kiroku.Store.Read.readStreamForward' and 'readStreamBackward' return only the -events whose per-stream version is >= @before@; earlier events are hidden from -ordered stream reads but are NOT deleted. - -This is the close-the-book / snapshot-and-compact primitive: append a snapshot -event (it lands at version @V@), then call @setStreamTruncateBefore name V@ so -rehydration starts from the snapshot. - -The marker does NOT affect the @$all@ global log, 'Kiroku.Store.Read.readCategory', -subscriptions, or existence probes — the global history stays complete, so -projections (including ones not yet written) can still be built from it. The -operation is fully reversible: lower the marker or call -'clearStreamTruncateBefore' to re-expose hidden events. - -Returns @Just streamId@ on success, @Nothing@ if the stream does not exist or is -soft-deleted. The reserved stream @$all@ is rejected with -'Kiroku.Store.Error.ReservedStreamName'. Per-stream versions are 1-based, so a -@before@ of 0 or 1 keeps the whole stream. Idempotent: setting the same value -again returns the same result and changes nothing. --} +-- | Set the logical truncate-before marker for a stream. After this call, +-- 'Kiroku.Store.Read.readStreamForward' and 'readStreamBackward' return only the +-- events whose per-stream version is >= @before@; earlier events are hidden from +-- ordered stream reads but are NOT deleted. +-- +-- This is the close-the-book / snapshot-and-compact primitive: append a snapshot +-- event (it lands at version @V@), then call @setStreamTruncateBefore name V@ so +-- rehydration starts from the snapshot. +-- +-- The marker does NOT affect the @$all@ global log, 'Kiroku.Store.Read.readCategory', +-- subscriptions, or existence probes — the global history stays complete, so +-- projections (including ones not yet written) can still be built from it. The +-- operation is fully reversible: lower the marker or call +-- 'clearStreamTruncateBefore' to re-expose hidden events. +-- +-- Returns @Just streamId@ on success, @Nothing@ if the stream does not exist or is +-- soft-deleted. The reserved stream @$all@ is rejected with +-- 'Kiroku.Store.Error.ReservedStreamName'. Per-stream versions are 1-based, so a +-- @before@ of 0 or 1 keeps the whole stream. Idempotent: setting the same value +-- again returns the same result and changes nothing. setStreamTruncateBefore :: - (HasCallStack, Store :> es) => - StreamName -> - StreamVersion -> - Eff es (Maybe StreamId) + (HasCallStack, Store :> es) => + StreamName -> + StreamVersion -> + Eff es (Maybe StreamId) setStreamTruncateBefore name before = send (SetStreamTruncateBefore name before) -{- | Clear a stream's truncate-before marker, re-exposing the full history to -ordered stream reads. Equivalent to @setStreamTruncateBefore name 0@. Returns -@Just streamId@ on success, @Nothing@ for a missing or soft-deleted stream. -Rejects @$all@ with 'Kiroku.Store.Error.ReservedStreamName'. --} +-- | Clear a stream's truncate-before marker, re-exposing the full history to +-- ordered stream reads. Equivalent to @setStreamTruncateBefore name 0@. Returns +-- @Just streamId@ on success, @Nothing@ for a missing or soft-deleted stream. +-- Rejects @$all@ with 'Kiroku.Store.Error.ReservedStreamName'. clearStreamTruncateBefore :: - (HasCallStack, Store :> es) => - StreamName -> - Eff es (Maybe StreamId) + (HasCallStack, Store :> es) => + StreamName -> + Eff es (Maybe StreamId) clearStreamTruncateBefore name = setStreamTruncateBefore name (StreamVersion 0) diff --git a/src/Kiroku/Store/Link.hs b/src/Kiroku/Store/Link.hs --- a/src/Kiroku/Store/Link.hs +++ b/src/Kiroku/Store/Link.hs @@ -1,6 +1,7 @@ -module Kiroku.Store.Link ( - linkToStream, -) where +module Kiroku.Store.Link + ( linkToStream, + ) +where import Effectful (Eff, (:>)) import Effectful.Dispatch.Dynamic (send) @@ -8,49 +9,48 @@ import Kiroku.Store.Effect (Store (..)) import Kiroku.Store.Types -{- | Link existing events into a target stream. - -__Provisional API.__ No known consumer uses this function (audited -2026-06-11: zero usage in keiro, the only downstream framework). It is the -only public feature that requires the @stream_events@ junction-table layout, -which a future global-position migration may replace with a single-table event -layout (global position as a column on @events@); in that case this function -will be removed or redesigned (e.g. rehomed to a dedicated @stream_links@ side -table). If you have a real use case, surface it before depending on this. See -docs/architecture/global-position-migration-path.md. - -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 — with - 'Kiroku.Store.Error.LinkSourceEventMissing'. (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 - 'Kiroku.Store.Error.EventAlreadyLinked'. - -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. --} +-- | Link existing events into a target stream. +-- +-- __Provisional API.__ No known consumer uses this function (audited +-- 2026-06-11: zero usage in keiro, the only downstream framework). It is the +-- only public feature that requires the @stream_events@ junction-table layout, +-- which a future global-position migration may replace with a single-table event +-- layout (global position as a column on @events@); in that case this function +-- will be removed or redesigned (e.g. rehomed to a dedicated @stream_links@ side +-- table). If you have a real use case, surface it before depending on this. See +-- docs/architecture/global-position-migration-path.md. +-- +-- 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 — with +-- 'Kiroku.Store.Error.LinkSourceEventMissing'. (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 +-- 'Kiroku.Store.Error.EventAlreadyLinked'. +-- +-- 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 + (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 --- a/src/Kiroku/Store/Notification.hs +++ b/src/Kiroku/Store/Notification.hs @@ -1,22 +1,27 @@ -module Kiroku.Store.Notification ( - Notifier (..), +module Kiroku.Store.Notification + ( Notifier (..), NotifierStartError (..), startNotifier, stopNotifier, -) where + NamespaceRegistry, + registerNamespace, + notifyNamespace, + ) +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.Concurrent.STM (STM, TChan, TVar, atomically, modifyTVar', newBroadcastTChanIO, newTVar, newTVarIO, readTVar, readTVarIO, writeTChan, writeTVar) import Control.Exception (Exception, SomeAsyncException, SomeException, asyncExceptionFromException, bracketOnError, catch, throwIO, toException) -import Control.Monad (void) +import Control.Monad (forM_, unless, void) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BC import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text (Text) +import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8Lenient) import Data.Word (Word64) import Hasql.Connection (Connection) @@ -32,46 +37,81 @@ import Kiroku.Store.Observability (KirokuEvent (..), emitOrDrop) import Kiroku.Store.Types (CategoryName (..), StreamName (..), categoryName) -{- | 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). --} +-- | 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. - -} - } + { -- | Broadcast channel; consumers must use 'dupTChan' to get a personal copy + tickChan :: !(TChan ()), + -- | The async thread running the LISTEN loop + listenerThread :: !(Async ()), + -- | The /current/ dedicated listener connection. Updated by the loop on + -- each successful reconnection so 'stopNotifier' always releases the + -- live socket. + listenerConnRef :: !(TVar Connection), + namespaceRegistry :: !NamespaceRegistry, + -- | 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. + categoryGenerations :: !(TVar (Map Text Word64)) + } -{- | Raised by 'startNotifier' when the initial dedicated @LISTEN@ setup fails. +-- | Only active namespace keys are retained. Duplicate workers share one cell. +type NamespaceRegistry = TVar (Map Text (Int, TVar Word64)) -Connection-acquire failures carry @hasql@'s underlying -'Connection.ConnectionError'. LISTEN failures carry the exception thrown after -the connection was acquired; that connection has already been released. --} +-- | Register before catch-up. The release is idempotent and cell-conditional, +-- so an old release cannot remove a replacement registration. +registerNamespace :: NamespaceRegistry -> Text -> STM (TVar Word64, STM ()) +registerNamespace registry namespace = do + entries <- readTVar registry + (count, cell) <- case Map.lookup namespace entries of + Just entry -> pure entry + Nothing -> (0,) <$> newTVar 0 + writeTVar registry (Map.insert namespace (count + 1, cell) entries) + released <- newTVar False + let release = do + done <- readTVar released + unless done $ do + writeTVar released True + modifyTVar' registry $ + Map.update + ( \(refs, current) -> + if current /= cell + then Just (refs, current) + else if refs == 1 then Nothing else Just (refs - 1, current) + ) + namespace + pure (cell, release) + +-- | Bump exact category and colon ancestors in the callback transaction. +-- An empty registry does no ancestor construction or map mutation. +notifyNamespace :: NamespaceRegistry -> Text -> STM () +notifyNamespace registry category = do + entries <- readTVar registry + unless (Map.null entries) $ + forM_ (scanl1 (\prefix segment -> prefix <> ":" <> segment) (T.splitOn ":" category)) $ \candidate -> + case Map.lookup candidate entries of + Nothing -> pure () + Just (_, cell) -> modifyTVar' cell (+ 1) + +-- | Raised by 'startNotifier' when the initial dedicated @LISTEN@ setup fails. +-- +-- Connection-acquire failures carry @hasql@'s underlying +-- 'Connection.ConnectionError'. LISTEN failures carry the exception thrown after +-- the connection was acquired; that connection has already been released. data NotifierStartError - = NotifierConnectError !ConnectionError - | NotifierListenError !SomeException - deriving stock (Show) - deriving anyclass (Exception) + = NotifierConnectError !ConnectionError + | NotifierListenError !SomeException + 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 @@ -85,69 +125,69 @@ -- 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. + | n <= 0 = 1_000_000 + | otherwise = min maxReconnectDelayMicros (1_000_000 * 2 ^ (min (n - 1) 30)) -Initial acquire or LISTEN failure raises 'NotifierStartError'. --} +-- | 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 or LISTEN 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 + (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 - let channel = toPgIdentifier (schema <> ".events") - bracketOnError (acquireOrThrow connString) Connection.release $ \conn -> do - Notifications.listen conn channel - `catch` \(e :: SomeException) -> - case asyncExceptionFromException e of - Just (ae :: SomeAsyncException) -> throwIO ae - Nothing -> throwIO (NotifierListenError e) - connRef <- newTVarIO conn - thread <- Async.async (listenerLoop chan catGenVar connRef channel connString mHandler) - pure - Notifier - { tickChan = chan - , listenerThread = thread - , listenerConnRef = connRef - , categoryGenerations = catGenVar - } + chan <- newBroadcastTChanIO + catGenVar <- newTVarIO Map.empty + namespaces <- newTVarIO Map.empty + let channel = toPgIdentifier (schema <> ".events") + bracketOnError (acquireOrThrow connString) Connection.release $ \conn -> do + Notifications.listen conn channel + `catch` \(e :: SomeException) -> + case asyncExceptionFromException e of + Just (ae :: SomeAsyncException) -> throwIO ae + Nothing -> throwIO (NotifierListenError e) + connRef <- newTVarIO conn + thread <- Async.async (listenerLoop chan catGenVar namespaces connRef channel connString mHandler) + pure + Notifier + { tickChan = chan, + listenerThread = thread, + listenerConnRef = connRef, + categoryGenerations = catGenVar, + namespaceRegistry = namespaces + } -{- | Stop the Notifier. Cancels the listener thread, waits for it to -finish, and releases whichever connection the loop is currently holding. --} +-- | 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 + 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 @@ -161,58 +201,59 @@ -- 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 + TChan () -> + TVar (Map Text Word64) -> + NamespaceRegistry -> + TVar Connection -> + PgIdentifier -> + Text -> + Maybe (KirokuEvent -> IO ()) -> + IO () +listenerLoop chan catGenVar namespaces 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 + ( do + currentConn <- readTVarIO connRef + waitForNotifications (handleNotification chan catGenVar namespaces) 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 (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 = emitOrDrop mHandler @@ -222,11 +263,13 @@ -- 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) +handleNotification :: TChan () -> TVar (Map Text Word64) -> NamespaceRegistry -> ByteString -> ByteString -> IO () +handleNotification chan catGenVar namespaces _channel payload = + atomically $ do + writeTChan chan () + let category = categoryFromPayload payload + modifyTVar' catGenVar (Map.insertWith (+) category 1) + notifyNamespace namespaces category -- Recover the originating stream's category from a @notify_events@ payload. The -- payload is @stream_name,stream_id,stream_version@; @stream_id@ and @@ -237,34 +280,34 @@ -- the @streams.category GENERATED ALWAYS AS split_part(stream_name,'-',1)@ column. categoryFromPayload :: ByteString -> Text categoryFromPayload payload = - let fields = BC.split ',' payload - streamNameBytes = BC.intercalate "," (take (max 0 (length fields - 2)) fields) - CategoryName category = categoryName (StreamName (decodeUtf8Lenient streamNameBytes)) - in category + let fields = BC.split ',' payload + streamNameBytes = BC.intercalate "," (take (max 0 (length fields - 2)) fields) + CategoryName category = categoryName (StreamName (decodeUtf8Lenient streamNameBytes)) + in category -- 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) + deriving stock (Show) + deriving anyclass (Exception) -- Internal: acquire a connection, set its application_name, or throw on failure. -- Throws 'NotifierStartError' (which derives 'Exception') for connection -- acquisition failures, 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 (NotifierConnectError 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 + result <- Connection.acquire (Conn.connectionString connStr) + case result of + Left err -> throwIO (NotifierConnectError 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 + unpreparable "SET application_name = 'kiroku-listener'" E.noParams D.noResult diff --git a/src/Kiroku/Store/Observability.hs b/src/Kiroku/Store/Observability.hs --- a/src/Kiroku/Store/Observability.hs +++ b/src/Kiroku/Store/Observability.hs @@ -1,55 +1,55 @@ -{- | 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). -* Committed replay-history lease acquisition, renewal, actual release, pruning, - and supported hard-delete refusal. - -Lease reasons remain in the durable inventory and are deliberately absent from -these process-local events. Do not turn free-form reasons into metrics labels. -Direct @Tx.Transaction@ combinators cannot emit process-local events; the -mockable effect wrappers emit only after their database transaction finishes. - -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 (..), +-- | 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). +-- * Committed replay-history lease acquisition, renewal, actual release, pruning, +-- and supported hard-delete refusal. +-- +-- Lease reasons remain in the durable inventory and are deliberately absent from +-- these process-local events. Do not turn free-form reasons into metrics labels. +-- Direct @Tx.Transaction@ combinators cannot emit process-local events; the +-- mockable effect wrappers emit only after their database transaction finishes. +-- +-- 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 (..), emitOrDrop, -) where + ) +where import Control.Exception (SomeAsyncException, SomeException, asyncExceptionFromException, catch, throwIO) import Data.Foldable (for_) @@ -60,246 +60,222 @@ import Kiroku.Store.HistoryRetention.Types (HistoryRetentionConflict, HistoryRetentionLeaseId, HistoryRetentionLeaseOwner, HistoryRetentionPruneResult) import Kiroku.Store.Settings (DecodeFailure) import Kiroku.Store.Subscription.Fsm (DeadLetterReason (..), SubscriptionStopReason (..)) -import Kiroku.Store.Subscription.Types ( - CheckpointInitialization, +import Kiroku.Store.Subscription.Types + ( CheckpointInitialization, ConsumerGroupSizeMismatch, SubscriptionCheckpointMissing, SubscriptionName, SubscriptionTarget, - ) + SubscriptionTargetMismatch, + ) import Kiroku.Store.Types (EventId, 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. --} +-- | 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 - = KirokuEventSubscriptionTargetBound !SubscriptionName !SubscriptionTarget !SubscriptionGroupContext - | KirokuEventSubscriptionGroupSizeMismatch !ConsumerGroupSizeMismatch !SubscriptionGroupContext - | {- | 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 - | {- | The publisher loop's broadcast iteration threw a synchronous - exception that was not a 'UsageError' — typically a user-supplied - 'Kiroku.Store.Settings.decodeHook' or observability handler throwing. - The publisher skipped this tick and will retry on the next notification - or the 30-second safety poll. Sustained emissions mean a deterministically - failing callback is stalling live broadcast until it is fixed. - -} - KirokuEventPublisherLoopError !SomeException - | -- | Typed hook failure at broadcast time; publisher still advances. - KirokuEventPublisherDecodeFailed !GlobalPosition !EventId !DecodeFailure - | -- | One handler invocation remains pending after the configured interval. - KirokuEventSubscriptionHandlerStalled !SubscriptionName !GlobalPosition !EventId !NominalDiffTime !SubscriptionGroupContext - | {- | A subscription's worker thread encountered a 'UsageError' in - the database phase identified by 'SubscriptionDbPhase'. Checkpoint-load - errors fail startup loudly, fetch-batch errors are retried at the same - cursor, and checkpoint-save errors are reported while the worker continues. - 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 - | {- | Startup resolved an exact checkpoint key before the worker emitted - 'KirokuEventSubscriptionStarted'. 'ExistingCheckpoint' means the worker - resumed durable progress; 'InitializedCheckpoint' identifies whether it - seeded zero or the current store head. The event contains no payload data. - -} - KirokuEventSubscriptionCheckpointResolved !CheckpointInitialization !SubscriptionGroupContext - | {- | Startup applied 'Kiroku.Store.Subscription.Types.FailIfMissing' to - an absent exact checkpoint key. The worker emits this event and throws the - carried typed exception before emitting 'KirokuEventSubscriptionStarted' - or invoking the handler. - -} - KirokuEventSubscriptionCheckpointMissing !SubscriptionCheckpointMissing !SubscriptionGroupContext - | {- | A subscription's worker thread has just started; the worker - will begin from the durable 'GlobalPosition' reported by the immediately - preceding checkpoint-resolution event. 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 - | {- | A lease acquisition committed. The lease row is the durable audit - evidence; this process-local event contains no event payload. - -} - KirokuEventHistoryRetentionLeaseAcquired !HistoryRetentionLeaseId !HistoryRetentionLeaseOwner !GlobalPosition !UTCTime - | -- | A live lease renewal committed; reason text is not copied into the event. - KirokuEventHistoryRetentionLeaseRenewed !HistoryRetentionLeaseId !HistoryRetentionLeaseOwner !UTCTime - | -- | A previously active lease was actually released and committed. - KirokuEventHistoryRetentionLeaseReleased !HistoryRetentionLeaseId !HistoryRetentionLeaseOwner !UTCTime - | -- | A prune operation committed with the reported terminal-row counts. - KirokuEventHistoryRetentionLeasesPruned !HistoryRetentionPruneResult - | -- | Supported hard delete was refused before changing history. - KirokuEventHardDeleteHistoryRetentionConflict !StreamName !HistoryRetentionConflict - deriving stock (Show) - -{- | Invoke the optional observability handler, dropping any synchronous exception -it throws. Asynchronous exceptions, including thread cancellation, are rethrown. + = KirokuEventSubscriptionTargetBound !SubscriptionName !SubscriptionTarget !SubscriptionGroupContext + | KirokuEventSubscriptionGroupSizeMismatch !ConsumerGroupSizeMismatch !SubscriptionGroupContext + | KirokuEventSubscriptionTargetMismatch !SubscriptionTargetMismatch !SubscriptionGroupContext + | -- | 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 + | -- | The publisher loop's broadcast iteration threw a synchronous + -- exception that was not a 'UsageError' — typically a user-supplied + -- 'Kiroku.Store.Settings.decodeHook' or observability handler throwing. + -- The publisher skipped this tick and will retry on the next notification + -- or the 30-second safety poll. Sustained emissions mean a deterministically + -- failing callback is stalling live broadcast until it is fixed. + KirokuEventPublisherLoopError !SomeException + | -- | Typed hook failure at broadcast time; publisher still advances. + KirokuEventPublisherDecodeFailed !GlobalPosition !EventId !DecodeFailure + | -- | One handler invocation remains pending after the configured interval. + KirokuEventSubscriptionHandlerStalled !SubscriptionName !GlobalPosition !EventId !NominalDiffTime !SubscriptionGroupContext + | -- | A subscription's worker thread encountered a 'UsageError' in + -- the database phase identified by 'SubscriptionDbPhase'. Checkpoint-load + -- errors fail startup loudly, fetch-batch errors are retried at the same + -- cursor, and checkpoint-save errors are reported while the worker continues. + -- 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 + | -- | Startup resolved an exact checkpoint key before the worker emitted + -- 'KirokuEventSubscriptionStarted'. 'ExistingCheckpoint' means the worker + -- resumed durable progress; 'InitializedCheckpoint' identifies whether it + -- seeded zero or the current store head. The event contains no payload data. + KirokuEventSubscriptionCheckpointResolved !CheckpointInitialization !SubscriptionGroupContext + | -- | Startup applied 'Kiroku.Store.Subscription.Types.FailIfMissing' to + -- an absent exact checkpoint key. The worker emits this event and throws the + -- carried typed exception before emitting 'KirokuEventSubscriptionStarted' + -- or invoking the handler. + KirokuEventSubscriptionCheckpointMissing !SubscriptionCheckpointMissing !SubscriptionGroupContext + | -- | A subscription's worker thread has just started; the worker + -- will begin from the durable 'GlobalPosition' reported by the immediately + -- preceding checkpoint-resolution event. 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 + | -- | A lease acquisition committed. The lease row is the durable audit + -- evidence; this process-local event contains no event payload. + KirokuEventHistoryRetentionLeaseAcquired !HistoryRetentionLeaseId !HistoryRetentionLeaseOwner !GlobalPosition !UTCTime + | -- | A live lease renewal committed; reason text is not copied into the event. + KirokuEventHistoryRetentionLeaseRenewed !HistoryRetentionLeaseId !HistoryRetentionLeaseOwner !UTCTime + | -- | A previously active lease was actually released and committed. + KirokuEventHistoryRetentionLeaseReleased !HistoryRetentionLeaseId !HistoryRetentionLeaseOwner !UTCTime + | -- | A prune operation committed with the reported terminal-row counts. + KirokuEventHistoryRetentionLeasesPruned !HistoryRetentionPruneResult + | -- | Supported hard delete was refused before changing history. + KirokuEventHardDeleteHistoryRetentionConflict !StreamName !HistoryRetentionConflict + deriving stock (Show) -Store-internal threads must not die because a metrics or logging callback threw; -the callback contract is that it should be fast and non-throwing. --} +-- | Invoke the optional observability handler, dropping any synchronous exception +-- it throws. Asynchronous exceptions, including thread cancellation, are rethrown. +-- +-- Store-internal threads must not die because a metrics or logging callback threw; +-- the callback contract is that it should be fast and non-throwing. emitOrDrop :: Maybe (KirokuEvent -> IO ()) -> KirokuEvent -> IO () emitOrDrop mHandler evt = - for_ mHandler $ \handler -> - handler evt `catch` \(e :: SomeException) -> - case asyncExceptionFromException e of - Just (ae :: SomeAsyncException) -> throwIO ae - Nothing -> pure () + for_ mHandler $ \handler -> + handler evt `catch` \(e :: SomeException) -> + case asyncExceptionFromException e of + Just (ae :: SomeAsyncException) -> throwIO ae + Nothing -> pure () -- | Which database phase a 'KirokuEventSubscriptionDbError' fired in. data SubscriptionDbPhase - = {- | 'Kiroku.Store.Subscription.Worker' failed to read the saved - checkpoint at subscription startup. The worker fails startup loudly - instead of silently re-processing from 'Kiroku.Store.Types.GlobalPosition' - @0@. - -} - 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) + = -- | 'Kiroku.Store.Subscription.Worker' failed to read the saved + -- checkpoint at subscription startup. The worker fails startup loudly + -- instead of silently re-processing from 'Kiroku.Store.Types.GlobalPosition' + -- @0@. + 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'). --} +-- | 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) + = -- | 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)@. --} +-- | 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) + = -- | 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 --- a/src/Kiroku/Store/Read.hs +++ b/src/Kiroku/Store/Read.hs @@ -1,5 +1,5 @@ -module Kiroku.Store.Read ( - readStreamForward, +module Kiroku.Store.Read + ( readStreamForward, readStreamForwardStream, readStreamBackward, readAllForward, @@ -15,7 +15,8 @@ eventExistsInStream, lookupStreamName, lookupStreamNames, -) where + ) +where import Control.Lens ((^.)) import Data.Generics.Labels () @@ -33,265 +34,251 @@ 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\". --} +-- | 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) + (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 a page comes back shorter than -@pageSize@. If the stream length is an exact multiple of @pageSize@, one -final empty-page probe is still required because the wrapper does not know -the total stream length up front. - -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. --} +-- | 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 a page comes back shorter than +-- @pageSize@. If the stream length is an exact multiple of @pageSize@, one +-- final empty-page probe is still required because the wrapper does not know +-- the total stream length up front. +-- +-- 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 + (HasCallStack, Store :> es) => + StreamName -> + StreamVersion -> + Int32 -> + Stream (Eff es) RecordedEvent readStreamForwardStream name startVer pageSize = - Stream.concatMap fromVector pages + Stream.concatMap fromVector pages where pages = Stream.unfoldrM nextPage (Just startVer) nextPage Nothing = pure Nothing nextPage (Just cursor) = do - events <- readStreamForward name cursor pageSize - if V.null events - then pure Nothing - else do - let nextState - | V.length events < fromIntegral pageSize = Nothing - | otherwise = Just (V.last events ^. #streamVersion) - pure (Just (events, nextState)) + events <- readStreamForward name cursor pageSize + if V.null events + then pure Nothing + else do + let nextState + | V.length events < fromIntegral pageSize = Nothing + | otherwise = Just (V.last events ^. #streamVersion) + pure (Just (events, nextState)) fromVector :: Vector a -> Stream (Eff es) a fromVector v = Stream.unfoldr (\i -> fmap (\x -> (x, i + 1)) (v V.!? i)) 0 -{- | 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 interpreter maps -0 to the maximum cursor value, so it never collides with a real stream -version; versions start at 1. Returns an empty vector for nonexistent or -soft-deleted streams. --} +-- | 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 interpreter maps +-- 0 to the maximum cursor value, so it never collides with a real stream +-- version; versions start at 1. Returns an empty vector for nonexistent or +-- soft-deleted streams. readStreamBackward :: - (HasCallStack, Store :> es) => - StreamName -> - StreamVersion -> - Int32 -> - Eff es (Vector RecordedEvent) + (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. --} +-- | 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) + (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@. The interpreter maps 0 to the maximum cursor value, -so it never collides with a real global position; positions start at 1. --} +-- | Read events from the global @$all@ stream in backward +-- ('GlobalPosition'-descending) order. +-- +-- Cursor exclusive. To start from the most recent event, pass +-- @'GlobalPosition' 0@. The interpreter maps 0 to the maximum cursor value, +-- so it never collides with a real global position; positions start at 1. readAllBackward :: - (HasCallStack, Store :> es) => - GlobalPosition -> - Int32 -> - Eff es (Vector RecordedEvent) + (HasCallStack, Store :> es) => + GlobalPosition -> + Int32 -> + Eff es (Vector RecordedEvent) readAllBackward startPos limit = send (ReadAllBackward startPos limit) -{- | Return the greatest 'GlobalPosition' still visible in the global @$all@ -stream, or @'GlobalPosition' 0@ when no event remains. - -Logical truncation and soft deletion leave @$all@ junctions intact, so neither -changes this value. Hard deletion removes junctions and can make the visible -head move backward or return to zero. This differs from -'Kiroku.Store.Subscription.Types.storePosition' in -'Kiroku.Store.Subscription.Types.SubscriptionCheckpointInventory', which is -the authoritative append frontier and remains monotonic after hard deletion. - -The value is observed by one database statement. A concurrent append or hard -deletion may change the visible head immediately after this function returns; -the result does not retain a database snapshot. --} +-- | Return the greatest 'GlobalPosition' still visible in the global @$all@ +-- stream, or @'GlobalPosition' 0@ when no event remains. +-- +-- Logical truncation and soft deletion leave @$all@ junctions intact, so neither +-- changes this value. Hard deletion removes junctions and can make the visible +-- head move backward or return to zero. This differs from +-- 'Kiroku.Store.Subscription.Types.storePosition' in +-- 'Kiroku.Store.Subscription.Types.SubscriptionCheckpointInventory', which is +-- the authoritative append frontier and remains monotonic after hard deletion. +-- +-- The value is observed by one database statement. A concurrent append or hard +-- deletion may change the visible head immediately after this function returns; +-- the result does not retain a database snapshot. visibleGlobalHeadPosition :: - (HasCallStack, Store :> es) => - Eff es GlobalPosition + (HasCallStack, Store :> es) => + Eff es GlobalPosition visibleGlobalHeadPosition = send GetVisibleGlobalHeadPosition -{- | 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. --} +-- | 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) + (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. --} +-- | 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) + (HasCallStack, Store :> es) => + StreamName -> + Eff es (Maybe StreamInfo) getStream name = send (GetStream name) -{- | Read metadata and the newest surviving /originated/ event's global -position in one SQL statement, from one database snapshot. - -Outer 'Nothing' means absent or hard-deleted. Inner 'Nothing' means the -stream exists without surviving originated events, including empty and -link-only streams. @$all@ always has an inner 'Nothing': it aggregates events -but originates none. Links advance the stream version without advancing this -head. Soft deletion and logical truncation preserve the originated head; -physical retention can remove it. This is neither the store-wide visible -head nor the monotonically allocated append frontier. - -For an origin-only stream with retained required history, capture this pair, -require @version >= N@ and @Just head@, then wait for the projection cursor to -reach @head@. Waiting and timeouts belong to the consumer. The observation does -not lock history or freeze subsequent appends; later physical removal can -require a timeout. A positive linked version gives no such guarantee. - -Only this opt-in operation pays for the indexed head probe. 'getStream' and -'StreamInfo' retain their existing representation and cost. --} +-- | Read metadata and the newest surviving /originated/ event's global +-- position in one SQL statement, from one database snapshot. +-- +-- Outer 'Nothing' means absent or hard-deleted. Inner 'Nothing' means the +-- stream exists without surviving originated events, including empty and +-- link-only streams. @$all@ always has an inner 'Nothing': it aggregates events +-- but originates none. Links advance the stream version without advancing this +-- head. Soft deletion and logical truncation preserve the originated head; +-- physical retention can remove it. This is neither the store-wide visible +-- head nor the monotonically allocated append frontier. +-- +-- For an origin-only stream with retained required history, capture this pair, +-- require @version >= N@ and @Just head@, then wait for the projection cursor to +-- reach @head@. Waiting and timeouts belong to the consumer. The observation does +-- not lock history or freeze subsequent appends; later physical removal can +-- require a timeout. A positive linked version gives no such guarantee. +-- +-- Only this opt-in operation pays for the indexed head probe. 'getStream' and +-- 'StreamInfo' retain their existing representation and cost. getStreamWithHead :: - (HasCallStack, Store :> es) => - StreamName -> - Eff es (Maybe (StreamInfo, Maybe GlobalPosition)) + (HasCallStack, Store :> es) => + StreamName -> + Eff es (Maybe (StreamInfo, Maybe GlobalPosition)) getStreamWithHead name = send (GetStreamWithHead 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. --} +-- | 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) + (HasCallStack, Store :> es) => + StreamName -> + Eff es (Maybe StreamId) lookupStreamId name = send (LookupStreamId name) -{- | Return 'True' when the supplied event id is linked into the supplied live -stream, and 'False' when the event id is absent, belongs only to another stream, -or the stream is nonexistent or soft-deleted. - -This is a point lookup for idempotency checks. Prefer it over scanning a stream -when the caller already has the event id it is looking for. --} +-- | Return 'True' when the supplied event id is linked into the supplied live +-- stream, and 'False' when the event id is absent, belongs only to another stream, +-- or the stream is nonexistent or soft-deleted. +-- +-- This is a point lookup for idempotency checks. Prefer it over scanning a stream +-- when the caller already has the event id it is looking for. eventExistsInStream :: - (HasCallStack, Store :> es) => - StreamName -> - EventId -> - Eff es Bool + (HasCallStack, Store :> es) => + StreamName -> + EventId -> + Eff es Bool eventExistsInStream name eid = send (EventExistsInStream name eid) -{- | 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 any database round trip because -the interpreter short-circuits. --} +-- | 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 any database round trip because +-- the interpreter short-circuits. lookupStreamNames :: - (HasCallStack, Store :> es) => - [StreamId] -> - Eff es (Map StreamId StreamName) + (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. --} +-- | 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) + (HasCallStack, Store :> es) => + StreamId -> + Eff es (Maybe StreamName) lookupStreamName sid = Map.lookup sid <$> lookupStreamNames [sid] -{- | Page streams in stable UTF-8 byte order, independent of database locale. -Category equality includes its bare name; prefix matching is literal, including -@%@ and @_@. Use the last returned name as the exclusive cursor. Soft-deleted -streams remain visible, hard-deleted streams do not. Only the reserved row is -excluded, so @$all-x@ and empty categories are valid. A short page proves current -exhaustion. Concurrent lifecycle changes are not a snapshot-isolation guarantee. -TypeID timestamps give generation order, not event/commit order. --} +-- | Page streams in stable UTF-8 byte order, independent of database locale. +-- Category equality includes its bare name; prefix matching is literal, including +-- @%@ and @_@. Use the last returned name as the exclusive cursor. Soft-deleted +-- streams remain visible, hard-deleted streams do not. Only the reserved row is +-- excluded, so @$all-x@ and empty categories are valid. A short page proves current +-- exhaustion. Concurrent lifecycle changes are not a snapshot-isolation guarantee. +-- TypeID timestamps give generation order, not event/commit order. listStreams :: (HasCallStack, Store :> es) => Maybe CategoryName -> Maybe Text -> Maybe StreamName -> BrowsePageSize -> Eff es (Vector StreamInfo) listStreams category prefix after limit = send (ListStreams category prefix after limit) diff --git a/src/Kiroku/Store/SQL.hs b/src/Kiroku/Store/SQL.hs --- a/src/Kiroku/Store/SQL.hs +++ b/src/Kiroku/Store/SQL.hs @@ -1,1574 +1,1655 @@ {-# LANGUAGE MultilineStrings #-} -module Kiroku.Store.SQL ( - -- * Append statements - AppendParams (..), - appendParamsEncoder, - appendResultDecoder, - appendExpectedVersion, - appendStreamExists, - appendNoStream, - appendAnyVersion, - - -- * Link statements - linkToStreamStmt, - - -- * Read statements - readStreamForwardStmt, - readStreamBackwardStmt, - readAllForwardStmt, - readAllBackwardStmt, - readCategoryForwardStmt, - readCategoryEncoder, - getStreamStmt, - getStreamWithHeadStmt, - eventExistsInStreamStmt, - lookupStreamNamesStmt, - listStreamsSession, - StreamRangeBound (..), - listStreamsRangeStmt, - listStreamsPairStmt, - listCategoriesStmt, - getEventStmt, - currentGlobalPositionStmt, - visibleGlobalHeadPositionStmt, - - -- * Consumer-group read statements - readCategoryForwardConsumerGroupStmt, - readCategoryConsumerGroupEncoder, - readAllForwardConsumerGroupStmt, - - -- * Row decoders - recordedEventRow, - - -- * Causation / correlation statements - findByCorrelationStmt, - findCausationDescendantsStmt, - findCausationAncestorsStmt, - - -- * Lifecycle statements - softDeleteStreamStmt, - undeleteStreamStmt, - setStreamTruncateBeforeStmt, - - -- * Hard-delete statements (used in sequence inside one transaction) - findStreamIdStmt, - deleteAllRowsForOriginStmt, - deleteJunctionsByEventIdsStmt, - deleteStreamOwnJunctionsStmt, - deleteDeadLettersForOrphanedEventsStmt, - deleteOrphanedEventsStmt, - deleteStreamRowStmt, - - -- * Multi-stream pre-lock (avoids row-lock deadlocks) - lockStreamsForMultiStmt, - - -- * Checkpoint statements - getCheckpointStmt, - saveCheckpointStmt, - getCheckpointMemberStmt, - saveCheckpointMemberStmt, - saveAllCheckpointMemberStmt, - saveCategoryCheckpointMemberStmt, - - -- * Dead-letter statements - DeadLetterParams (..), - DeadLetterRecord (..), - insertDeadLetterAndCheckpointStmt, - readDeadLettersStmt, - listSubscriptionDeadLettersStmt, - listSubscriptionDeadLettersFromStartStmt, - listSubscriptionMemberDeadLettersStmt, - listSubscriptionMemberDeadLettersFromStartStmt, -) where - -import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5, contrazip6) -import Control.Lens ((^.)) -import Data.Aeson (Value) -import Data.Char (chr, ord) -import Data.Functor.Contravariant ((>$<)) -import Data.Generics.Labels () -import Data.Int (Int32, Int64) -import Data.Text (Text) -import Data.Text qualified as T -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.Session qualified as Session -import Hasql.Statement (Statement, preparable) -import Kiroku.Store.Subscription.DeadLetter.SQL (listSubscriptionDeadLettersFromStartStmt, listSubscriptionDeadLettersStmt, listSubscriptionMemberDeadLettersFromStartStmt, listSubscriptionMemberDeadLettersStmt) -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, category, 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, category) - SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category - 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, category, 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, category) - SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category - 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, category, 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, category) - SELECT ne.event_id, 0, au.initial_global_version + ne.idx, si.stream_id, si.initial_version + ne.idx, si.category - 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, category, 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, category) - SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category - 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 (6 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) - <*> (StreamVersion <$> D.column (D.nonNullable D.int8)) -- truncate_before - --- | 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))) - --- | Read the greatest position still visible in the global $all stream. -visibleGlobalHeadPositionStmt :: Statement () GlobalPosition -visibleGlobalHeadPositionStmt = - preparable - """ - SELECT COALESCE(( - SELECT stream_version - FROM stream_events - WHERE stream_id = 0 - ORDER BY stream_version DESC - LIMIT 1 - ), 0) - """ - E.noParams - (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8))) - --- | Metadata and the newest surviving originated global position in one snapshot. -getStreamWithHeadStmt :: Statement Text (Maybe (StreamInfo, Maybe GlobalPosition)) -getStreamWithHeadStmt = - preparable - getStreamWithHeadSQL - (E.param (E.nonNullable E.text)) - (D.rowMaybe ((,) <$> streamInfoRow <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8)))) - -getStreamWithHeadSQL :: Text -getStreamWithHeadSQL = - """ - SELECT s.stream_id, s.stream_name, s.stream_version, - s.created_at, s.deleted_at, s.truncate_before, - (SELECT se.stream_version - FROM stream_events AS se - WHERE se.stream_id = 0 - AND se.original_stream_id = s.stream_id - ORDER BY se.stream_version DESC - LIMIT 1) AS head_global_position - FROM streams AS s - WHERE s.stream_name = $1 - """ - --- | Get stream metadata by name. -getStreamStmt :: Statement Text (Maybe StreamInfo) -getStreamStmt = - preparable - getStreamSQL - (E.param (E.nonNullable E.text)) - (D.rowMaybe streamInfoRow) - --- | Point probe for whether an event exists in a live stream. -eventExistsInStreamStmt :: Statement (Text, UUID) Bool -eventExistsInStreamStmt = - preparable - """ - SELECT EXISTS ( - SELECT 1 - FROM stream_events se - WHERE se.event_id = $2 - AND se.stream_id = ( - SELECT stream_id - FROM streams - WHERE stream_name = $1 - AND deleted_at IS NULL - ) - ) - """ - (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.uuid))) - (D.singleRow (D.column (D.nonNullable D.bool))) - --- --------------------------------------------------------------------------- --- Read SQL Templates --- --------------------------------------------------------------------------- - -{- | Read from a named stream in forward order. -Joins stream_events with events and streams, filters on stream_version > -start_version, hides the logically-truncated prefix (stream_version >= -streams.truncate_before), 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 - JOIN streams s ON s.stream_id = se.stream_id - WHERE s.stream_name = $1 - AND s.deleted_at IS NULL - AND se.stream_version > $2 - AND se.stream_version >= s.truncate_before - ORDER BY se.stream_version ASC - LIMIT $3 - """ - -{- | Read from a named stream in backward order. -The start version is an exclusive upper bound. The interpreter maps -caller cursor 0 to 'maxBound' so "from latest" stays a Haskell API -sentinel and the SQL keeps a plain range predicate. --} -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 - JOIN streams s ON s.stream_id = se.stream_id - WHERE s.stream_name = $1 - AND s.deleted_at IS NULL - AND se.stream_version < $2 - AND se.stream_version >= s.truncate_before - 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. -The global log deliberately ignores the per-stream @truncate_before@ marker: -logical truncation only hides events from ordered per-stream reads, never from -the @$all@ backbone that subscriptions and projections consume. --} -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. -The start position is an exclusive upper bound. The interpreter maps -caller cursor 0 to 'maxBound' so "from latest" stays a Haskell API -sentinel and the SQL keeps a plain range predicate. --} -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, truncate_before - 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. - -Scans @ix_stream_events_all_by_category@ from @(category, startPosition)@ and -stops at the limit, so a poll's cost follows the rows it returns, not the -number of streams in the category (BUG-2). The @category@ column on @$all@ -junction rows is written by the append statements (migration @0012@). Params: -@(startPosition, category, limit)@. --} -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 stream_events se - JOIN events e ON e.event_id = se.event_id - WHERE se.stream_id = 0 - AND se.category = $2 - AND se.stream_version > $1 - 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 read scans @ix_stream_events_all_by_category@ from -@(category, startPosition)@ and applies the predicate to -@se.original_stream_id@, which the index carries as an @INCLUDE@ column, so -other members' rows are skipped on index tuples. A poll touches about -@limit * size@ index entries at most, never one probe per stream in the -category (BUG-2). 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 stream_events se - JOIN events e ON e.event_id = se.event_id - WHERE se.stream_id = 0 - AND se.category = $2 - AND se.stream_version > $1 - AND (((hashtextextended(se.original_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))) - -{- | Set a stream's logical truncate-before marker. Returns Nothing if the -stream does not exist or is soft-deleted. --} -setStreamTruncateBeforeStmt :: Statement (Text, Int64) (Maybe StreamId) -setStreamTruncateBeforeStmt = - preparable - setStreamTruncateBeforeSQL - (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.int8))) - (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 the @$all@ junction rows for events that originated in the target -stream, returning exactly those originated event ids. - -Served by @ix_stream_events_all_by_origin@, whose partial predicate is -@stream_id = 0@. Every event that originated in a stream has one @$all@ row, so -this indexed delete yields the complete originated-event set without scanning all -of @stream_events@. - -The caller then passes the returned ids to 'deleteJunctionsByEventIdsStmt' to -remove the remaining home/link junction rows for those originated events. --} -deleteAllRowsForOriginStmt :: Statement Int64 (Vector UUID) -deleteAllRowsForOriginStmt = - preparable - """ - DELETE FROM stream_events - WHERE original_stream_id = $1 - AND stream_id = 0 - RETURNING event_id - """ - (E.param (E.nonNullable E.int8)) - (D.rowVector (D.column (D.nonNullable D.uuid))) - -{- | Delete all remaining junction rows for the given event ids. - -Served by the @stream_events@ primary key @(event_id, stream_id)@. This removes -the originated events' home rows and any link rows in other streams after -'deleteAllRowsForOriginStmt' has removed their @$all@ rows. --} -deleteJunctionsByEventIdsStmt :: Statement (Vector UUID) () -deleteJunctionsByEventIdsStmt = - preparable - """ - DELETE FROM stream_events - WHERE event_id = ANY($1::uuid[]) - """ - (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid)))) - D.noResult - -{- | Delete junction rows whose visible stream is the target stream, returning -the affected event ids. - -Served by @ix_stream_events_stream_version@ (or the unique replacement -@ux_stream_events_stream_version@ after EP-5 M3) on @(stream_id, -stream_version)@. After 'deleteJunctionsByEventIdsStmt' this matches only -events that originated elsewhere and were linked into the deleted stream. Those -events normally survive; returning them lets the same orphan check make the -decision instead of relying on that assumption. --} -deleteStreamOwnJunctionsStmt :: Statement Int64 (Vector UUID) -deleteStreamOwnJunctionsStmt = - preparable - """ - DELETE FROM stream_events - WHERE stream_id = $1 - RETURNING event_id - """ - (E.param (E.nonNullable E.int8)) - (D.rowVector (D.column (D.nonNullable D.uuid))) - -{- | Delete dead-letter rows for candidate events that have become orphaned. - -Served by @ix_dead_letters_event_id@. The @NOT EXISTS@ predicate mirrors -'deleteOrphanedEventsStmt', so dead letters are purged exactly for events whose -payload rows are about to be removed while dead letters for surviving linked-in -events remain. - -Must be called after the junction deletes and before 'deleteOrphanedEventsStmt' -within the same transaction so the @NOT EXISTS@ subquery sees the post-delete -state of @stream_events@ and the @dead_letters.event_id@ foreign key remains -satisfied when orphan event payloads are deleted. --} -deleteDeadLettersForOrphanedEventsStmt :: Statement (Vector UUID) () -deleteDeadLettersForOrphanedEventsStmt = - preparable - """ - DELETE FROM dead_letters dl - WHERE dl.event_id = ANY($1::uuid[]) - AND NOT EXISTS ( - SELECT 1 FROM stream_events se - WHERE se.event_id = dl.event_id - ) - """ - (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid)))) - D.noResult - -{- | 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). - -The first implementation tried to inline orphan-event deletion with a -data-modifying CTE, 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 multiple -statements within the same hasql-transaction lets each statement see previous -statements' effects. - -Must be called after 'deleteDeadLettersForOrphanedEventsStmt' within the same -transaction so the @NOT EXISTS@ subquery sees the post-delete state of -@stream_events@ and the @dead_letters.event_id@ foreign key is already clear. --} -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. - -\$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. See EP-1 F4. - -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 do serialize on the unique index on -@stream_name@, but that serialization does /not/ preserve the -source-before-$all acquisition order this pre-lock exists to establish, -and a multi-stream append can still deadlock against a concurrent -single-stream append: - - * multi locks stream A, then @$all@ (both inside A's CTE), then stream B; - * a single-stream append to the still-fresh B locks B, then wants @$all@. - -Each then waits on the other. PostgreSQL detects it and aborts one side -with @40P01@; the interpreter retries the append once, and a repeated -conflict reaches the caller as -'Kiroku.Store.Error.TransientTransactionFailure', which is documented -retryable. Eliminating the cycle would mean establishing every source -lock before any @$all@ lock, including for streams that do not exist yet -— tracked as IR-7, deliberately not done here because it is a throughput -question that needs benchmarking, not a correctness gap. --} -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 - """ - -{- | Set the logical truncate-before marker on a live stream. Soft-deleted -streams (deleted_at IS NOT NULL) match no row and return Nothing, matching -the other lifecycle statements. --} -setStreamTruncateBeforeSQL :: Text -setStreamTruncateBeforeSQL = - """ - UPDATE streams - SET truncate_before = $2 - WHERE stream_name = $1 - AND deleted_at IS 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, Int32, Text, Maybe Text) () -saveCheckpointMemberStmt = - preparable - saveCheckpointMemberSQL - ( contrazip6 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.text)) - ) - D.noResult - --- | Bound targets use a fixed kind rather than encoding a constant per save. -saveAllCheckpointMemberStmt :: Statement (Text, Int32, Int64, Int32) () -saveAllCheckpointMemberStmt = - preparable - (saveCheckpointMemberSQLWith "'all', NULL") - (contrazip4 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.int4)) (E.param (E.nonNullable E.int8)) (E.param (E.nonNullable E.int4))) - D.noResult - -saveCategoryCheckpointMemberStmt :: Statement (Text, Int32, Int64, Int32, Text) () -saveCategoryCheckpointMemberStmt = - preparable - (saveCheckpointMemberSQLWith "'category', $5") - (contrazip5 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.int4)) (E.param (E.nonNullable E.int8)) (E.param (E.nonNullable E.int4)) (E.param (E.nonNullable E.text))) - D.noResult - -getCheckpointMemberSQL :: Text -getCheckpointMemberSQL = - """ - SELECT last_seen - FROM subscriptions - WHERE subscription_name = $1 - AND consumer_group_member = $2 - """ - -saveCheckpointMemberSQL :: Text -saveCheckpointMemberSQL = saveCheckpointMemberSQLWith "$5, $6" - -saveCheckpointMemberSQLWith :: Text -> Text -saveCheckpointMemberSQLWith binding = - "INSERT INTO subscriptions (subscription_name, consumer_group_member, last_seen, updated_at, consumer_group_size, target_kind, target_category) VALUES ($1, $2, $3, now(), $4, " - <> binding - <> ") " - <> """ - ON CONFLICT (subscription_name, consumer_group_member) - DO UPDATE SET last_seen = GREATEST(subscriptions.last_seen, EXCLUDED.last_seen), updated_at = now(), consumer_group_size = EXCLUDED.consumer_group_size, target_kind = EXCLUDED.target_kind, target_category = EXCLUDED.target_category - """ - --- --------------------------------------------------------------------------- --- Dead-letter Statements --- --------------------------------------------------------------------------- - --- | Parameters for 'insertDeadLetterAndCheckpointStmt'. -data DeadLetterParams = DeadLetterParams - { dlSubscriptionName :: !Text - , dlMember :: !Int32 - , dlTargetKind :: !Text - , dlTargetCategory :: !(Maybe Text) - , dlGroupSize :: !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)) - <> ((^. #dlGroupSize) >$< E.param (E.nonNullable E.int4)) - <> ((^. #dlTargetKind) >$< E.param (E.nonNullable E.text)) - <> ((^. #dlTargetCategory) >$< E.param (E.nullable E.text)) - -{- | 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, consumer_group_size, target_kind, target_category) - VALUES ($1, $2, $3, now(), $8, $9, $10) - ON CONFLICT (subscription_name, consumer_group_member) - DO UPDATE SET last_seen = GREATEST(subscriptions.last_seen, EXCLUDED.last_seen), updated_at = now(), consumer_group_size = EXCLUDED.consumer_group_size, target_kind = EXCLUDED.target_kind, target_category = EXCLUDED.target_category - """ - --- | 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 - """ - --- Catalog statements have a finite family of prepared shapes. Upper bounds --- are deliberately checked after the ordered LIMIT, keeping generic plans --- from bitmap-scanning and sorting an entire matching prefix. -data StreamRangeBound = InclusiveLower | ExclusiveLower | ExactName - deriving stock (Eq, Show) - -streamColumns :: Text -streamColumns = "stream_id, stream_name, stream_version, created_at, deleted_at, truncate_before" - -streamRangeSQL :: StreamRangeBound -> Text -> Text -> Text -> Text -streamRangeSQL bound lower upper limit = - "SELECT * FROM (SELECT " - <> streamColumns - <> " FROM streams WHERE stream_id <> 0 AND stream_name COLLATE \"C\" " - <> operator - <> " " - <> lower - <> " ORDER BY stream_name COLLATE \"C\" LIMIT " - <> limit - <> ") bounded WHERE (" - <> upper - <> "::text IS NULL OR stream_name COLLATE \"C\" < " - <> upper - <> ")" - where - operator = case bound of InclusiveLower -> ">="; ExclusiveLower -> ">"; ExactName -> "=" - -listStreamsRangeStmt :: StreamRangeBound -> Statement (Text, Maybe Text, Int32) (Vector StreamInfo) -listStreamsRangeStmt bound = - preparable - (streamRangeSQL bound "$1" "$2" "$3" <> " ORDER BY stream_name COLLATE \"C\"") - (contrazip3 (E.param (E.nonNullable E.text)) (E.param (E.nullable E.text)) (E.param (E.nonNullable E.int4))) - (D.rowVector streamInfoRow) - -listStreamsPairStmt :: StreamRangeBound -> StreamRangeBound -> Statement (Text, Maybe Text, Text, Maybe Text, Int32) (Vector StreamInfo) -listStreamsPairStmt first second = - preparable - ( "SELECT * FROM ((" - <> streamRangeSQL first "$1" "$2" "$5" - <> ") UNION ALL (" - <> streamRangeSQL second "$3" "$4" "$5" - <> ")) matching ORDER BY stream_name COLLATE \"C\" LIMIT $5" - ) - ( contrazip5 - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nonNullable E.int4)) - ) - (D.rowVector streamInfoRow) - -{- | One statement and one checkout, including the bare-category/descendant union. -All text is encoded as parameters; only closed operator choices build SQL. --} -listStreamsSession :: Maybe CategoryName -> Maybe Text -> Maybe StreamName -> BrowsePageSize -> Session.Session (Vector StreamInfo) -listStreamsSession category prefix after page = case ranges of - [] -> pure mempty - [(kind, lower, upper)] -> Session.statement (lower, upper, limit) (listStreamsRangeStmt kind) - [(kind, lower, upper), (kind2, lower2, upper2)] -> - Session.statement (lower, upper, lower2, upper2, limit) (listStreamsPairStmt kind kind2) - _ -> error "catalog range invariant: at most two disjoint ranges" - where - limit = browsePageSizeValue page - cursor = fmap (\(StreamName value) -> value) after - ranges = case category of - Nothing -> maybe [] pure (interval "" Nothing) - Just (CategoryName value) - | T.any (== '-') value -> [] - | otherwise -> bare value <> maybe [] pure (interval (value <> "-") (prefixEnd (value <> "-"))) - bare value - | maybe True (`T.isPrefixOf` value) prefix && maybe True (< value) cursor = [(ExactName, value, Nothing)] - | otherwise = [] - interval start end = - let lower = max start (maybe "" (\value -> value) prefix) - upper = minimumEnd end (prefix >>= prefixEnd) - (kind, seek) = case cursor of - Just value | value >= lower -> (ExclusiveLower, value) - _ -> (InclusiveLower, lower) - in if maybe False (<= seek) upper then Nothing else Just (kind, seek, upper) - minimumEnd Nothing b = b - minimumEnd a Nothing = a - minimumEnd (Just a) (Just b) = Just (min a b) - --- Valid UTF-8 byte order follows Unicode scalar order. The all-maximum and --- empty prefixes have no finite upper bound; PostgreSQL text has no NUL. -prefixEnd :: Text -> Maybe Text -prefixEnd value = case T.unsnoc value of - Nothing -> Nothing - Just (initial, lastChar) - | ord lastChar == 0x10ffff -> prefixEnd initial - | otherwise -> Just (T.snoc initial (chr (if ord lastChar + 1 == 0xd800 then 0xe000 else ord lastChar + 1))) - --- First and later category pages have separate cursor shapes. Category order --- retains the deployment collation and its existing category index. -listCategoriesStmt :: Bool -> Statement (Maybe Text, Int32) (Vector Text) -listCategoriesStmt after = - preparable - query - (contrazip2 (E.param (E.nullable E.text)) (E.param (E.nonNullable E.int4))) - (D.rowVector (D.column (D.nonNullable D.text))) - where - first = if after then "AND s.category > $1" else "AND $1::text IS NULL" - query = - "WITH RECURSIVE next_category AS (SELECT (SELECT s.category FROM streams s WHERE s.stream_id <> 0 " - <> first - <> " ORDER BY s.category LIMIT 1) AS category UNION ALL SELECT (SELECT s.category FROM streams s " - <> "WHERE s.stream_id <> 0 AND s.category > n.category ORDER BY s.category LIMIT 1) " - <> "FROM next_category n WHERE n.category IS NOT NULL) SELECT category FROM next_category " - <> "WHERE category IS NOT NULL LIMIT $2" - -getEventStmt :: Statement UUID (Maybe RecordedEvent) -getEventStmt = - preparable - "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.event_id=$1" - (E.param (E.nonNullable E.uuid)) - (D.rowMaybe recordedEventRow) +module Kiroku.Store.SQL + ( -- * Append statements + AppendParams (..), + appendParamsEncoder, + appendResultDecoder, + appendExpectedVersion, + appendStreamExists, + appendNoStream, + appendAnyVersion, + + -- * Link statements + linkToStreamStmt, + + -- * Read statements + readStreamForwardStmt, + readStreamBackwardStmt, + readAllForwardStmt, + readAllBackwardStmt, + readCategoryForwardStmt, + readCategoryEncoder, + NamespaceWindow (..), + readNamespaceWindowStmt, + readNamespaceGroupWindowStmt, + getStreamStmt, + getStreamWithHeadStmt, + eventExistsInStreamStmt, + lookupStreamNamesStmt, + listStreamsSession, + StreamRangeBound (..), + listStreamsRangeStmt, + listStreamsPairStmt, + listCategoriesStmt, + getEventStmt, + currentGlobalPositionStmt, + visibleGlobalHeadPositionStmt, + + -- * Consumer-group read statements + readCategoryForwardConsumerGroupStmt, + readCategoryConsumerGroupEncoder, + readAllForwardConsumerGroupStmt, + + -- * Row decoders + recordedEventRow, + + -- * Causation / correlation statements + findByCorrelationStmt, + findCausationDescendantsStmt, + findCausationAncestorsStmt, + + -- * Lifecycle statements + softDeleteStreamStmt, + undeleteStreamStmt, + setStreamTruncateBeforeStmt, + + -- * Hard-delete statements (used in sequence inside one transaction) + findStreamIdStmt, + deleteAllRowsForOriginStmt, + deleteJunctionsByEventIdsStmt, + deleteStreamOwnJunctionsStmt, + deleteDeadLettersForOrphanedEventsStmt, + deleteOrphanedEventsStmt, + deleteStreamRowStmt, + + -- * Multi-stream pre-lock (avoids row-lock deadlocks) + lockStreamsForMultiStmt, + + -- * Checkpoint statements + getCheckpointStmt, + saveCheckpointStmt, + getCheckpointMemberStmt, + saveCheckpointMemberStmt, + saveAllCheckpointMemberStmt, + saveCategoryCheckpointMemberStmt, + saveNamespaceCheckpointMemberStmt, + + -- * Dead-letter statements + DeadLetterParams (..), + DeadLetterRecord (..), + insertDeadLetterAndCheckpointStmt, + readDeadLettersStmt, + listSubscriptionDeadLettersStmt, + listSubscriptionDeadLettersFromStartStmt, + listSubscriptionMemberDeadLettersStmt, + listSubscriptionMemberDeadLettersFromStartStmt, + ) +where + +import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5, contrazip6) +import Control.Lens ((^.)) +import Data.Aeson (Value) +import Data.Char (chr, ord) +import Data.Functor.Contravariant ((>$<)) +import Data.Generics.Labels () +import Data.Int (Int32, Int64) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime) +import Data.UUID (UUID) +import Data.Vector (Vector) +import Data.Vector qualified as V +import GHC.Generics (Generic) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Session qualified as Session +import Hasql.Statement (Statement, preparable) +import Kiroku.Store.Subscription.DeadLetter.SQL (listSubscriptionDeadLettersFromStartStmt, listSubscriptionDeadLettersStmt, listSubscriptionMemberDeadLettersFromStartStmt, listSubscriptionMemberDeadLettersStmt) +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, category, 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, category) + SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category + 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, category, 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, category) + SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category + 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, category, 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, category) + SELECT ne.event_id, 0, au.initial_global_version + ne.idx, si.stream_id, si.initial_version + ne.idx, si.category + 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, category, 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, category) + SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx, su.category + 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 (6 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) + <*> (StreamVersion <$> D.column (D.nonNullable D.int8)) -- truncate_before + +-- | 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))) + +-- | Read the greatest position still visible in the global $all stream. +visibleGlobalHeadPositionStmt :: Statement () GlobalPosition +visibleGlobalHeadPositionStmt = + preparable + """ + SELECT COALESCE(( + SELECT stream_version + FROM stream_events + WHERE stream_id = 0 + ORDER BY stream_version DESC + LIMIT 1 + ), 0) + """ + E.noParams + (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8))) + +-- | Metadata and the newest surviving originated global position in one snapshot. +getStreamWithHeadStmt :: Statement Text (Maybe (StreamInfo, Maybe GlobalPosition)) +getStreamWithHeadStmt = + preparable + getStreamWithHeadSQL + (E.param (E.nonNullable E.text)) + (D.rowMaybe ((,) <$> streamInfoRow <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8)))) + +getStreamWithHeadSQL :: Text +getStreamWithHeadSQL = + """ + SELECT s.stream_id, s.stream_name, s.stream_version, + s.created_at, s.deleted_at, s.truncate_before, + (SELECT se.stream_version + FROM stream_events AS se + WHERE se.stream_id = 0 + AND se.original_stream_id = s.stream_id + ORDER BY se.stream_version DESC + LIMIT 1) AS head_global_position + FROM streams AS s + WHERE s.stream_name = $1 + """ + +-- | Get stream metadata by name. +getStreamStmt :: Statement Text (Maybe StreamInfo) +getStreamStmt = + preparable + getStreamSQL + (E.param (E.nonNullable E.text)) + (D.rowMaybe streamInfoRow) + +-- | Point probe for whether an event exists in a live stream. +eventExistsInStreamStmt :: Statement (Text, UUID) Bool +eventExistsInStreamStmt = + preparable + """ + SELECT EXISTS ( + SELECT 1 + FROM stream_events se + WHERE se.event_id = $2 + AND se.stream_id = ( + SELECT stream_id + FROM streams + WHERE stream_name = $1 + AND deleted_at IS NULL + ) + ) + """ + (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.uuid))) + (D.singleRow (D.column (D.nonNullable D.bool))) + +-- --------------------------------------------------------------------------- +-- Read SQL Templates +-- --------------------------------------------------------------------------- + +-- | Read from a named stream in forward order. +-- Joins stream_events with events and streams, filters on stream_version > +-- start_version, hides the logically-truncated prefix (stream_version >= +-- streams.truncate_before), 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 + JOIN streams s ON s.stream_id = se.stream_id + WHERE s.stream_name = $1 + AND s.deleted_at IS NULL + AND se.stream_version > $2 + AND se.stream_version >= s.truncate_before + ORDER BY se.stream_version ASC + LIMIT $3 + """ + +-- | Read from a named stream in backward order. +-- The start version is an exclusive upper bound. The interpreter maps +-- caller cursor 0 to 'maxBound' so "from latest" stays a Haskell API +-- sentinel and the SQL keeps a plain range predicate. +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 + JOIN streams s ON s.stream_id = se.stream_id + WHERE s.stream_name = $1 + AND s.deleted_at IS NULL + AND se.stream_version < $2 + AND se.stream_version >= s.truncate_before + 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. +-- The global log deliberately ignores the per-stream @truncate_before@ marker: +-- logical truncation only hides events from ordered per-stream reads, never from +-- the @$all@ backbone that subscriptions and projections consume. +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. +-- The start position is an exclusive upper bound. The interpreter maps +-- caller cursor 0 to 'maxBound' so "from latest" stays a Haskell API +-- sentinel and the SQL keeps a plain range predicate. +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, truncate_before + 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. +-- +-- Scans @ix_stream_events_all_by_category@ from @(category, startPosition)@ and +-- stops at the limit, so a poll's cost follows the rows it returns, not the +-- number of streams in the category (BUG-2). The @category@ column on @$all@ +-- junction rows is written by the append statements (migration @0012@). Params: +-- @(startPosition, category, limit)@. +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 stream_events se + JOIN events e ON e.event_id = se.event_id + WHERE se.stream_id = 0 + AND se.category = $2 + AND se.stream_version > $1 + 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 read scans @ix_stream_events_all_by_category@ from +-- @(category, startPosition)@ and applies the predicate to +-- @se.original_stream_id@, which the index carries as an @INCLUDE@ column, so +-- other members' rows are skipped on index tuples. A poll touches about +-- @limit * size@ index entries at most, never one probe per stream in the +-- category (BUG-2). 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 stream_events se + JOIN events e ON e.event_id = se.event_id + WHERE se.stream_id = 0 + AND se.category = $2 + AND se.stream_version > $1 + AND (((hashtextextended(se.original_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 + """ + +-- | One bounded global scan, including progress when there are no matches. +-- The payloads and frontier come from one statement snapshot. +data NamespaceWindow = NamespaceWindow + { namespaceEvents :: !(Vector RecordedEvent), + scannedThrough :: !GlobalPosition, + scannedCount :: !Int32, + exhausted :: !Bool + } + deriving stock (Show) + +-- | @(exclusive cursor, captured head, literal namespace, window size)@. +readNamespaceWindowStmt :: Statement (Int64, Int64, Text, Int32) NamespaceWindow +readNamespaceWindowStmt = + preparable + (namespaceWindowSQL False) + (contrazip4 (E.param (E.nonNullable E.int8)) (E.param (E.nonNullable E.int8)) (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.int4))) + namespaceWindowDecoder + +-- | Group filtering happens after bounding the scan, using the originating id. +readNamespaceGroupWindowStmt :: Statement (Int64, Int64, Text, Int32, Int32, Int32) NamespaceWindow +readNamespaceGroupWindowStmt = + preparable + (namespaceWindowSQL True) + (contrazip6 (E.param (E.nonNullable E.int8)) (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))) + namespaceWindowDecoder + +namespaceWindowSQL :: Bool -> Text +namespaceWindowSQL grouped = + """ + WITH scanned AS MATERIALIZED ( + SELECT event_id, stream_version, original_stream_id, original_stream_version, category + FROM stream_events + -- stream_id is integral: this range selects exactly $all. Keeping both + -- index keys in the ordering prevents custom tail plans from choosing + -- the partial category index and sorting an unrestricted metadata scan. + WHERE stream_id >= 0 AND stream_id < 1 AND stream_version > $1 + ORDER BY stream_id, stream_version LIMIT $4 + ), eligible AS MATERIALIZED ( + SELECT * FROM scanned WHERE stream_version <= $2 + ), progress AS ( + SELECT count(*)::int4 AS scanned_count, + count(*) < $4 OR coalesce(max(stream_version) = $2, false) AS exhausted, + CASE WHEN count(*) < $4 OR coalesce(max(stream_version) = $2, false) + THEN $2 ELSE max(stream_version) END AS frontier + FROM eligible + ), matching AS MATERIALIZED ( + SELECT * FROM eligible + WHERE (category COLLATE "C" = $3 OR starts_with(category COLLATE "C", $3 || ':')) + """ + <> (if grouped then " AND (((hashtextextended(original_stream_id::text, 0) % $6) + $6) % $6) = $5" else "") + <> """ + ) + , payloads AS MATERIALIZED ( + SELECT m.stream_version, + ROW(e.event_id, e.event_type, m.stream_version, m.stream_version, + m.original_stream_id, m.original_stream_version, + e.data, e.metadata, e.causation_id, e.correlation_id, e.created_at) AS event + FROM matching m + -- OFFSET 0 keeps event-id probes behind matching in generic plans. + LEFT JOIN LATERAL (SELECT * FROM events WHERE event_id = m.event_id OFFSET 0) e ON true + ) + SELECT p.frontier, p.scanned_count, p.exhausted, payloads.event + FROM progress p + -- Generate the sentinel after payload probing, so an empty matching set + -- never invokes even a zero-I/O NULL event-id lookup. + LEFT JOIN payloads ON true + ORDER BY payloads.stream_version + """ + +-- The sentinel's NULL record is explicit. A selected junction without a payload +-- produces a non-null record with null required fields and fails decoding. +namespaceWindowDecoder :: D.Result NamespaceWindow +namespaceWindowDecoder = assemble <$> D.rowVector row + where + row = + (,,,) + <$> (GlobalPosition <$> D.column (D.nonNullable D.int8)) + <*> D.column (D.nonNullable D.int4) + <*> D.column (D.nonNullable D.bool) + <*> D.column (D.nullable (D.record eventRecord)) + assemble rows = + let (frontier, count, done, _) = V.head rows + in NamespaceWindow (V.fromList (mapMaybe (\(_, _, _, event) -> event) (V.toList rows))) frontier count done + eventRecord = + RecordedEvent + <$> (EventId <$> D.field (D.nonNullable D.uuid)) + <*> (EventType <$> D.field (D.nonNullable D.text)) + <*> (StreamVersion <$> D.field (D.nonNullable D.int8)) + <*> (GlobalPosition <$> D.field (D.nonNullable D.int8)) + <*> (StreamId <$> D.field (D.nonNullable D.int8)) + <*> (StreamVersion <$> D.field (D.nonNullable D.int8)) + <*> D.field (D.nonNullable D.jsonb) + <*> D.field (D.nullable D.jsonb) + <*> D.field (D.nullable D.uuid) + <*> D.field (D.nullable D.uuid) + <*> D.field (D.nonNullable D.timestamptz) + +-- --------------------------------------------------------------------------- +-- 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))) + +-- | Set a stream's logical truncate-before marker. Returns Nothing if the +-- stream does not exist or is soft-deleted. +setStreamTruncateBeforeStmt :: Statement (Text, Int64) (Maybe StreamId) +setStreamTruncateBeforeStmt = + preparable + setStreamTruncateBeforeSQL + (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.int8))) + (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 the @$all@ junction rows for events that originated in the target +-- stream, returning exactly those originated event ids. +-- +-- Served by @ix_stream_events_all_by_origin@, whose partial predicate is +-- @stream_id = 0@. Every event that originated in a stream has one @$all@ row, so +-- this indexed delete yields the complete originated-event set without scanning all +-- of @stream_events@. +-- +-- The caller then passes the returned ids to 'deleteJunctionsByEventIdsStmt' to +-- remove the remaining home/link junction rows for those originated events. +deleteAllRowsForOriginStmt :: Statement Int64 (Vector UUID) +deleteAllRowsForOriginStmt = + preparable + """ + DELETE FROM stream_events + WHERE original_stream_id = $1 + AND stream_id = 0 + RETURNING event_id + """ + (E.param (E.nonNullable E.int8)) + (D.rowVector (D.column (D.nonNullable D.uuid))) + +-- | Delete all remaining junction rows for the given event ids. +-- +-- Served by the @stream_events@ primary key @(event_id, stream_id)@. This removes +-- the originated events' home rows and any link rows in other streams after +-- 'deleteAllRowsForOriginStmt' has removed their @$all@ rows. +deleteJunctionsByEventIdsStmt :: Statement (Vector UUID) () +deleteJunctionsByEventIdsStmt = + preparable + """ + DELETE FROM stream_events + WHERE event_id = ANY($1::uuid[]) + """ + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid)))) + D.noResult + +-- | Delete junction rows whose visible stream is the target stream, returning +-- the affected event ids. +-- +-- Served by @ix_stream_events_stream_version@ (or the unique replacement +-- @ux_stream_events_stream_version@ after EP-5 M3) on @(stream_id, +-- stream_version)@. After 'deleteJunctionsByEventIdsStmt' this matches only +-- events that originated elsewhere and were linked into the deleted stream. Those +-- events normally survive; returning them lets the same orphan check make the +-- decision instead of relying on that assumption. +deleteStreamOwnJunctionsStmt :: Statement Int64 (Vector UUID) +deleteStreamOwnJunctionsStmt = + preparable + """ + DELETE FROM stream_events + WHERE stream_id = $1 + RETURNING event_id + """ + (E.param (E.nonNullable E.int8)) + (D.rowVector (D.column (D.nonNullable D.uuid))) + +-- | Delete dead-letter rows for candidate events that have become orphaned. +-- +-- Served by @ix_dead_letters_event_id@. The @NOT EXISTS@ predicate mirrors +-- 'deleteOrphanedEventsStmt', so dead letters are purged exactly for events whose +-- payload rows are about to be removed while dead letters for surviving linked-in +-- events remain. +-- +-- Must be called after the junction deletes and before 'deleteOrphanedEventsStmt' +-- within the same transaction so the @NOT EXISTS@ subquery sees the post-delete +-- state of @stream_events@ and the @dead_letters.event_id@ foreign key remains +-- satisfied when orphan event payloads are deleted. +deleteDeadLettersForOrphanedEventsStmt :: Statement (Vector UUID) () +deleteDeadLettersForOrphanedEventsStmt = + preparable + """ + DELETE FROM dead_letters dl + WHERE dl.event_id = ANY($1::uuid[]) + AND NOT EXISTS ( + SELECT 1 FROM stream_events se + WHERE se.event_id = dl.event_id + ) + """ + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid)))) + D.noResult + +-- | 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). +-- +-- The first implementation tried to inline orphan-event deletion with a +-- data-modifying CTE, 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 multiple +-- statements within the same hasql-transaction lets each statement see previous +-- statements' effects. +-- +-- Must be called after 'deleteDeadLettersForOrphanedEventsStmt' within the same +-- transaction so the @NOT EXISTS@ subquery sees the post-delete state of +-- @stream_events@ and the @dead_letters.event_id@ foreign key is already clear. +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. +-- +-- \$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. See EP-1 F4. +-- +-- 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 do serialize on the unique index on +-- @stream_name@, but that serialization does /not/ preserve the +-- source-before-$all acquisition order this pre-lock exists to establish, +-- and a multi-stream append can still deadlock against a concurrent +-- single-stream append: +-- +-- * multi locks stream A, then @$all@ (both inside A's CTE), then stream B; +-- * a single-stream append to the still-fresh B locks B, then wants @$all@. +-- +-- Each then waits on the other. PostgreSQL detects it and aborts one side +-- with @40P01@; the interpreter retries the append once, and a repeated +-- conflict reaches the caller as +-- 'Kiroku.Store.Error.TransientTransactionFailure', which is documented +-- retryable. Eliminating the cycle would mean establishing every source +-- lock before any @$all@ lock, including for streams that do not exist yet +-- — tracked as IR-7, deliberately not done here because it is a throughput +-- question that needs benchmarking, not a correctness gap. +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 + """ + +-- | Set the logical truncate-before marker on a live stream. Soft-deleted +-- streams (deleted_at IS NOT NULL) match no row and return Nothing, matching +-- the other lifecycle statements. +setStreamTruncateBeforeSQL :: Text +setStreamTruncateBeforeSQL = + """ + UPDATE streams + SET truncate_before = $2 + WHERE stream_name = $1 + AND deleted_at IS 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, Int32, Text, Maybe Text) () +saveCheckpointMemberStmt = + preparable + saveCheckpointMemberSQL + ( contrazip6 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + (E.param (E.nullable E.text)) + ) + D.noResult + +-- | Bound targets use a fixed kind rather than encoding a constant per save. +saveAllCheckpointMemberStmt :: Statement (Text, Int32, Int64, Int32) () +saveAllCheckpointMemberStmt = + preparable + (saveCheckpointMemberSQLWith "'all', NULL") + (contrazip4 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.int4)) (E.param (E.nonNullable E.int8)) (E.param (E.nonNullable E.int4))) + D.noResult + +saveCategoryCheckpointMemberStmt :: Statement (Text, Int32, Int64, Int32, Text) () +saveCategoryCheckpointMemberStmt = + preparable + (saveCheckpointMemberSQLWith "'category', $5") + (contrazip5 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.int4)) (E.param (E.nonNullable E.int8)) (E.param (E.nonNullable E.int4)) (E.param (E.nonNullable E.text))) + D.noResult + +-- | Namespace saves keep the existing all/category hot statements unchanged. +saveNamespaceCheckpointMemberStmt :: Statement (Text, Int32, Int64, Int32, Text) () +saveNamespaceCheckpointMemberStmt = + preparable + (saveCheckpointMemberSQLWith "'category_namespace', $5") + (contrazip5 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.int4)) (E.param (E.nonNullable E.int8)) (E.param (E.nonNullable E.int4)) (E.param (E.nonNullable E.text))) + D.noResult + +getCheckpointMemberSQL :: Text +getCheckpointMemberSQL = + """ + SELECT last_seen + FROM subscriptions + WHERE subscription_name = $1 + AND consumer_group_member = $2 + """ + +saveCheckpointMemberSQL :: Text +saveCheckpointMemberSQL = saveCheckpointMemberSQLWith "$5, $6" + +saveCheckpointMemberSQLWith :: Text -> Text +saveCheckpointMemberSQLWith binding = + "INSERT INTO subscriptions (subscription_name, consumer_group_member, last_seen, updated_at, consumer_group_size, target_kind, target_category) VALUES ($1, $2, $3, now(), $4, " + <> binding + <> ") " + <> """ + ON CONFLICT (subscription_name, consumer_group_member) + DO UPDATE SET last_seen = GREATEST(subscriptions.last_seen, EXCLUDED.last_seen), updated_at = now(), consumer_group_size = EXCLUDED.consumer_group_size, target_kind = EXCLUDED.target_kind, target_category = EXCLUDED.target_category + """ + +-- --------------------------------------------------------------------------- +-- Dead-letter Statements +-- --------------------------------------------------------------------------- + +-- | Parameters for 'insertDeadLetterAndCheckpointStmt'. +data DeadLetterParams = DeadLetterParams + { dlSubscriptionName :: !Text, + dlMember :: !Int32, + dlTargetKind :: !Text, + dlTargetCategory :: !(Maybe Text), + dlGroupSize :: !Int32, + dlGlobalPosition :: !Int64, + dlEventId :: !UUID, + -- | structured JSONB reason (@reason@ column) + dlReason :: !Value, + -- | operator-facing summary (@reason_summary@ column) + dlReasonSummary :: !Text, + 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)) + <> ((^. #dlGroupSize) >$< E.param (E.nonNullable E.int4)) + <> ((^. #dlTargetKind) >$< E.param (E.nonNullable E.text)) + <> ((^. #dlTargetCategory) >$< E.param (E.nullable E.text)) + +-- | 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, consumer_group_size, target_kind, target_category) + VALUES ($1, $2, $3, now(), $8, $9, $10) + ON CONFLICT (subscription_name, consumer_group_member) + DO UPDATE SET last_seen = GREATEST(subscriptions.last_seen, EXCLUDED.last_seen), updated_at = now(), consumer_group_size = EXCLUDED.consumer_group_size, target_kind = EXCLUDED.target_kind, target_category = EXCLUDED.target_category + """ + +-- | 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 + """ + +-- Catalog statements have a finite family of prepared shapes. Upper bounds +-- are deliberately checked after the ordered LIMIT, keeping generic plans +-- from bitmap-scanning and sorting an entire matching prefix. +data StreamRangeBound = InclusiveLower | ExclusiveLower | ExactName + deriving stock (Eq, Show) + +streamColumns :: Text +streamColumns = "stream_id, stream_name, stream_version, created_at, deleted_at, truncate_before" + +streamRangeSQL :: StreamRangeBound -> Text -> Text -> Text -> Text +streamRangeSQL bound lower upper limit = + "SELECT * FROM (SELECT " + <> streamColumns + <> " FROM streams WHERE stream_id <> 0 AND stream_name COLLATE \"C\" " + <> operator + <> " " + <> lower + <> " ORDER BY stream_name COLLATE \"C\" LIMIT " + <> limit + <> ") bounded WHERE (" + <> upper + <> "::text IS NULL OR stream_name COLLATE \"C\" < " + <> upper + <> ")" + where + operator = case bound of InclusiveLower -> ">="; ExclusiveLower -> ">"; ExactName -> "=" + +listStreamsRangeStmt :: StreamRangeBound -> Statement (Text, Maybe Text, Int32) (Vector StreamInfo) +listStreamsRangeStmt bound = + preparable + (streamRangeSQL bound "$1" "$2" "$3" <> " ORDER BY stream_name COLLATE \"C\"") + (contrazip3 (E.param (E.nonNullable E.text)) (E.param (E.nullable E.text)) (E.param (E.nonNullable E.int4))) + (D.rowVector streamInfoRow) + +listStreamsPairStmt :: StreamRangeBound -> StreamRangeBound -> Statement (Text, Maybe Text, Text, Maybe Text, Int32) (Vector StreamInfo) +listStreamsPairStmt first second = + preparable + ( "SELECT * FROM ((" + <> streamRangeSQL first "$1" "$2" "$5" + <> ") UNION ALL (" + <> streamRangeSQL second "$3" "$4" "$5" + <> ")) matching ORDER BY stream_name COLLATE \"C\" LIMIT $5" + ) + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nullable E.text)) + (E.param (E.nonNullable E.int4)) + ) + (D.rowVector streamInfoRow) + +-- | One statement and one checkout, including the bare-category/descendant union. +-- All text is encoded as parameters; only closed operator choices build SQL. +listStreamsSession :: Maybe CategoryName -> Maybe Text -> Maybe StreamName -> BrowsePageSize -> Session.Session (Vector StreamInfo) +listStreamsSession category prefix after page = case ranges of + [] -> pure mempty + [(kind, lower, upper)] -> Session.statement (lower, upper, limit) (listStreamsRangeStmt kind) + [(kind, lower, upper), (kind2, lower2, upper2)] -> + Session.statement (lower, upper, lower2, upper2, limit) (listStreamsPairStmt kind kind2) + _ -> error "catalog range invariant: at most two disjoint ranges" + where + limit = browsePageSizeValue page + cursor = fmap (\(StreamName value) -> value) after + ranges = case category of + Nothing -> maybe [] pure (interval "" Nothing) + Just (CategoryName value) + | T.any (== '-') value -> [] + | otherwise -> bare value <> maybe [] pure (interval (value <> "-") (prefixEnd (value <> "-"))) + bare value + | maybe True (`T.isPrefixOf` value) prefix && maybe True (< value) cursor = [(ExactName, value, Nothing)] + | otherwise = [] + interval start end = + let lower = max start (maybe "" (\value -> value) prefix) + upper = minimumEnd end (prefix >>= prefixEnd) + (kind, seek) = case cursor of + Just value | value >= lower -> (ExclusiveLower, value) + _ -> (InclusiveLower, lower) + in if maybe False (<= seek) upper then Nothing else Just (kind, seek, upper) + minimumEnd Nothing b = b + minimumEnd a Nothing = a + minimumEnd (Just a) (Just b) = Just (min a b) + +-- Valid UTF-8 byte order follows Unicode scalar order. The all-maximum and +-- empty prefixes have no finite upper bound; PostgreSQL text has no NUL. +prefixEnd :: Text -> Maybe Text +prefixEnd value = case T.unsnoc value of + Nothing -> Nothing + Just (initial, lastChar) + | ord lastChar == 0x10ffff -> prefixEnd initial + | otherwise -> Just (T.snoc initial (chr (if ord lastChar + 1 == 0xd800 then 0xe000 else ord lastChar + 1))) + +-- First and later category pages have separate cursor shapes. Category order +-- retains the deployment collation and its existing category index. +listCategoriesStmt :: Bool -> Statement (Maybe Text, Int32) (Vector Text) +listCategoriesStmt after = + preparable + query + (contrazip2 (E.param (E.nullable E.text)) (E.param (E.nonNullable E.int4))) + (D.rowVector (D.column (D.nonNullable D.text))) + where + first = if after then "AND s.category > $1" else "AND $1::text IS NULL" + query = + "WITH RECURSIVE next_category AS (SELECT (SELECT s.category FROM streams s WHERE s.stream_id <> 0 " + <> first + <> " ORDER BY s.category LIMIT 1) AS category UNION ALL SELECT (SELECT s.category FROM streams s " + <> "WHERE s.stream_id <> 0 AND s.category > n.category ORDER BY s.category LIMIT 1) " + <> "FROM next_category n WHERE n.category IS NOT NULL) SELECT category FROM next_category " + <> "WHERE category IS NOT NULL LIMIT $2" + +getEventStmt :: Statement UUID (Maybe RecordedEvent) +getEventStmt = + preparable + "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.event_id=$1" + (E.param (E.nonNullable E.uuid)) + (D.rowMaybe recordedEventRow) diff --git a/src/Kiroku/Store/Settings.hs b/src/Kiroku/Store/Settings.hs --- a/src/Kiroku/Store/Settings.hs +++ b/src/Kiroku/Store/Settings.hs @@ -1,44 +1,43 @@ -{- | 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 -retain the original event list/vector without traversal. Subscription -decoding adds one batch constructor, with no per-event wrappers. - -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 (Right (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 (..), +-- | 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 +-- retain the original event list/vector without traversal. Subscription +-- decoding adds one batch constructor, with no per-event wrappers. +-- +-- 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 (Right (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, DecodeFailure (..), @@ -50,7 +49,8 @@ decodedBatchLength, decodedBatchLastEvent, filterDecodedBatch, -) where + ) +where import Data.Text (Text) import Data.Vector (Vector) @@ -58,108 +58,102 @@ import GHC.Generics (Generic) import Kiroku.Store.Types (EventData, EventId, RecordedEvent) -{- | A hook could not decode this event. Return it through 'Left'; throwing -from the hook remains a programming error. Default retry exhaustion is surfaced -by SubscriptionUndecodable, carrying this failure. --} +-- | A hook could not decode this event. Return it through 'Left'; throwing +-- from the hook remains a programming error. Default retry exhaustion is surfaced +-- by SubscriptionUndecodable, carrying this failure. data DecodeFailure = DecodeFailure - { decodeFailureEventId :: !EventId - , decodeFailureReason :: !Text - } - deriving stock (Eq, Show, Generic) + { decodeFailureEventId :: !EventId, + decodeFailureReason :: !Text + } + deriving stock (Eq, Show, Generic) -- | A transformed event, or its raw value retained for retry and disposition. data DecodedEvent - = Decoded !RecordedEvent - | Undecodable !RecordedEvent !DecodeFailure - deriving stock (Eq, Show) + = Decoded !RecordedEvent + | Undecodable !RecordedEvent !DecodeFailure + deriving stock (Eq, Show) -{- | No hook means no traversal or per-event wrappers. Hook results are shared -by all live publisher subscribers, whose retry/disposition is independent. --} +-- | No hook means no traversal or per-event wrappers. Hook results are shared +-- by all live publisher subscribers, whose retry/disposition is independent. data DecodedBatch - = UnchangedBatch !(Vector RecordedEvent) - | TransformedBatch !(Vector DecodedEvent) - deriving stock (Eq, Show) + = UnchangedBatch !(Vector RecordedEvent) + | TransformedBatch !(Vector DecodedEvent) + deriving stock (Eq, Show) decodedEventRecorded :: DecodedEvent -> RecordedEvent decodedEventRecorded = \case - Decoded event -> event - Undecodable event _ -> event + Decoded event -> event + Undecodable event _ -> event decodedBatchLength :: DecodedBatch -> Int decodedBatchLength = \case - UnchangedBatch events -> V.length events - TransformedBatch events -> V.length events + UnchangedBatch events -> V.length events + TransformedBatch events -> V.length events decodedBatchLastEvent :: DecodedBatch -> RecordedEvent decodedBatchLastEvent = \case - UnchangedBatch events -> V.last events - TransformedBatch events -> decodedEventRecorded (V.last events) + UnchangedBatch events -> V.last events + TransformedBatch events -> decodedEventRecorded (V.last events) filterDecodedBatch :: (RecordedEvent -> Bool) -> DecodedBatch -> DecodedBatch filterDecodedBatch predicate = \case - UnchangedBatch events -> UnchangedBatch (V.filter predicate events) - TransformedBatch events -> TransformedBatch (V.filter (predicate . decodedEventRecorded) events) - -{- | 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. + UnchangedBatch events -> UnchangedBatch (V.filter predicate events) + TransformedBatch events -> TransformedBatch (V.filter (predicate . decodedEventRecorded) events) -When a field is 'Nothing', reads and enrichment return their input directly. -Subscription decoding retains the vector in one batch constructor without -traversal or per-event wrappers. --} +-- | 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', reads and enrichment return their input directly. +-- Subscription decoding retains the vector in one batch constructor without +-- traversal or per-event wrappers. data StoreSettings = StoreSettings - { enrichEvent :: !(Maybe (EventData -> IO EventData)) - -- ^ Append-path hook. Runs once per appended event before encoding. - , decodeHook :: !(Maybe (RecordedEvent -> IO (Either DecodeFailure RecordedEvent))) - {- ^ Read- and subscription-path hook. Return 'Left' for an undecodable - event: reads fail with a typed store error, subscriptions use their - optional undecodable handler or retry and stop by default. Exceptions - remain programming failures. Runs once per surfaced event; an undecodable - event's retry re-applies the hook to its original value. - -} - } - deriving stock (Generic) + { -- | Append-path hook. Runs once per appended event before encoding. + enrichEvent :: !(Maybe (EventData -> IO EventData)), + -- | Read- and subscription-path hook. Return 'Left' for an undecodable + -- event: reads fail with a typed store error, subscriptions use their + -- optional undecodable handler or retry and stop by default. Exceptions + -- remain programming failures. Runs once per surfaced event; an undecodable + -- event's retry re-applies the hook to its original value. + decodeHook :: !(Maybe (RecordedEvent -> IO (Either DecodeFailure RecordedEvent))) + } + deriving stock (Generic) -- | Defaults to both hooks being 'Nothing' — semantically a no-op. defaultStoreSettings :: StoreSettings defaultStoreSettings = - StoreSettings - { enrichEvent = Nothing - , decodeHook = Nothing - } + StoreSettings + { enrichEvent = Nothing, + decodeHook = Nothing + } -{- | Apply 'enrichEvent' to a list of events. When the hook is -'Nothing', returns the list unchanged with no traversal. --} +-- | 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 + Nothing -> pure xs + Just f -> traverse f xs -{- | Apply 'decodeHook' to a vector of events. When the hook is -'Nothing', retains the vector unchanged without traversal or per-event wrappers. --} +-- | Apply 'decodeHook' to a vector of events. When the hook is +-- 'Nothing', retains the vector unchanged without traversal or per-event wrappers. decodeEvents :: StoreSettings -> Vector RecordedEvent -> IO DecodedBatch decodeEvents ss xs = case decodeHook ss of - Nothing -> pure (UnchangedBatch xs) - Just f -> TransformedBatch <$> V.mapM (applyDecode f) xs + Nothing -> pure (UnchangedBatch xs) + Just f -> TransformedBatch <$> V.mapM (applyDecode f) xs -- | Re-apply the hook to one raw undecodable event on a subscriber retry. decodeEvent :: StoreSettings -> RecordedEvent -> IO DecodedEvent decodeEvent ss event = case decodeHook ss of - Nothing -> pure (Decoded event) - Just f -> applyDecode f event + Nothing -> pure (Decoded event) + Just f -> applyDecode f event applyDecode :: (RecordedEvent -> IO (Either DecodeFailure RecordedEvent)) -> RecordedEvent -> IO DecodedEvent applyDecode f event = either (Undecodable event) Decoded <$> f event diff --git a/src/Kiroku/Store/Subscription.hs b/src/Kiroku/Store/Subscription.hs --- a/src/Kiroku/Store/Subscription.hs +++ b/src/Kiroku/Store/Subscription.hs @@ -1,5 +1,5 @@ -module Kiroku.Store.Subscription ( - -- * Subscribe +module Kiroku.Store.Subscription + ( -- * Subscribe subscribe, withSubscription, @@ -12,7 +12,8 @@ -- * Types module Kiroku.Store.Subscription.Types, -) where + ) +where import Control.Concurrent.Async qualified as Async import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVarIO) @@ -39,313 +40,314 @@ import Kiroku.Store.Subscription.Worker (LiveSource (..), configMember, runWorker) import Kiroku.Store.Types (CategoryName (..), GlobalPosition (..)) -{- | Start a subscription. Returns a handle for cancellation and waiting. - -The subscription spawns a worker thread that: - -1. Resolves the exact @(subscription name, consumer-group member)@ checkpoint. - An existing row always wins. If absent, 'missingCheckpointPolicy' durably - seeds zero, atomically seeds the current @$all@ head, or fails before the - handler runs. A database error fails the worker loudly through 'wait'; it - does not fall back to 0. -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 outside a consumer group, the worker reads pre-broadcast - events from the publisher's bounded per-subscriber queue. For - 'Kiroku.Store.Subscription.Types.Category' subscriptions and all - consumer-group subscriptions, no publisher queue is created; the worker - re-queries the database in live mode. - -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 non-group 'Kiroku.Store.Subscription.Types.AllStreams' - subscription overflowed under - 'Kiroku.Store.Subscription.Types.DropSubscription'. Category and - consumer-group subscriptions do not own publisher queues, so - 'queueCapacity' and 'overflowPolicy' have no effect for them. - 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@ where @e@ is - 'Kiroku.Store.Subscription.Types.SubscriptionUndecodable' — the default - decode retry policy exhausted. The exception carries 'DecodeFailure'; - the checkpoint remains before the failed event. Fix the hook and restart - the same subscription to replay it. -* @Left e@ where @e@ is a 'Hasql.Pool.UsageError' from checkpoint load — - startup could not read the saved checkpoint. The worker stops rather than - silently replaying from global position 0. -* @Left e@ where @e@ is - 'Kiroku.Store.Subscription.Types.SubscriptionCheckpointMissing' — - 'Kiroku.Store.Subscription.Types.FailIfMissing' refused an absent exact key. - No checkpoint row was inserted and the handler did not run. -* @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. --} +-- | Start a subscription. Returns a handle for cancellation and waiting. +-- +-- The subscription spawns a worker thread that: +-- +-- 1. Resolves the exact @(subscription name, consumer-group member)@ checkpoint. +-- An existing row always wins. If absent, 'missingCheckpointPolicy' durably +-- seeds zero, atomically seeds the current @$all@ head, or fails before the +-- handler runs. A database error fails the worker loudly through 'wait'; it +-- does not fall back to 0. +-- 2. Catches up by querying the database directly until it reaches the +-- 'Kiroku.Store.Subscription.EventPublisher.lastPublished' cursor. Namespace +-- targets instead capture the committed database head and drain bounded +-- global windows through it, including windows without matching events. +-- 3. Switches to live mode. For 'Kiroku.Store.Subscription.Types.AllStreams' +-- subscriptions outside a consumer group, the worker reads pre-broadcast +-- events from the publisher's bounded per-subscriber queue. For +-- 'Kiroku.Store.Subscription.Types.Category' subscriptions and all +-- consumer-group subscriptions, no publisher queue is created; the worker +-- re-queries the database in live mode. +-- +-- 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 (or the completed +-- scan frontier for a namespace window); 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 non-group 'Kiroku.Store.Subscription.Types.AllStreams' +-- subscription overflowed under +-- 'Kiroku.Store.Subscription.Types.DropSubscription'. Category and +-- consumer-group subscriptions do not own publisher queues, so +-- 'queueCapacity' and 'overflowPolicy' have no effect for them. +-- 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@ where @e@ is +-- 'Kiroku.Store.Subscription.Types.SubscriptionUndecodable' — the default +-- decode retry policy exhausted. The exception carries 'DecodeFailure'; +-- the checkpoint remains before the failed event. Fix the hook and restart +-- the same subscription to replay it. +-- * @Left e@ where @e@ is a 'Hasql.Pool.UsageError' from checkpoint load — +-- startup could not read the saved checkpoint. The worker stops rather than +-- silently replaying from global position 0. +-- * @Left e@ where @e@ is +-- 'Kiroku.Store.Subscription.Types.SubscriptionCheckpointMissing' — +-- 'Kiroku.Store.Subscription.Types.FailIfMissing' refused an absent exact key. +-- No checkpoint row was inserted and the handler did not run. +-- * @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 - mask $ \_restore -> + mask $ \_restore -> + bracketOnError + ( case (consumerGroup config, target config) of + (Nothing, AllStreams) -> do + (queue, statusVar, unsubscribe) <- + atomically $ + Pub.subscribePublisher + (store ^. #publisher) + (queueCapacity config) + (overflowPolicy config) + pure (LiveFromPublisherQueue queue statusVar, unsubscribe) + -- Plain categories and consumer-group category members both wake + -- on the category's NOTIFY generation; a member's fetch applies + -- its partition predicate in SQL. + (_, Category (CategoryName cat)) -> + pure (LiveFromCategoryNotify cat, pure ()) + (_, CategoryNamespace namespace) -> do + (generation, release) <- + atomically $ + Notifier.registerNamespace (Notifier.namespaceRegistry (store ^. #notifier)) namespace + pure (LiveFromNamespaceNotify generation, atomically release) + (Just _, AllStreams) -> + pure (LiveFromGroupPolling, pure ()) + ) + (\(_, unsubscribe) -> unsubscribe) + $ \(liveSource, unsubscribe) -> do + -- 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) + deregister = + atomically + ( modifyTVar' reg $ + Map.update + ( \(tok', cell) -> + if tok' == token + then Nothing + else Just (tok', cell) + ) + key + ) + -- `finally cleanup` 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 >> deregister + -- Insert before forking so a caller that reads a snapshot immediately after + -- `subscribe` returns already sees this subscription. bracketOnError - ( case (consumerGroup config, target config) of - (Nothing, AllStreams) -> do - (queue, statusVar, unsubscribe) <- - atomically $ - Pub.subscribePublisher - (store ^. #publisher) - (queueCapacity config) - (overflowPolicy config) - pure (LiveFromPublisherQueue queue statusVar, unsubscribe) - -- Plain categories and consumer-group category members both wake - -- on the category's NOTIFY generation; a member's fetch applies - -- its partition predicate in SQL. - (_, Category (CategoryName cat)) -> - pure (LiveFromCategoryNotify cat, pure ()) - (Just _, AllStreams) -> - pure (LiveFromGroupPolling, pure ()) - ) - (\(_, unsubscribe) -> unsubscribe) - $ \(liveSource, unsubscribe) -> do - -- 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) - deregister = - atomically - ( modifyTVar' reg $ - Map.update - ( \(tok', cell) -> - if tok' == token - then Nothing - else Just (tok', cell) - ) - key - ) - -- `finally cleanup` 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 >> deregister - -- Insert before forking so a caller that reads a snapshot immediately after - -- `subscribe` returns already sees this subscription. - bracketOnError - (atomically $ modifyTVar' reg (Map.insert key (token, stateVar))) - (const deregister) - $ \() -> do - -- Every acquisition above is paired with a release in the - -- pre-fork window; once asyncWithUnmask returns, ownership of - -- both releases has transferred to the worker thread's cleanup. - thread <- - Async.asyncWithUnmask $ \unmask -> - unmask - (runWorker (store ^. #pool) liveSource 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 + (atomically $ modifyTVar' reg (Map.insert key (token, stateVar))) + (const deregister) + $ \() -> do + -- Every acquisition above is paired with a release in the + -- pre-fork window; once asyncWithUnmask returns, ownership of + -- both releases has transferred to the worker thread's cleanup. + thread <- + Async.asyncWithUnmask $ \unmask -> + unmask + (runWorker (store ^. #pool) liveSource 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 + } -but lifted to any 'MonadUnliftIO' so it composes with effectful stacks -that already have an unlift in scope. --} +-- | 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 + (MonadUnliftIO m) => + KirokuStore -> + SubscriptionConfig -> + (SubscriptionHandle -> m a) -> + m a withSubscription store config action = withRunInIO $ \runInIO -> - bracket (subscribe store config) cancel (runInIO . action) - -{- | Read the durable checkpoint inventory and global store position captured by -one PostgreSQL statement snapshot. - -An empty 'checkpoints' vector means that no subscription checkpoint has yet -been written. Unlike 'subscriptionStates', stopped subscriptions remain in this -inventory because their committed rows are durable. Rows are sorted by -subscription name and consumer-group member, and a new call is required to -observe commits made after this snapshot. + bracket (subscribe store config) cancel (runInIO . action) -A live worker cursor may be ahead of its durable checkpoint while work is in -flight. Member zero alone does not reveal whether a subscription is ungrouped -or is member zero of a group. 'checkpointUpdatedAt' records the last successful -checkpoint write, not proof that its position advanced. Finally, subtracting a -'checkpointPosition' from 'storePosition' yields a global position distance, -not an exact count of relevant events for filtered, category, or sharded -consumers. --} +-- | Read the durable checkpoint inventory and global store position captured by +-- one PostgreSQL statement snapshot. +-- +-- An empty 'checkpoints' vector means that no subscription checkpoint has yet +-- been written. Unlike 'subscriptionStates', stopped subscriptions remain in this +-- inventory because their committed rows are durable. Rows are sorted by +-- subscription name and consumer-group member, and a new call is required to +-- observe commits made after this snapshot. +-- +-- A live worker cursor may be ahead of its durable checkpoint while work is in +-- flight. Member zero alone does not reveal whether a subscription is ungrouped +-- or is member zero of a group. 'checkpointUpdatedAt' records the last successful +-- checkpoint write, not proof that its position advanced. Finally, subtracting a +-- 'checkpointPosition' from 'storePosition' yields a global position distance, +-- not an exact count of relevant events for filtered, category, or sharded +-- consumers. subscriptionCheckpointInventory :: - (HasCallStack, Store :> es) => - Eff es SubscriptionCheckpointInventory + (HasCallStack, Store :> es) => + Eff es SubscriptionCheckpointInventory subscriptionCheckpointInventory = send GetSubscriptionCheckpointInventory -{- | Resolve the durable checkpoint for one exact @(subscription name, -consumer-group member)@ key. - -An existing row is returned unchanged for every policy. When no row exists, -'FromBeginning' atomically inserts position zero, 'FromCurrentHead' atomically -inserts the current @$all@ store position, and 'FailIfMissing' returns -'SubscriptionCheckpointMissing' without inserting. Concurrent initializers -converge on the first committed row. --} +-- | Resolve the durable checkpoint for one exact @(subscription name, +-- consumer-group member)@ key. +-- +-- An existing row is returned unchanged for every policy. When no row exists, +-- 'FromBeginning' atomically inserts position zero, 'FromCurrentHead' atomically +-- inserts the current @$all@ store position, and 'FailIfMissing' returns +-- 'SubscriptionCheckpointMissing' without inserting. Concurrent initializers +-- converge on the first committed row. initializeSubscriptionCheckpoint :: - (HasCallStack, Store :> es) => - SubscriptionName -> - Int32 -> - MissingCheckpointPolicy -> - Eff es (Either SubscriptionCheckpointMissing CheckpointInitialization) + (HasCallStack, Store :> es) => + SubscriptionName -> + Int32 -> + MissingCheckpointPolicy -> + Eff es (Either SubscriptionCheckpointMissing CheckpointInitialization) initializeSubscriptionCheckpoint subscriptionName member policy = - send (InitializeSubscriptionCheckpoint subscriptionName member policy) - -{- | 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. + send (InitializeSubscriptionCheckpoint subscriptionName member policy) -Read fields via the codebase's @generic-lens@ convention, e.g. @view ^. #state@. --} +-- | 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. + { subscriptionName :: !SubscriptionName, + member :: !Int32, + state :: !SubscriptionState, + statePhase :: !Text, + cursor :: !GlobalPosition + } + deriving stock (Show, Generic) -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. --} +-- | 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 - -{- | Read one subscription's dead letters, newest first by global position and -then dead-letter id. Echo the page's 'nextCursor' as 'after' for an exclusive -next page. 'consumerGroupMember' Nothing includes all historical members; Just -selects one (ungrouped subscriptions use 0). All-member work is bounded by the -number of historical members times the page size; use member-scoped polling for -large groups. One statement and one pool checkout serve a page. + 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 -The reason JSON is returned unchanged, without an event decoding hook. An empty -page means no dead letters were recorded for this query. Hard-deleting source -streams can remove rows, but their cursors remain valid. This operation neither -writes a checkpoint nor changes the worker or cleanup paths. --} +-- | Read one subscription's dead letters, newest first by global position and +-- then dead-letter id. Echo the page's 'nextCursor' as 'after' for an exclusive +-- next page. 'consumerGroupMember' Nothing includes all historical members; Just +-- selects one (ungrouped subscriptions use 0). All-member work is bounded by the +-- number of historical members times the page size; use member-scoped polling for +-- large groups. One statement and one pool checkout serve a page. +-- +-- The reason JSON is returned unchanged, without an event decoding hook. An empty +-- page means no dead letters were recorded for this query. Hard-deleting source +-- streams can remove rows, but their cursors remain valid. This operation neither +-- writes a checkpoint nor changes the worker or cleanup paths. subscriptionDeadLetters :: (HasCallStack, Store :> es) => SubscriptionDeadLetterQuery -> Eff es SubscriptionDeadLetterPage subscriptionDeadLetters = send . ListSubscriptionDeadLetters diff --git a/src/Kiroku/Store/Subscription/Checkpoint.hs b/src/Kiroku/Store/Subscription/Checkpoint.hs --- a/src/Kiroku/Store/Subscription/Checkpoint.hs +++ b/src/Kiroku/Store/Subscription/Checkpoint.hs @@ -1,17 +1,17 @@ -{- | Explicit mutation operations for durable subscription checkpoints. - -Ordinary subscription checkpoint saves are monotonic. This module owns the -separate reset, resize and rebind operations for callers that need to move -persisted progress backward or forward as part of a larger transaction. --} -module Kiroku.Store.Subscription.Checkpoint ( - SubscriptionCheckpointResetReport (..), +-- | Explicit mutation operations for durable subscription checkpoints. +-- +-- Ordinary subscription checkpoint saves are monotonic. This module owns the +-- separate reset, resize and rebind operations for callers that need to move +-- persisted progress backward or forward as part of a larger transaction. +module Kiroku.Store.Subscription.Checkpoint + ( SubscriptionCheckpointResetReport (..), resetSubscriptionCheckpointsTx, ConsumerGroupResizeReport (..), resizeConsumerGroupTx, SubscriptionTargetRebindReport (..), rebindSubscriptionTargetTx, -) where + ) +where import Data.Int (Int32) import Data.List (nub, sort) @@ -22,122 +22,117 @@ import GHC.Generics (Generic) import Hasql.Transaction qualified as Tx import Kiroku.Store.Subscription.Checkpoint.SQL qualified as SQL -import Kiroku.Store.Subscription.Types ( - ConsumerGroupSize, +import Kiroku.Store.Subscription.Types + ( ConsumerGroupSize, SubscriptionCheckpointKey (..), SubscriptionName (..), SubscriptionTarget, consumerGroupSizeValue, - ) + ) import Kiroku.Store.Types (GlobalPosition (..)) -{- | Exact result of resetting a non-empty set of subscription names. - -'resetCheckpointKeys' contains every persisted @(name, member)@ row that was -updated. 'missingSubscriptionNames' contains requested names for which no row -existed. Both vectors are sorted by subscription name (and then member for -keys); duplicate requested names appear only once in the report. --} +-- | Exact result of resetting a non-empty set of subscription names. +-- +-- 'resetCheckpointKeys' contains every persisted @(name, member)@ row that was +-- updated. 'missingSubscriptionNames' contains requested names for which no row +-- existed. Both vectors are sorted by subscription name (and then member for +-- keys); duplicate requested names appear only once in the report. data SubscriptionCheckpointResetReport = SubscriptionCheckpointResetReport - { resetCheckpointKeys :: !(Vector SubscriptionCheckpointKey) - , missingSubscriptionNames :: !(Vector SubscriptionName) - } - deriving stock (Eq, Show, Generic) - -{- | Set every existing checkpoint member for the requested subscription names -to the exact target position and return complete deterministic evidence. + { resetCheckpointKeys :: !(Vector SubscriptionCheckpointKey), + missingSubscriptionNames :: !(Vector SubscriptionName) + } + deriving stock (Eq, Show, Generic) -The operation treats duplicate requested names as one name, updates all -persisted members for each name, and never creates checkpoint rows for missing -names. Unlike ordinary worker saves, this operation can move a checkpoint -backward. It is a 'Tx.Transaction' combinator so a caller can atomically compose -the reset with its own projection fence and target preparation; condemning that -surrounding transaction rolls back all of those writes together. --} +-- | Set every existing checkpoint member for the requested subscription names +-- to the exact target position and return complete deterministic evidence. +-- +-- The operation treats duplicate requested names as one name, updates all +-- persisted members for each name, and never creates checkpoint rows for missing +-- names. Unlike ordinary worker saves, this operation can move a checkpoint +-- backward. It is a 'Tx.Transaction' combinator so a caller can atomically compose +-- the reset with its own projection fence and target preparation; condemning that +-- surrounding transaction rolls back all of those writes together. resetSubscriptionCheckpointsTx :: - NonEmpty SubscriptionName -> - GlobalPosition -> - Tx.Transaction SubscriptionCheckpointResetReport + NonEmpty SubscriptionName -> + GlobalPosition -> + Tx.Transaction SubscriptionCheckpointResetReport resetSubscriptionCheckpointsTx names (GlobalPosition position) = do - rows <- - Tx.statement - ( Vector.fromList - [name | SubscriptionName name <- NonEmpty.toList names] - , position - ) - SQL.resetSubscriptionCheckpointsStmt - pure - SubscriptionCheckpointResetReport - { resetCheckpointKeys = Vector.mapMaybe resetKey rows - , missingSubscriptionNames = Vector.mapMaybe missingName rows - } + rows <- + Tx.statement + ( Vector.fromList + [name | SubscriptionName name <- NonEmpty.toList names], + position + ) + SQL.resetSubscriptionCheckpointsStmt + pure + SubscriptionCheckpointResetReport + { resetCheckpointKeys = Vector.mapMaybe resetKey rows, + missingSubscriptionNames = Vector.mapMaybe missingName rows + } where resetKey (name, Just member) = - Just (SubscriptionCheckpointKey (SubscriptionName name) member) + Just (SubscriptionCheckpointKey (SubscriptionName name) member) resetKey (_, Nothing) = Nothing missingName (name, Nothing) = Just (SubscriptionName name) missingName (_, Just _) = Nothing -{- | Evidence of explicit topology equalization. Previous sizes are sorted and -distinct; all new members resume from 'resumePosition'. A missing group starts -at zero. A repeat reports the now-equalized topology without moving progress. --} +-- | Evidence of explicit topology equalization. Previous sizes are sorted and +-- distinct; all new members resume from 'resumePosition'. A missing group starts +-- at zero. A repeat reports the now-equalized topology without moving progress. data ConsumerGroupResizeReport = ConsumerGroupResizeReport - { previousSizes :: !(Vector Int32) - , previousMemberCount :: !Int - , newSize :: !ConsumerGroupSize - , resumePosition :: !GlobalPosition - } - deriving stock (Eq, Show, Generic) + { previousSizes :: !(Vector Int32), + previousMemberCount :: !Int, + newSize :: !ConsumerGroupSize, + resumePosition :: !GlobalPosition + } + deriving stock (Eq, Show, Generic) -{- | Stop every worker for the name before calling this operation. Lock its -checkpoint set, rewind every new member to the old minimum, and remove obsolete -members atomically. Existing member identities are retained. A hash-assignment -change also requires this equalization even when the group size is unchanged. -The caller can compose or roll back the resize with application-owned SQL. --} +-- | Stop every worker for the name before calling this operation. Lock its +-- checkpoint set, rewind every new member to the old minimum, and remove obsolete +-- members atomically. Existing member identities are retained. A hash-assignment +-- change also requires this equalization even when the group size is unchanged. +-- The caller can compose or roll back the resize with application-owned SQL. resizeConsumerGroupTx :: - SubscriptionName -> ConsumerGroupSize -> Tx.Transaction ConsumerGroupResizeReport + SubscriptionName -> ConsumerGroupSize -> Tx.Transaction ConsumerGroupResizeReport resizeConsumerGroupTx (SubscriptionName name) newSize = do - Tx.statement name SQL.lockCheckpointNameStmt - rows <- Tx.statement name SQL.lockCheckpointRowsStmt - let position = if Vector.null rows then 0 else Vector.minimum (Vector.map (\(_, _, p, _) -> p) rows) - previousSizes = Vector.fromList . sort . nub $ [n | (_, n, _, _) <- Vector.toList rows] - let binding = if Vector.null rows then Nothing else let (_, _, _, b) = Vector.head rows in b - (kind, category) = SQL.targetColumns binding - Tx.statement (name, consumerGroupSizeValue newSize, position, kind, category) SQL.resizeCheckpointMembersStmt - pure - ConsumerGroupResizeReport - { previousSizes = previousSizes - , previousMemberCount = Vector.length rows - , newSize = newSize - , resumePosition = GlobalPosition position - } + Tx.statement name SQL.lockCheckpointNameStmt + rows <- Tx.statement name SQL.lockCheckpointRowsStmt + let position = if Vector.null rows then 0 else Vector.minimum (Vector.map (\(_, _, p, _) -> p) rows) + previousSizes = Vector.fromList . sort . nub $ [n | (_, n, _, _) <- Vector.toList rows] + let binding = if Vector.null rows then Nothing else let (_, _, _, b) = Vector.head rows in b + (kind, category) = SQL.targetColumns binding + Tx.statement (name, consumerGroupSizeValue newSize, position, kind, category) SQL.resizeCheckpointMembersStmt + pure + ConsumerGroupResizeReport + { previousSizes = previousSizes, + previousMemberCount = Vector.length rows, + newSize = newSize, + resumePosition = GlobalPosition position + } -- | Rebind evidence includes every distinct prior binding; Nothing denotes legacy rows. data SubscriptionTargetRebindReport = SubscriptionTargetRebindReport - { reboundMemberCount :: !Int - , previousBindings :: !(Vector (Maybe SubscriptionTarget)) - , reboundTarget :: !SubscriptionTarget - , reboundPosition :: !GlobalPosition - } - deriving stock (Eq, Show) + { reboundMemberCount :: !Int, + previousBindings :: !(Vector (Maybe SubscriptionTarget)), + reboundTarget :: !SubscriptionTarget, + reboundPosition :: !GlobalPosition + } + deriving stock (Eq, Show) -{- | Stop all workers first. Bind every existing member and explicitly reset its -position in the caller's transaction. A missing name fails the transaction; -repeating the operation leaves target and progress unchanged. --} +-- | Stop all workers first. Bind every existing member and explicitly reset its +-- position in the caller's transaction. A missing name fails the transaction; +-- repeating the operation leaves target and progress unchanged. rebindSubscriptionTargetTx :: - SubscriptionName -> SubscriptionTarget -> GlobalPosition -> Tx.Transaction SubscriptionTargetRebindReport + SubscriptionName -> SubscriptionTarget -> GlobalPosition -> Tx.Transaction SubscriptionTargetRebindReport rebindSubscriptionTargetTx (SubscriptionName name) target position@(GlobalPosition pos) = do - Tx.statement name SQL.lockCheckpointNameStmt - rows <- Tx.statement name SQL.lockCheckpointRowsStmt - let (kind, category) = SQL.targetColumns (Just target) - count <- Tx.statement (name, kind, category, pos) SQL.rebindCheckpointTargetStmt - pure - SubscriptionTargetRebindReport - { reboundMemberCount = fromIntegral count - , previousBindings = Vector.fromList . nub $ [binding | (_, _, _, binding) <- Vector.toList rows] - , reboundTarget = target - , reboundPosition = position - } + Tx.statement name SQL.lockCheckpointNameStmt + rows <- Tx.statement name SQL.lockCheckpointRowsStmt + let (kind, category) = SQL.targetColumns (Just target) + count <- Tx.statement (name, kind, category, pos) SQL.rebindCheckpointTargetStmt + pure + SubscriptionTargetRebindReport + { reboundMemberCount = fromIntegral count, + previousBindings = Vector.fromList . nub $ [binding | (_, _, _, binding) <- Vector.toList rows], + reboundTarget = target, + reboundPosition = position + } diff --git a/src/Kiroku/Store/Subscription/Checkpoint/SQL.hs b/src/Kiroku/Store/Subscription/Checkpoint/SQL.hs --- a/src/Kiroku/Store/Subscription/Checkpoint/SQL.hs +++ b/src/Kiroku/Store/Subscription/Checkpoint/SQL.hs @@ -2,8 +2,8 @@ {-# LANGUAGE RankNTypes #-} -- | Package-internal SQL for subscription checkpoint lifecycle operations. -module Kiroku.Store.Subscription.Checkpoint.SQL ( - initializeSubscriptionCheckpointSession, +module Kiroku.Store.Subscription.Checkpoint.SQL + ( initializeSubscriptionCheckpointSession, initializeWorkerCheckpointSession, lockCheckpointNameStmt, lockCheckpointRowsStmt, @@ -12,7 +12,8 @@ targetColumns, saveBoundCheckpointSession, rebindCheckpointTargetStmt, -) where + ) +where import Contravariant.Extras (contrazip2, contrazip4, contrazip5, contrazip6) import Data.Int (Int32, Int64) @@ -27,8 +28,8 @@ import Hasql.Transaction qualified as Tx import Hasql.Transaction.Sessions qualified as TxSessions import Kiroku.Store.SQL qualified as SQL -import Kiroku.Store.Subscription.Types ( - CheckpointInitialization (..), +import Kiroku.Store.Subscription.Types + ( CheckpointInitialization (..), ConsumerGroupSizeMismatch (..), MissingCheckpointPolicy (..), SomeSubscriptionStartupFailure (..), @@ -38,202 +39,211 @@ SubscriptionTarget (..), SubscriptionTargetMismatch (..), TargetBindingPolicy (..), - ) + ) import Kiroku.Store.Types (CategoryName (..), GlobalPosition (..)) -{- | Resolve one checkpoint key in a Hasql session. - -The first statement inserts the policy-selected position with @ON CONFLICT DO -NOTHING@ and then reads the winning row. PostgreSQL can report no row to that -final read when another transaction committed the conflicting insert after the -statement snapshot was taken. For an initializing policy, a second statement -therefore reads the now-committed winner on a fresh snapshot. 'FailIfMissing' -does not retry because it never attempts an insert. --} +-- | Resolve one checkpoint key in a Hasql session. +-- +-- The name lock serializes topology adoption with worker startup, resize and +-- rebind. A newly inserted member inherits uniform sibling size and binding; +-- empty or inconsistent sets retain the size-1/unbound defaults. Existing rows +-- always win and sibling rows are never repaired here. +-- +-- The insert statement inserts the policy-selected position with @ON CONFLICT DO +-- NOTHING@ and then reads the winning row. PostgreSQL can report no row to that +-- final read when another transaction committed the conflicting insert after the +-- statement snapshot was taken. For an initializing policy, a second statement +-- therefore reads the now-committed winner on a fresh snapshot. 'FailIfMissing' +-- does not retry because it never attempts an insert. initializeSubscriptionCheckpointSession :: - SubscriptionName -> - Int32 -> - MissingCheckpointPolicy -> - Session.Session (Either SubscriptionCheckpointMissing CheckpointInitialization) -initializeSubscriptionCheckpointSession name member policy = - initializeCheckpointWith Session.statement name member 1 Nothing policy + SubscriptionName -> + Int32 -> + MissingCheckpointPolicy -> + Session.Session (Either SubscriptionCheckpointMissing CheckpointInitialization) +initializeSubscriptionCheckpointSession subscriptionName@(SubscriptionName name) member policy = + TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do + Tx.statement name lockCheckpointNameStmt + rows <- Tx.statement name readCheckpointRowsStmt + let topologies = nub [(size, siblingBinding) | (_, size, _, siblingBinding) <- Vector.toList rows] + (groupSize, binding) = case topologies of + [uniform] -> uniform + _ -> (1, Nothing) + initializeCheckpointWith Tx.statement subscriptionName member groupSize binding policy -{- | Startup-only validation and insertion share one checkout and one transaction. -The name lock serializes competing topologies, including an initially absent -row set. It is never acquired by ordinary checkpoint saves or event appends. --} +-- | Startup-only validation and insertion share one checkout and one transaction. +-- The name lock serializes competing topologies, including an initially absent +-- row set. It is never acquired by ordinary checkpoint saves or event appends. initializeWorkerCheckpointSession :: - SubscriptionName -> - Int32 -> - Int32 -> - SubscriptionTarget -> - TargetBindingPolicy -> - MissingCheckpointPolicy -> - Session.Session (Either SomeSubscriptionStartupFailure (CheckpointInitialization, Bool)) + SubscriptionName -> + Int32 -> + Int32 -> + SubscriptionTarget -> + TargetBindingPolicy -> + MissingCheckpointPolicy -> + Session.Session (Either SomeSubscriptionStartupFailure (CheckpointInitialization, Bool)) initializeWorkerCheckpointSession subscriptionName@(SubscriptionName name) member configured target bindingPolicy policy = - TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do - Tx.statement name lockCheckpointNameStmt - rows <- Tx.statement name readCheckpointRowsStmt - let sizes = Vector.fromList . sort . nub . fmap (\(_, n, _, _) -> n) $ Vector.toList rows - bindings = Vector.fromList . nub $ [binding | (_, _, _, binding) <- Vector.toList rows] - unbound = not (Vector.null rows) && bindings == Vector.singleton Nothing - matches = Vector.all (== Just target) bindings - if Vector.any (/= configured) sizes - then pure (Left (SomeSubscriptionStartupFailure (ConsumerGroupSizeMismatch subscriptionName configured sizes))) - else - if not matches && not (unbound && bindingPolicy == AdoptUnbound) - then pure (Left (SomeSubscriptionStartupFailure (SubscriptionTargetMismatch subscriptionName target bindings))) - else do - -- Check exact-key absence before adoption so a refused startup never - -- mutates sibling bindings. Both operations share the name lock. - resolution <- initializeCheckpointWith Tx.statement subscriptionName member configured (Just target) policy - case resolution of - Left missing -> pure (Left (SomeSubscriptionStartupFailure missing)) - Right initialized -> do - if unbound then Tx.statement (name, targetColumns (Just target)) adoptCheckpointTargetStmt else pure () - pure (Right (initialized, unbound)) + TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do + Tx.statement name lockCheckpointNameStmt + rows <- Tx.statement name readCheckpointRowsStmt + let sizes = Vector.fromList . sort . nub . fmap (\(_, n, _, _) -> n) $ Vector.toList rows + bindings = Vector.fromList . nub $ [binding | (_, _, _, binding) <- Vector.toList rows] + unbound = not (Vector.null rows) && bindings == Vector.singleton Nothing + matches = Vector.all (== Just target) bindings + if Vector.any (/= configured) sizes + then pure (Left (SomeSubscriptionStartupFailure (ConsumerGroupSizeMismatch subscriptionName configured sizes))) + else + if not matches && not (unbound && bindingPolicy == AdoptUnbound) + then pure (Left (SomeSubscriptionStartupFailure (SubscriptionTargetMismatch subscriptionName target bindings))) + else do + -- Check exact-key absence before adoption so a refused startup never + -- mutates sibling bindings. Both operations share the name lock. + resolution <- initializeCheckpointWith Tx.statement subscriptionName member configured (Just target) policy + case resolution of + Left missing -> pure (Left (SomeSubscriptionStartupFailure missing)) + Right initialized -> do + if unbound then Tx.statement (name, targetColumns (Just target)) adoptCheckpointTargetStmt else pure () + pure (Right (initialized, unbound)) initializeCheckpointWith :: - (Monad m) => - (forall a b. a -> Statement a b -> m b) -> - SubscriptionName -> - Int32 -> - Int32 -> - Maybe SubscriptionTarget -> - MissingCheckpointPolicy -> - m (Either SubscriptionCheckpointMissing CheckpointInitialization) + (Monad m) => + (forall a b. a -> Statement a b -> m b) -> + SubscriptionName -> + Int32 -> + Int32 -> + Maybe SubscriptionTarget -> + MissingCheckpointPolicy -> + m (Either SubscriptionCheckpointMissing CheckpointInitialization) initializeCheckpointWith statement subscriptionName@(SubscriptionName name) member groupSize binding policy = do - first <- statement (name, member, policyCode policy, groupSize, fst (targetColumns binding), snd (targetColumns binding)) initializeSubscriptionCheckpointStmt - case first of - Just result -> pure (Right (decodeResult result)) - Nothing -> case policy of - FailIfMissing -> pure (Left missing) - _ -> do - -- The insert lost a concurrent unique-key race after this - -- statement's snapshot. A fresh statement snapshot observes - -- the committed winner; singleRow turns a violated invariant - -- into a structured Hasql session error. - position <- statement (name, member) readInitializedCheckpointStmt - pure (Right (ExistingCheckpoint key (GlobalPosition position))) + first <- statement (name, member, policyCode policy, groupSize, fst (targetColumns binding), snd (targetColumns binding)) initializeSubscriptionCheckpointStmt + case first of + Just result -> pure (Right (decodeResult result)) + Nothing -> case policy of + FailIfMissing -> pure (Left missing) + _ -> do + -- The insert lost a concurrent unique-key race after this + -- statement's snapshot. A fresh statement snapshot observes + -- the committed winner; singleRow turns a violated invariant + -- into a structured Hasql session error. + position <- statement (name, member) readInitializedCheckpointStmt + pure (Right (ExistingCheckpoint key (GlobalPosition position))) where key = SubscriptionCheckpointKey subscriptionName member missing = SubscriptionCheckpointMissing key decodeResult (position, inserted) - | inserted = InitializedCheckpoint policy key (GlobalPosition position) - | otherwise = ExistingCheckpoint key (GlobalPosition position) + | inserted = InitializedCheckpoint policy key (GlobalPosition position) + | otherwise = ExistingCheckpoint key (GlobalPosition position) policyCode :: MissingCheckpointPolicy -> Text policyCode = \case - FromBeginning -> "from_beginning" - FromCurrentHead -> "from_current_head" - FailIfMissing -> "fail_if_missing" + FromBeginning -> "from_beginning" + FromCurrentHead -> "from_current_head" + FailIfMissing -> "fail_if_missing" initializeSubscriptionCheckpointStmt :: Statement (Text, Int32, Text, Int32, Text, Maybe Text) (Maybe (Int64, Bool)) initializeSubscriptionCheckpointStmt = - preparable - """ - WITH desired AS ( - SELECT CASE $3 - WHEN 'from_beginning' THEN 0::bigint - WHEN 'from_current_head' THEN ( - SELECT stream_version FROM streams WHERE stream_id = 0 - ) - ELSE NULL::bigint - END AS last_seen - ), - inserted AS ( - INSERT INTO subscriptions - (subscription_name, consumer_group_member, last_seen, updated_at, consumer_group_size, target_kind, target_category) - SELECT $1, $2, desired.last_seen, now(), $4, $5, $6 - FROM desired - WHERE desired.last_seen IS NOT NULL - ON CONFLICT (subscription_name, consumer_group_member) DO NOTHING - RETURNING last_seen - ) - SELECT inserted.last_seen, TRUE AS initialized - FROM inserted - UNION ALL - SELECT subscriptions.last_seen, FALSE AS initialized - FROM subscriptions - WHERE subscription_name = $1 - AND consumer_group_member = $2 - LIMIT 1 - """ - ( contrazip6 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.text)) - ) - ( D.rowMaybe $ - (,) - <$> D.column (D.nonNullable D.int8) - <*> D.column (D.nonNullable D.bool) - ) + preparable + """ + WITH desired AS ( + SELECT CASE $3 + WHEN 'from_beginning' THEN 0::bigint + WHEN 'from_current_head' THEN ( + SELECT stream_version FROM streams WHERE stream_id = 0 + ) + ELSE NULL::bigint + END AS last_seen + ), + inserted AS ( + INSERT INTO subscriptions + (subscription_name, consumer_group_member, last_seen, updated_at, consumer_group_size, target_kind, target_category) + SELECT $1, $2, desired.last_seen, now(), $4, $5, $6 + FROM desired + WHERE desired.last_seen IS NOT NULL + ON CONFLICT (subscription_name, consumer_group_member) DO NOTHING + RETURNING last_seen + ) + SELECT inserted.last_seen, TRUE AS initialized + FROM inserted + UNION ALL + SELECT subscriptions.last_seen, FALSE AS initialized + FROM subscriptions + WHERE subscription_name = $1 + AND consumer_group_member = $2 + LIMIT 1 + """ + ( contrazip6 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.text)) + (E.param (E.nullable E.text)) + ) + ( D.rowMaybe $ + (,) + <$> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.bool) + ) readInitializedCheckpointStmt :: Statement (Text, Int32) Int64 readInitializedCheckpointStmt = - preparable - """ - SELECT last_seen - FROM subscriptions - WHERE subscription_name = $1 - AND consumer_group_member = $2 - """ - ( contrazip2 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - ) - (D.singleRow (D.column (D.nonNullable D.int8))) - -{- | Reset every persisted member belonging to the requested subscription -names. The input is treated as a set by PostgreSQL. Each returned row contains -either one reset member or a requested name with no persisted rows, and the -result is deterministically ordered by name and member. + preparable + """ + SELECT last_seen + FROM subscriptions + WHERE subscription_name = $1 + AND consumer_group_member = $2 + """ + ( contrazip2 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + ) + (D.singleRow (D.column (D.nonNullable D.int8))) -This statement deliberately assigns @last_seen@ directly. Ordinary worker -saves retain their separate @GREATEST(...)@ monotonicity contract. --} +-- | Reset every persisted member belonging to the requested subscription +-- names. The input is treated as a set by PostgreSQL. Each returned row contains +-- either one reset member or a requested name with no persisted rows, and the +-- result is deterministically ordered by name and member. +-- +-- This statement deliberately assigns @last_seen@ directly. Ordinary worker +-- saves retain their separate @GREATEST(...)@ monotonicity contract. resetSubscriptionCheckpointsStmt :: - Statement (Vector Text, Int64) (Vector (Text, Maybe Int32)) + Statement (Vector Text, Int64) (Vector (Text, Maybe Int32)) resetSubscriptionCheckpointsStmt = - preparable - """ - WITH requested AS ( - SELECT DISTINCT requested_name AS subscription_name - FROM unnest($1::text[]) AS requested_name - ), - updated AS ( - UPDATE subscriptions AS checkpoint - SET last_seen = $2, updated_at = now() - FROM requested - WHERE checkpoint.subscription_name = requested.subscription_name - RETURNING checkpoint.subscription_name, checkpoint.consumer_group_member - ) - SELECT requested.subscription_name, updated.consumer_group_member - FROM requested - LEFT JOIN updated USING (subscription_name) - ORDER BY requested.subscription_name, updated.consumer_group_member - """ - ( contrazip2 - (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) - (E.param (E.nonNullable E.int8)) - ) - ( D.rowVector $ - (,) - <$> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.int4) - ) + preparable + """ + WITH requested AS ( + SELECT DISTINCT requested_name AS subscription_name + FROM unnest($1::text[]) AS requested_name + ), + updated AS ( + UPDATE subscriptions AS checkpoint + SET last_seen = $2, updated_at = now() + FROM requested + WHERE checkpoint.subscription_name = requested.subscription_name + RETURNING checkpoint.subscription_name, checkpoint.consumer_group_member + ) + SELECT requested.subscription_name, updated.consumer_group_member + FROM requested + LEFT JOIN updated USING (subscription_name) + ORDER BY requested.subscription_name, updated.consumer_group_member + """ + ( contrazip2 + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) + (E.param (E.nonNullable E.int8)) + ) + ( D.rowVector $ + (,) + <$> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.int4) + ) -- | A separate key domain from the optional member guard. lockCheckpointNameStmt :: Statement Text () lockCheckpointNameStmt = - preparable - "SELECT pg_advisory_xact_lock(hashtextextended('kiroku:checkpoint-topology:' || $1, 0))" - (E.param (E.nonNullable E.text)) - D.noResult + preparable + "SELECT pg_advisory_xact_lock(hashtextextended('kiroku:checkpoint-topology:' || $1, 0))" + (E.param (E.nonNullable E.text)) + D.noResult readCheckpointRowsStmt :: Statement Text (Vector (Int32, Int32, Int64, Maybe SubscriptionTarget)) readCheckpointRowsStmt = checkpointRowsStmt "" @@ -243,52 +253,53 @@ checkpointRowsStmt :: Text -> Statement Text (Vector (Int32, Int32, Int64, Maybe SubscriptionTarget)) checkpointRowsStmt suffix = - preparable - ("SELECT consumer_group_member, consumer_group_size, last_seen, target_kind, target_category FROM subscriptions WHERE subscription_name = $1 ORDER BY consumer_group_member" <> suffix) - (E.param (E.nonNullable E.text)) - (D.rowVector ((,,,) <$> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.int8) <*> targetBindingRow)) + preparable + ("SELECT consumer_group_member, consumer_group_size, last_seen, target_kind, target_category FROM subscriptions WHERE subscription_name = $1 ORDER BY consumer_group_member" <> suffix) + (E.param (E.nonNullable E.text)) + (D.rowVector ((,,,) <$> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.int8) <*> targetBindingRow)) -{- | Keep existing row identities, equalize every new member, remove obsolete -members. Caller already holds the name and row locks; workers must be stopped. --} +-- | Keep existing row identities, equalize every new member, remove obsolete +-- members. Caller already holds the name and row locks; workers must be stopped. resizeCheckpointMembersStmt :: Statement (Text, Int32, Int64, Text, Maybe Text) () resizeCheckpointMembersStmt = - preparable - """ - WITH removed AS ( - DELETE FROM subscriptions - WHERE subscription_name = $1 AND consumer_group_member >= $2 - ) - INSERT INTO subscriptions - (subscription_name, consumer_group_member, consumer_group_size, last_seen, updated_at, target_kind, target_category) - SELECT $1, member, $2, $3, now(), $4, $5 FROM generate_series(0, $2 - 1) AS member - ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE - SET consumer_group_size = EXCLUDED.consumer_group_size, - last_seen = EXCLUDED.last_seen, updated_at = now() - """ - ( contrazip5 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.int4)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.text)) - ) - D.noResult + preparable + """ + WITH removed AS ( + DELETE FROM subscriptions + WHERE subscription_name = $1 AND consumer_group_member >= $2 + ) + INSERT INTO subscriptions + (subscription_name, consumer_group_member, consumer_group_size, last_seen, updated_at, target_kind, target_category) + SELECT $1, member, $2, $3, now(), $4, $5 FROM generate_series(0, $2 - 1) AS member + ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE + SET consumer_group_size = EXCLUDED.consumer_group_size, + last_seen = EXCLUDED.last_seen, updated_at = now() + """ + ( contrazip5 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.int4)) + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.text)) + (E.param (E.nullable E.text)) + ) + D.noResult -{- | Select a fixed-kind statement once for the configured target. Both forms -write the full binding and retain the same unconditional monotonic upsert. --} +-- | Select a fixed-kind statement once for the configured target. Both forms +-- write the full binding and retain the same unconditional monotonic upsert. saveBoundCheckpointSession :: SubscriptionTarget -> Text -> Int32 -> Int64 -> Int32 -> Session.Session () saveBoundCheckpointSession AllStreams name member position groupSize = - Session.statement (name, member, position, groupSize) SQL.saveAllCheckpointMemberStmt + Session.statement (name, member, position, groupSize) SQL.saveAllCheckpointMemberStmt saveBoundCheckpointSession (Category (CategoryName category)) name member position groupSize = - Session.statement (name, member, position, groupSize, category) SQL.saveCategoryCheckpointMemberStmt + Session.statement (name, member, position, groupSize, category) SQL.saveCategoryCheckpointMemberStmt +saveBoundCheckpointSession (CategoryNamespace namespace) name member position groupSize = + Session.statement (name, member, position, groupSize, namespace) SQL.saveNamespaceCheckpointMemberStmt -- | One encoder for every checkpoint target write, including legacy provisioning. targetColumns :: Maybe SubscriptionTarget -> (Text, Maybe Text) targetColumns Nothing = ("unbound", Nothing) targetColumns (Just AllStreams) = ("all", Nothing) targetColumns (Just (Category (CategoryName category))) = ("category", Just category) +targetColumns (Just (CategoryNamespace namespace)) = ("category_namespace", Just namespace) -- The CHECK constraints make this decoder total over valid database rows. targetBindingRow :: D.Row (Maybe SubscriptionTarget) @@ -296,27 +307,28 @@ where decode "all" Nothing = Just AllStreams decode "category" (Just category) = Just (Category (CategoryName category)) + decode "category_namespace" (Just namespace) = Just (CategoryNamespace namespace) decode _ _ = Nothing adoptCheckpointTargetStmt :: Statement (Text, (Text, Maybe Text)) () adoptCheckpointTargetStmt = - preparable - "UPDATE subscriptions SET target_kind = $2, target_category = $3 WHERE subscription_name = $1" - (contrazip2 (E.param (E.nonNullable E.text)) (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nullable E.text)))) - D.noResult + preparable + "UPDATE subscriptions SET target_kind = $2, target_category = $3 WHERE subscription_name = $1" + (contrazip2 (E.param (E.nonNullable E.text)) (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nullable E.text)))) + D.noResult -- A singleRow decoder refuses an absent name and aborts the surrounding transaction. rebindCheckpointTargetStmt :: Statement (Text, Text, Maybe Text, Int64) Int64 rebindCheckpointTargetStmt = - preparable - """ - WITH rebound AS ( - UPDATE subscriptions - SET target_kind = $2, target_category = $3, last_seen = $4, updated_at = now() - WHERE subscription_name = $1 - RETURNING subscription_id - ) - SELECT count(*) FROM rebound HAVING count(*) > 0 - """ - (contrazip4 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.text)) (E.param (E.nullable E.text)) (E.param (E.nonNullable E.int8))) - (D.singleRow (D.column (D.nonNullable D.int8))) + preparable + """ + WITH rebound AS ( + UPDATE subscriptions + SET target_kind = $2, target_category = $3, last_seen = $4, updated_at = now() + WHERE subscription_name = $1 + RETURNING subscription_id + ) + SELECT count(*) FROM rebound HAVING count(*) > 0 + """ + (contrazip4 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.text)) (E.param (E.nullable E.text)) (E.param (E.nonNullable E.int8))) + (D.singleRow (D.column (D.nonNullable D.int8))) diff --git a/src/Kiroku/Store/Subscription/CheckpointInventory/SQL.hs b/src/Kiroku/Store/Subscription/CheckpointInventory/SQL.hs --- a/src/Kiroku/Store/Subscription/CheckpointInventory/SQL.hs +++ b/src/Kiroku/Store/Subscription/CheckpointInventory/SQL.hs @@ -1,8 +1,9 @@ {-# LANGUAGE MultilineStrings #-} -module Kiroku.Store.Subscription.CheckpointInventory.SQL ( - getSubscriptionCheckpointInventoryStmt, -) where +module Kiroku.Store.Subscription.CheckpointInventory.SQL + ( getSubscriptionCheckpointInventoryStmt, + ) +where import Data.Int (Int32, Int64) import Data.Text (Text) @@ -13,102 +14,102 @@ import Hasql.Encoders qualified as E import Hasql.Statement (Statement, preparable) import Hasql.Statement qualified as Statement -import Kiroku.Store.Subscription.Types ( - SubscriptionCheckpoint (..), +import Kiroku.Store.Subscription.Types + ( SubscriptionCheckpoint (..), SubscriptionCheckpointInventory (..), SubscriptionName (..), - ) + ) import Kiroku.Store.Types (GlobalPosition (..)) data InventoryRow = InventoryRow - { rowStorePosition :: !Int64 - , rowSubscriptionName :: !(Maybe Text) - , rowConsumerGroupMember :: !(Maybe Int32) - , rowCheckpointPosition :: !(Maybe Int64) - , rowCheckpointUpdatedAt :: !(Maybe UTCTime) - } + { rowStorePosition :: !Int64, + rowSubscriptionName :: !(Maybe Text), + rowConsumerGroupMember :: !(Maybe Int32), + rowCheckpointPosition :: !(Maybe Int64), + rowCheckpointUpdatedAt :: !(Maybe UTCTime) + } getSubscriptionCheckpointInventoryStmt :: Statement () SubscriptionCheckpointInventory getSubscriptionCheckpointInventoryStmt = - Statement.refineResult finalizeInventory $ - preparable - """ - SELECT store_head.stream_version, - checkpoint.subscription_name, - checkpoint.consumer_group_member, - checkpoint.last_seen, - checkpoint.updated_at - FROM streams AS store_head - LEFT JOIN subscriptions AS checkpoint ON TRUE - WHERE store_head.stream_id = 0 - ORDER BY checkpoint.subscription_name ASC, - checkpoint.consumer_group_member ASC - """ - E.noParams - (D.rowVector inventoryRow) + Statement.refineResult finalizeInventory $ + preparable + """ + SELECT store_head.stream_version, + checkpoint.subscription_name, + checkpoint.consumer_group_member, + checkpoint.last_seen, + checkpoint.updated_at + FROM streams AS store_head + LEFT JOIN subscriptions AS checkpoint ON TRUE + WHERE store_head.stream_id = 0 + ORDER BY checkpoint.subscription_name ASC, + checkpoint.consumer_group_member ASC + """ + E.noParams + (D.rowVector inventoryRow) inventoryRow :: D.Row InventoryRow inventoryRow = - InventoryRow - <$> D.column (D.nonNullable D.int8) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.int4) - <*> D.column (D.nullable D.int8) - <*> D.column (D.nullable D.timestamptz) + InventoryRow + <$> D.column (D.nonNullable D.int8) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.int4) + <*> D.column (D.nullable D.int8) + <*> D.column (D.nullable D.timestamptz) finalizeInventory :: Vector InventoryRow -> Either Text SubscriptionCheckpointInventory finalizeInventory rows = case V.uncons rows of - Nothing -> Left "subscription checkpoint inventory: missing $all stream row" - Just (firstRow, remainingRows) -> - let capturedPosition = rowStorePosition firstRow - in case checkpointColumns firstRow of - EmptyCheckpoint - | V.null remainingRows -> - Right $ - SubscriptionCheckpointInventory - (GlobalPosition capturedPosition) - V.empty - | otherwise -> - Left "subscription checkpoint inventory: empty checkpoint row was not the only result" - PartialCheckpoint -> - Left "subscription checkpoint inventory: partially null checkpoint row" - CompleteCheckpoint -> - SubscriptionCheckpointInventory (GlobalPosition capturedPosition) - <$> V.mapM (decodeCheckpoint capturedPosition) rows + Nothing -> Left "subscription checkpoint inventory: missing $all stream row" + Just (firstRow, remainingRows) -> + let capturedPosition = rowStorePosition firstRow + in case checkpointColumns firstRow of + EmptyCheckpoint + | V.null remainingRows -> + Right $ + SubscriptionCheckpointInventory + (GlobalPosition capturedPosition) + V.empty + | otherwise -> + Left "subscription checkpoint inventory: empty checkpoint row was not the only result" + PartialCheckpoint -> + Left "subscription checkpoint inventory: partially null checkpoint row" + CompleteCheckpoint -> + SubscriptionCheckpointInventory (GlobalPosition capturedPosition) + <$> V.mapM (decodeCheckpoint capturedPosition) rows data CheckpointColumns - = EmptyCheckpoint - | PartialCheckpoint - | CompleteCheckpoint + = EmptyCheckpoint + | PartialCheckpoint + | CompleteCheckpoint checkpointColumns :: InventoryRow -> CheckpointColumns checkpointColumns row = - case ( rowSubscriptionName row - , rowConsumerGroupMember row - , rowCheckpointPosition row - , rowCheckpointUpdatedAt row - ) of - (Nothing, Nothing, Nothing, Nothing) -> EmptyCheckpoint - (Just _, Just _, Just _, Just _) -> CompleteCheckpoint - _ -> PartialCheckpoint + case ( rowSubscriptionName row, + rowConsumerGroupMember row, + rowCheckpointPosition row, + rowCheckpointUpdatedAt row + ) of + (Nothing, Nothing, Nothing, Nothing) -> EmptyCheckpoint + (Just _, Just _, Just _, Just _) -> CompleteCheckpoint + _ -> PartialCheckpoint decodeCheckpoint :: Int64 -> InventoryRow -> Either Text SubscriptionCheckpoint decodeCheckpoint capturedPosition row - | rowStorePosition row /= capturedPosition = - Left "subscription checkpoint inventory: inconsistent repeated store position" - | otherwise = - case ( rowSubscriptionName row - , rowConsumerGroupMember row - , rowCheckpointPosition row - , rowCheckpointUpdatedAt row - ) of - (Just name, Just member, Just position, Just updatedAt) -> - Right $ - SubscriptionCheckpoint - (SubscriptionName name) - member - (GlobalPosition position) - updatedAt - (Nothing, Nothing, Nothing, Nothing) -> - Left "subscription checkpoint inventory: unexpected empty checkpoint row" - _ -> Left "subscription checkpoint inventory: partially null checkpoint row" + | rowStorePosition row /= capturedPosition = + Left "subscription checkpoint inventory: inconsistent repeated store position" + | otherwise = + case ( rowSubscriptionName row, + rowConsumerGroupMember row, + rowCheckpointPosition row, + rowCheckpointUpdatedAt row + ) of + (Just name, Just member, Just position, Just updatedAt) -> + Right $ + SubscriptionCheckpoint + (SubscriptionName name) + member + (GlobalPosition position) + updatedAt + (Nothing, Nothing, Nothing, Nothing) -> + Left "subscription checkpoint inventory: unexpected empty checkpoint row" + _ -> Left "subscription checkpoint inventory: partially null checkpoint row" diff --git a/src/Kiroku/Store/Subscription/DeadLetter/SQL.hs b/src/Kiroku/Store/Subscription/DeadLetter/SQL.hs --- a/src/Kiroku/Store/Subscription/DeadLetter/SQL.hs +++ b/src/Kiroku/Store/Subscription/DeadLetter/SQL.hs @@ -1,12 +1,13 @@ {-# LANGUAGE MultilineStrings #-} -module Kiroku.Store.Subscription.DeadLetter.SQL ( - listSubscriptionDeadLettersSession, +module Kiroku.Store.Subscription.DeadLetter.SQL + ( listSubscriptionDeadLettersSession, listSubscriptionDeadLettersStmt, listSubscriptionDeadLettersFromStartStmt, listSubscriptionMemberDeadLettersStmt, listSubscriptionMemberDeadLettersFromStartStmt, -) where + ) +where import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5) import Control.Lens ((^.)) @@ -25,118 +26,120 @@ listSubscriptionDeadLettersFromStartStmt :: Statement (Text, Int32) (Vector SubscriptionDeadLetter) listSubscriptionDeadLettersFromStartStmt = - preparable - """ - WITH RECURSIVE members(member) AS ( - SELECT (SELECT consumer_group_member FROM dead_letters - WHERE subscription_name = $1 ORDER BY consumer_group_member LIMIT 1) - UNION ALL - SELECT (SELECT consumer_group_member FROM dead_letters - WHERE subscription_name = $1 AND consumer_group_member > m.member - ORDER BY consumer_group_member LIMIT 1) - FROM members m WHERE m.member IS NOT NULL - ) - SELECT d.dead_letter_id, d.subscription_name, d.consumer_group_member, d.global_position, d.event_id, d.reason, d.reason_summary, d.attempt_count, d.created_at - FROM members m - CROSS JOIN LATERAL ( - SELECT dead_letter_id, subscription_name, consumer_group_member, global_position, event_id, reason, reason_summary, attempt_count, created_at - FROM dead_letters - WHERE subscription_name = $1 AND consumer_group_member = m.member + preparable + """ + WITH RECURSIVE members(member) AS ( + SELECT (SELECT consumer_group_member FROM dead_letters + WHERE subscription_name = $1 ORDER BY consumer_group_member LIMIT 1) + UNION ALL + SELECT (SELECT consumer_group_member FROM dead_letters + WHERE subscription_name = $1 AND consumer_group_member > m.member + ORDER BY consumer_group_member LIMIT 1) + FROM members m WHERE m.member IS NOT NULL + ) + SELECT d.dead_letter_id, d.subscription_name, d.consumer_group_member, d.global_position, d.event_id, d.reason, d.reason_summary, d.attempt_count, d.created_at + FROM members m + CROSS JOIN LATERAL ( + SELECT dead_letter_id, subscription_name, consumer_group_member, global_position, event_id, reason, reason_summary, attempt_count, created_at + FROM dead_letters + WHERE subscription_name = $1 AND consumer_group_member = m.member - ORDER BY global_position DESC, dead_letter_id DESC LIMIT $2 - ) d - WHERE m.member IS NOT NULL - ORDER BY d.global_position DESC, d.dead_letter_id DESC LIMIT $2 - """ - (contrazip2 text int4) - (D.rowVector deadLetterRow) + ORDER BY global_position DESC, dead_letter_id DESC LIMIT $2 + ) d + WHERE m.member IS NOT NULL + ORDER BY d.global_position DESC, d.dead_letter_id DESC LIMIT $2 + """ + (contrazip2 text int4) + (D.rowVector deadLetterRow) listSubscriptionDeadLettersStmt :: Statement (Text, Int64, Int64, Int32) (Vector SubscriptionDeadLetter) listSubscriptionDeadLettersStmt = - preparable - """ - WITH RECURSIVE members(member) AS ( - SELECT (SELECT consumer_group_member FROM dead_letters - WHERE subscription_name = $1 ORDER BY consumer_group_member LIMIT 1) - UNION ALL - SELECT (SELECT consumer_group_member FROM dead_letters - WHERE subscription_name = $1 AND consumer_group_member > m.member - ORDER BY consumer_group_member LIMIT 1) - FROM members m WHERE m.member IS NOT NULL - ) - SELECT d.dead_letter_id, d.subscription_name, d.consumer_group_member, d.global_position, d.event_id, d.reason, d.reason_summary, d.attempt_count, d.created_at - FROM members m - CROSS JOIN LATERAL ( - SELECT dead_letter_id, subscription_name, consumer_group_member, global_position, event_id, reason, reason_summary, attempt_count, created_at - FROM dead_letters - WHERE subscription_name = $1 AND consumer_group_member = m.member - AND (global_position, dead_letter_id) < ($2, $3) - ORDER BY global_position DESC, dead_letter_id DESC LIMIT $4 - ) d - WHERE m.member IS NOT NULL - ORDER BY d.global_position DESC, d.dead_letter_id DESC LIMIT $4 - """ - (contrazip4 text int8 int8 int4) - (D.rowVector deadLetterRow) + preparable + """ + WITH RECURSIVE members(member) AS ( + SELECT (SELECT consumer_group_member FROM dead_letters + WHERE subscription_name = $1 ORDER BY consumer_group_member LIMIT 1) + UNION ALL + SELECT (SELECT consumer_group_member FROM dead_letters + WHERE subscription_name = $1 AND consumer_group_member > m.member + ORDER BY consumer_group_member LIMIT 1) + FROM members m WHERE m.member IS NOT NULL + ) + SELECT d.dead_letter_id, d.subscription_name, d.consumer_group_member, d.global_position, d.event_id, d.reason, d.reason_summary, d.attempt_count, d.created_at + FROM members m + CROSS JOIN LATERAL ( + SELECT dead_letter_id, subscription_name, consumer_group_member, global_position, event_id, reason, reason_summary, attempt_count, created_at + FROM dead_letters + WHERE subscription_name = $1 AND consumer_group_member = m.member + AND (global_position, dead_letter_id) < ($2, $3) + ORDER BY global_position DESC, dead_letter_id DESC LIMIT $4 + ) d + WHERE m.member IS NOT NULL + ORDER BY d.global_position DESC, d.dead_letter_id DESC LIMIT $4 + """ + (contrazip4 text int8 int8 int4) + (D.rowVector deadLetterRow) listSubscriptionMemberDeadLettersFromStartStmt :: Statement (Text, Int32, Int32) (Vector SubscriptionDeadLetter) listSubscriptionMemberDeadLettersFromStartStmt = - preparable - """ - SELECT dead_letter_id, subscription_name, consumer_group_member, global_position, event_id, reason, reason_summary, attempt_count, created_at - FROM dead_letters - WHERE subscription_name = $1 AND consumer_group_member = $2 + preparable + """ + SELECT dead_letter_id, subscription_name, consumer_group_member, 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 LIMIT $3 - """ - (contrazip3 text int4 int4) - (D.rowVector deadLetterRow) + ORDER BY global_position DESC, dead_letter_id DESC LIMIT $3 + """ + (contrazip3 text int4 int4) + (D.rowVector deadLetterRow) listSubscriptionMemberDeadLettersStmt :: Statement (Text, Int32, Int64, Int64, Int32) (Vector SubscriptionDeadLetter) listSubscriptionMemberDeadLettersStmt = - preparable - """ - SELECT dead_letter_id, subscription_name, consumer_group_member, global_position, event_id, reason, reason_summary, attempt_count, created_at - FROM dead_letters - WHERE subscription_name = $1 AND consumer_group_member = $2 - AND (global_position, dead_letter_id) < ($3, $4) - ORDER BY global_position DESC, dead_letter_id DESC LIMIT $5 - """ - (contrazip5 text int4 int8 int8 int4) - (D.rowVector deadLetterRow) + preparable + """ + SELECT dead_letter_id, subscription_name, consumer_group_member, global_position, event_id, reason, reason_summary, attempt_count, created_at + FROM dead_letters + WHERE subscription_name = $1 AND consumer_group_member = $2 + AND (global_position, dead_letter_id) < ($3, $4) + ORDER BY global_position DESC, dead_letter_id DESC LIMIT $5 + """ + (contrazip5 text int4 int8 int8 int4) + (D.rowVector deadLetterRow) text :: E.Params Text text = E.param (E.nonNullable E.text) + int4 :: E.Params Int32 int4 = E.param (E.nonNullable E.int4) + int8 :: E.Params Int64 int8 = E.param (E.nonNullable E.int8) deadLetterRow :: D.Row SubscriptionDeadLetter deadLetterRow = - SubscriptionDeadLetter - <$> D.column (D.nonNullable D.int8) - <*> (SubscriptionName <$> D.column (D.nonNullable D.text)) - <*> D.column (D.nonNullable D.int4) - <*> (GlobalPosition <$> D.column (D.nonNullable D.int8)) - <*> (EventId <$> 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) + SubscriptionDeadLetter + <$> D.column (D.nonNullable D.int8) + <*> (SubscriptionName <$> D.column (D.nonNullable D.text)) + <*> D.column (D.nonNullable D.int4) + <*> (GlobalPosition <$> D.column (D.nonNullable D.int8)) + <*> (EventId <$> 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) listSubscriptionDeadLettersSession :: SubscriptionDeadLetterQuery -> Session SubscriptionDeadLetterPage listSubscriptionDeadLettersSession query = do - let SubscriptionName name = query ^. #subscriptionName - pageSize = subscriptionDeadLetterLimitValue (query ^. #limit) - fetch = pageSize + 1 - rows <- case (query ^. #consumerGroupMember, query ^. #after) of - (Nothing, Nothing) -> Session.statement (name, fetch) listSubscriptionDeadLettersFromStartStmt - (Just selectedMember, Nothing) -> Session.statement (name, selectedMember, fetch) listSubscriptionMemberDeadLettersFromStartStmt - (Nothing, Just (SubscriptionDeadLetterCursor (GlobalPosition position) ident)) -> - Session.statement (name, position, ident, fetch) listSubscriptionDeadLettersStmt - (Just selectedMember, Just (SubscriptionDeadLetterCursor (GlobalPosition position) ident)) -> - Session.statement (name, selectedMember, position, ident, fetch) listSubscriptionMemberDeadLettersStmt - let page = V.take (fromIntegral pageSize) rows - cursor = if V.length rows > fromIntegral pageSize then Just (subscriptionDeadLetterCursor (V.last page)) else Nothing - pure (SubscriptionDeadLetterPage page cursor) + let SubscriptionName name = query ^. #subscriptionName + pageSize = subscriptionDeadLetterLimitValue (query ^. #limit) + fetch = pageSize + 1 + rows <- case (query ^. #consumerGroupMember, query ^. #after) of + (Nothing, Nothing) -> Session.statement (name, fetch) listSubscriptionDeadLettersFromStartStmt + (Just selectedMember, Nothing) -> Session.statement (name, selectedMember, fetch) listSubscriptionMemberDeadLettersFromStartStmt + (Nothing, Just (SubscriptionDeadLetterCursor (GlobalPosition position) ident)) -> + Session.statement (name, position, ident, fetch) listSubscriptionDeadLettersStmt + (Just selectedMember, Just (SubscriptionDeadLetterCursor (GlobalPosition position) ident)) -> + Session.statement (name, selectedMember, position, ident, fetch) listSubscriptionMemberDeadLettersStmt + let page = V.take (fromIntegral pageSize) rows + cursor = if V.length rows > fromIntegral pageSize then Just (subscriptionDeadLetterCursor (V.last page)) else Nothing + pure (SubscriptionDeadLetterPage page cursor) diff --git a/src/Kiroku/Store/Subscription/Effect.hs b/src/Kiroku/Store/Subscription/Effect.hs --- a/src/Kiroku/Store/Subscription/Effect.hs +++ b/src/Kiroku/Store/Subscription/Effect.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies #-} -module Kiroku.Store.Subscription.Effect ( - -- * The Subscription effect +module Kiroku.Store.Subscription.Effect + ( -- * The Subscription effect Subscription (..), -- * Convenience wrappers @@ -11,7 +11,8 @@ -- * Interpreters runSubscription, runSubscriptionResource, -) where + ) +where import Control.Monad.IO.Class (liftIO) import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..), (:>)) @@ -26,13 +27,12 @@ -- 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. --} +-- | 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 + Subscribe :: SubscriptionConfigM m -> Subscription m SubscriptionHandle type instance DispatchOf Subscription = Dynamic @@ -40,103 +40,100 @@ -- 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 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. --} +-- | 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 + (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. --} +-- | 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 + (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: policy fields are preserved; both callbacks are unlifted, - -- 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) - , undecodableHandler = fmap (\callback event failure -> unlift (callback event failure)) (undecodableHandler config) - } - Sub.subscribe store ioConfig + Subscribe config -> + localUnliftIO env (ConcUnlift Persistent (Limited 1)) $ \unlift -> do + -- Record update intentionally: policy fields are preserved; both callbacks are unlifted, + -- 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), + undecodableHandler = fmap (\callback event failure -> unlift (callback event failure)) (undecodableHandler config) + } + 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 + (IOE :> es, KirokuStoreResource :> es) => + Eff (Subscription : es) a -> + Eff es a runSubscriptionResource action = do - store <- getKirokuStore - runSubscription store action + store <- getKirokuStore + runSubscription store action diff --git a/src/Kiroku/Store/Subscription/EventPublisher.hs b/src/Kiroku/Store/Subscription/EventPublisher.hs --- a/src/Kiroku/Store/Subscription/EventPublisher.hs +++ b/src/Kiroku/Store/Subscription/EventPublisher.hs @@ -1,24 +1,23 @@ -{- | The centralized @$all@ broadcaster shared by queue-consuming live clients. - -A single 'EventPublisher' reads new events from the global stream once when at -least one 'Subscriber' is registered and fans them out through each -subscriber's bounded 'Control.Concurrent.STM.TBQueue'. When the registry is -empty, it does not fetch full event rows; it advances 'lastPublished' from the -@$all@ tail with a single-row query so DB-driven subscriptions can still use the -position as their live gate. 'startPublisher' launches the loop, -'subscribePublisher' registers a subscriber (returning its queue, a status -'TVar', and an unsubscribe action), 'publisherPosition' reports the last -published 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 and counts the drop in 'subDropped'. The publisher itself never blocks on a slow consumer. --} -module Kiroku.Store.Subscription.EventPublisher ( - EventPublisher (..), +-- | The centralized @$all@ broadcaster shared by queue-consuming live clients. +-- +-- A single 'EventPublisher' reads new events from the global stream once when at +-- least one 'Subscriber' is registered and fans them out through each +-- subscriber's bounded 'Control.Concurrent.STM.TBQueue'. When the registry is +-- empty, it does not fetch full event rows; it advances 'lastPublished' from the +-- @$all@ tail with a single-row query so DB-driven subscriptions can still use the +-- position as their live gate. 'startPublisher' launches the loop, +-- 'subscribePublisher' registers a subscriber (returning its queue, a status +-- 'TVar', and an unsubscribe action), 'publisherPosition' reports the last +-- published 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 and counts the drop in 'subDropped'. The publisher itself never blocks on a slow consumer. +module Kiroku.Store.Subscription.EventPublisher + ( EventPublisher (..), Subscriber (..), SubscriberStatus (..), startPublisher, @@ -27,12 +26,13 @@ PublisherSubscription (..), subscribePublisherWith, publisherPosition, -) where + ) +where import Control.Concurrent.Async (Async) import Control.Concurrent.Async qualified as Async -import Control.Concurrent.STM ( - STM, +import Control.Concurrent.STM + ( STM, TBQueue, TChan, TVar, @@ -51,7 +51,7 @@ tryReadTChan, writeTBQueue, writeTVar, - ) + ) import Control.Concurrent.STM qualified as STM import Control.Exception (SomeAsyncException, SomeException, asyncExceptionFromException, catch, throwIO) import Control.Monad (when) @@ -72,62 +72,57 @@ import Kiroku.Store.Types (GlobalPosition (..), RecordedEvent (..)) import Numeric.Natural (Natural) -{- | The centralized EventPublisher. With registered subscribers, reads events -from the database once per notification and fans them out to a registry of -bounded per-subscriber queues. With an empty registry, fetches only the current -@$all@ tail to keep 'lastPublished' moving without decoding event rows. --} +-- | The centralized EventPublisher. With registered subscribers, reads events +-- from the database once per notification and fans them out to a registry of +-- bounded per-subscriber queues. With an empty registry, fetches only the current +-- @$all@ tail to keep 'lastPublished' moving without decoding event rows. 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 - } + { -- | Active subscriber registry, keyed by an internal id. + subscribers :: !(TVar (IntMap Subscriber)), + nextSubscriberId :: !(TVar Int), + publisherThread :: !(Async ()), + -- | Last-published position; workers read this to know when catch-up is done + lastPublished :: !(TVar GlobalPosition) + } -{- | 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'. --} +-- | 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 DecodedBatch) - , subStatus :: !(TVar SubscriberStatus) - , subPolicy :: !OverflowPolicy - , subDropped :: !(TVar Word64) - -- ^ Dropped batches under DropOldest; compare successive readings (modulo Word64). - } + { subQueue :: !(TBQueue DecodedBatch), + subStatus :: !(TVar SubscriberStatus), + subPolicy :: !OverflowPolicy, + -- | Dropped batches under DropOldest; compare successive readings (modulo Word64). + subDropped :: !(TVar Word64) + } -- | A bounded publisher subscription with its exact dropped-batch counter. data PublisherSubscription = PublisherSubscription - { subscriptionQueue :: !(TBQueue DecodedBatch) - , subscriptionStatus :: !(TVar SubscriberStatus) - , subscriptionDropped :: !(TVar Word64) - , unsubscribe :: !(IO ()) - -- ^ Idempotent deregistration; invoke on every exit. - } + { subscriptionQueue :: !(TBQueue DecodedBatch), + subscriptionStatus :: !(TVar SubscriberStatus), + subscriptionDropped :: !(TVar Word64), + -- | Idempotent deregistration; invoke on every exit. + unsubscribe :: !(IO ()) + } -- | 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) + = -- | 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. --} +-- | Publisher batch size — larger than subscriber batch size because the +-- Publisher serves all subscribers. publisherBatchSize :: Int32 publisherBatchSize = 1000 @@ -135,86 +130,83 @@ 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). With at least one registered -subscriber, the thread queries full event rows and delivers them to every active -subscriber; with an empty registry, it advances 'lastPublished' from the @$all@ -tail using a single-row query and fetches no payload rows. 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. --} +-- | Start the EventPublisher. Spawns a thread that waits for ticks from the +-- Notifier (or a 30-second safety poll timeout). With at least one registered +-- subscriber, the thread queries full event rows and delivers them to every active +-- subscriber; with an empty registry, it advances 'lastPublished' from the @$all@ +-- tail using a single-row query and fetches no payload rows. 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 + (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 - -- Duplicate the notifier channel before reading the tail so ticks arriving - -- during startup are redundant rather than lost until the safety poll. - tickChan <- atomically (dupTChan notifierChan) - tailResult <- Pool.use pool (Session.statement () SQL.currentGlobalPositionStmt) - tailPos <- either throwIO pure tailResult - pos <- newTVarIO (GlobalPosition tailPos) - thread <- Async.async (publisherLoop pool tickChan subsVar pos mHandler stSettings) - pure - EventPublisher - { subscribers = subsVar - , nextSubscriberId = nextIdVar - , publisherThread = thread - , lastPublished = pos - } + subsVar <- newTVarIO IntMap.empty + nextIdVar <- newTVarIO 0 + -- Duplicate the notifier channel before reading the tail so ticks arriving + -- during startup are redundant rather than lost until the safety poll. + tickChan <- atomically (dupTChan notifierChan) + tailResult <- Pool.use pool (Session.statement () SQL.currentGlobalPositionStmt) + tailPos <- either throwIO pure tailResult + pos <- newTVarIO (GlobalPosition tailPos) + 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) + 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. --} +-- | 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 DecodedBatch, TVar SubscriberStatus, IO ()) + EventPublisher -> + -- | Queue capacity (number of batches) + Natural -> + OverflowPolicy -> + STM (TBQueue DecodedBatch, TVar SubscriberStatus, IO ()) subscribePublisher pub cap policy = do - sub <- subscribePublisherWith pub cap policy - pure (subscriptionQueue sub, subscriptionStatus sub, unsubscribe sub) + sub <- subscribePublisherWith pub cap policy + pure (subscriptionQueue sub, subscriptionStatus sub, unsubscribe sub) -- | Register a subscriber, also exposing the DropOldest counter (initially zero). subscribePublisherWith :: EventPublisher -> Natural -> OverflowPolicy -> STM PublisherSubscription subscribePublisherWith pub cap policy = do - queue <- newTBQueue cap - status <- newTVar Active - dropped <- newTVar 0 - sid <- readTVar (nextSubscriberId pub) - writeTVar (nextSubscriberId pub) (sid + 1) - let sub = Subscriber{subQueue = queue, subStatus = status, subPolicy = policy, subDropped = dropped} - modifyTVar' (subscribers pub) (IntMap.insert sid sub) - let deregister = - atomically $ - modifyTVar' (subscribers pub) (IntMap.delete sid) - pure (PublisherSubscription queue status dropped deregister) + queue <- newTBQueue cap + status <- newTVar Active + dropped <- newTVar 0 + sid <- readTVar (nextSubscriberId pub) + writeTVar (nextSubscriberId pub) (sid + 1) + let sub = Subscriber {subQueue = queue, subStatus = status, subPolicy = policy, subDropped = dropped} + modifyTVar' (subscribers pub) (IntMap.insert sid sub) + let deregister = + atomically $ + modifyTVar' (subscribers pub) (IntMap.delete sid) + pure (PublisherSubscription queue status dropped deregister) -- | Read the last-published global position. publisherPosition :: EventPublisher -> STM GlobalPosition @@ -222,144 +214,144 @@ -- Internal: the publisher loop. publisherLoop :: - Pool -> - TChan () -> - TVar (IntMap Subscriber) -> - TVar GlobalPosition -> - Maybe (KirokuEvent -> IO ()) -> - StoreSettings -> - IO () + 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. If a synchronous callback failure occurs after - -- partial delivery, lastPublished is not advanced, so the next tick - -- re-fetches under Kiroku's at-least-once delivery contract. - fetchAndBroadcast `catch` \(e :: SomeException) -> - case asyncExceptionFromException e of - Just (ae :: SomeAsyncException) -> throwIO ae - Nothing -> emitOrDrop mHandler (KirokuEventPublisherLoopError e) - loop + -- Wait for a tick OR safety poll timeout + waitForWakeup tickChan + -- Drain all pending ticks (debouncing) + drainTicks tickChan + -- Fetch and broadcast. If a synchronous callback failure occurs after + -- partial delivery, lastPublished is not advanced, so the next tick + -- re-fetches under Kiroku's at-least-once delivery contract. + fetchAndBroadcast `catch` \(e :: SomeException) -> + case asyncExceptionFromException e of + Just (ae :: SomeAsyncException) -> throwIO ae + Nothing -> emitOrDrop mHandler (KirokuEventPublisherLoopError e) + loop fetchAndBroadcast = do - subs <- readTVarIO subsVar - if IntMap.null subs - then cheapAdvance - else fullFetch + subs <- readTVarIO subsVar + if IntMap.null subs + then cheapAdvance + else fullFetch cheapAdvance = do - result <- Pool.use pool (Session.statement () SQL.currentGlobalPositionStmt) - case result of - Left err -> do - -- Surface the pool error so operators see why the publisher - -- position has stalled; the 30-second safety poll will retry. - emitOrDrop mHandler (KirokuEventPublisherPoolError err) - Right tailPos -> do - -- Re-check registry emptiness in the same STM transaction as - -- the position write. If a queue subscriber registered after - -- our snapshot, fall through to a full fetch so no event skips - -- a queue that now exists. - raced <- atomically $ do - subs' <- readTVar subsVar - if IntMap.null subs' - then do - GlobalPosition cur <- readTVar posVar - let nextPos = max cur tailPos - -- Do not store a chain of lazy max expressions that - -- retains earlier tail-query results. - nextPos `seq` writeTVar posVar (GlobalPosition nextPos) - pure False - else pure True - when raced fullFetch + result <- Pool.use pool (Session.statement () SQL.currentGlobalPositionStmt) + case result of + Left err -> do + -- Surface the pool error so operators see why the publisher + -- position has stalled; the 30-second safety poll will retry. + emitOrDrop mHandler (KirokuEventPublisherPoolError err) + Right tailPos -> do + -- Re-check registry emptiness in the same STM transaction as + -- the position write. If a queue subscriber registered after + -- our snapshot, fall through to a full fetch so no event skips + -- a queue that now exists. + raced <- atomically $ do + subs' <- readTVar subsVar + if IntMap.null subs' + then do + GlobalPosition cur <- readTVar posVar + let nextPos = max cur tailPos + -- Do not store a chain of lazy max expressions that + -- retains earlier tail-query results. + nextPos `seq` writeTVar posVar (GlobalPosition nextPos) + pure False + else pure True + when raced fullFetch fullFetch = 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. - emitOrDrop 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 - case events of - UnchangedBatch _ -> pure () - TransformedBatch decoded -> for_ decoded $ \case - Decoded _ -> pure () - Undecodable event failure -> emitOrDrop mHandler (KirokuEventPublisherDecodeFailed (globalPosition event) (eventId event) failure) - let lastEvent = V.last rawEvents - 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 only after attempting delivery to the - -- snapshot cohort. In the same transaction, re-read the - -- registry and offer the in-flight batch to subscribers that - -- registered after the snapshot. This closes the attach race: - -- every subscriber either received the batch before the - -- advance or registered after the advanced position was - -- visible and will cover the range through SQL catch-up. - atomically $ do - subs' <- readTVar subsVar - for_ (IntMap.elems (subs' `IntMap.difference` subs)) (deliverBatchSTM events) - writeTVar posVar newPos - -- If we got a full batch, there may be more — loop immediately - if V.length rawEvents >= fromIntegral publisherBatchSize - then fullFetch - else pure () + 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. + emitOrDrop 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 + case events of + UnchangedBatch _ -> pure () + TransformedBatch decoded -> for_ decoded $ \case + Decoded _ -> pure () + Undecodable event failure -> emitOrDrop mHandler (KirokuEventPublisherDecodeFailed (globalPosition event) (eventId event) failure) + let lastEvent = V.last rawEvents + 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 only after attempting delivery to the + -- snapshot cohort. In the same transaction, re-read the + -- registry and offer the in-flight batch to subscribers that + -- registered after the snapshot. This closes the attach race: + -- every subscriber either received the batch before the + -- advance or registered after the advanced position was + -- visible and will cover the range through SQL catch-up. + atomically $ do + subs' <- readTVar subsVar + for_ (IntMap.elems (subs' `IntMap.difference` subs)) (deliverBatchSTM events) + writeTVar posVar newPos + -- If we got a full batch, there may be more — loop immediately + if V.length rawEvents >= fromIntegral publisherBatchSize + then fullFetch + else pure () deliverBatch events sub = atomically $ do - deliverBatchSTM events sub + deliverBatchSTM events sub deliverBatchSTM events sub = 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) - modifyTVar' (subDropped sub) (+ 1) - writeTBQueue (subQueue sub) events + 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) + modifyTVar' (subDropped sub) (+ 1) + 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) + 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 + 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 --- a/src/Kiroku/Store/Subscription/Fsm.hs +++ b/src/Kiroku/Store/Subscription/Fsm.hs @@ -1,37 +1,36 @@ {-# 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 +-- | 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, @@ -53,7 +52,8 @@ -- * Transition function step, -) where + ) +where import Control.Exception (SomeException) import Data.Aeson (Value, object, (.=)) @@ -64,300 +64,294 @@ import Kiroku.Store.Settings (DecodeFailure (..), DecodedBatch, decodedBatchLastEvent, decodedBatchLength) import Kiroku.Store.Types (EventId (..), 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. --} +-- | 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 - | -- | Default undecodable-event retries exhausted; checkpoint remains before it. - StopUndecodable !DecodeFailure - deriving stock (Show) - -{- | How long to wait before redelivering a retried event. + = -- | 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 + | -- | Default undecodable-event retries exhausted; checkpoint remains before it. + StopUndecodable !DecodeFailure + deriving stock (Show) -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@. --} +-- | 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) + deriving stock (Eq, Show) -{- | The retry delay in microseconds, clamped at @0@, suitable for -'Control.Concurrent.threadDelay'. Fractional seconds are rounded. --} +-- | 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. --} +-- | 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 total deliveries. - DeadLetterMaxAttempts !Int - | -- | A custom reason: a summary plus structured JSON detail. - DeadLetterOther !Text !Value - | -- | A consumer explicitly chose to skip an undecodable event. - DeadLetterDecodeFailure !DecodeFailure - deriving stock (Eq, Show) + = -- | 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 total deliveries. + DeadLetterMaxAttempts !Int + | -- | A custom reason: a summary plus structured JSON detail. + DeadLetterOther !Text !Value + | -- | A consumer explicitly chose to skip an undecodable event. + DeadLetterDecodeFailure !DecodeFailure + 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 - DeadLetterDecodeFailure failure -> "decode failure: " <> decodeFailureReason failure + DeadLetterPoison detail -> "poison: " <> detail + DeadLetterInvalid detail -> "invalid payload: " <> detail + DeadLetterMaxAttempts n -> "max retry attempts exceeded (" <> T.pack (show n) <> ")" + DeadLetterOther summary _ -> summary + DeadLetterDecodeFailure failure -> "decode failure: " <> decodeFailureReason failure -- | 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] - DeadLetterDecodeFailure failure -> object ["kind" .= ("decode_failure" :: Text), "event_id" .= (case decodeFailureEventId failure of EventId eid -> show eid), "detail" .= decodeFailureReason failure] - -{- | What unblocks a 'Paused' worker. + 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] + DeadLetterDecodeFailure failure -> object ["kind" .= ("decode_failure" :: Text), "event_id" .= (case decodeFailureEventId failure of EventId eid -> show eid), "detail" .= decodeFailureReason failure] -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. --} +-- | 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. + = -- | Resume once the consumer drains its bounded queue. + ResumeOnDrain + deriving stock (Eq, Show) - * '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'. --} +-- | 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) + = 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. --} +-- | 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 + 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. --} +-- | 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. + CatchingUp {} -> "catching_up" + Live {} -> "live" + Paused {} -> "paused" + Reconnecting {} -> "reconnecting" + Retrying {} -> "retrying" + Stopped {} -> "stopped" -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@). --} +-- | 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 !DecodedBatch - | -- | 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 !GlobalPosition !Pool.UsageError - | -- | The caller cancelled the worker. - Cancelled - deriving stock (Show) - -{- | A side effect the driver must perform after a transition. + = -- | A non-empty history\/live batch arrived. + BatchFetched !DecodedBatch + | -- | A scanned namespace window; progress remains speculative until delivery. + NamespaceWindowFetched !DecodedBatch !GlobalPosition !Bool + | -- | Every applicable disposition in the window has completed. + NamespaceWindowCompleted !GlobalPosition !Bool + | -- | 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 !GlobalPosition !Pool.UsageError + | -- | The caller cancelled the worker. + Cancelled + deriving stock (Show) -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. --} +-- | 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 !DecodedBatch - | {- | 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) + = -- | 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 !DecodedBatch + | -- | Deliver before publishing the window frontier as completed state. + DeliverNamespaceWindow !DecodedBatch !GlobalPosition !Bool + | -- | 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 -> DecodedBatch -> GlobalPosition lastPos fallback evs - | decodedBatchLength evs == 0 = fallback - | otherwise = globalPosition (decodedBatchLastEvent evs) - -{- | The single transition function. Given the current state and an input, -return the next state and the effects to perform. + | decodedBatchLength evs == 0 = fallback + | otherwise = globalPosition (decodedBatchLastEvent evs) -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. --} +-- | 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 observed _ -> (Reconnecting (max c observed) 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 observed _ -> (Reconnecting (max c observed) 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 observed _ -> (Reconnecting (max c observed) (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, []) + CatchingUp c n -> case input of + NamespaceWindowFetched evs frontier done -> (CatchingUp c n, [DeliverNamespaceWindow evs frontier done]) + NamespaceWindowCompleted frontier done -> if done then (Live frontier, [EmitCaughtUp]) else (CatchingUp frontier 0, []) + 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 observed _ -> (Reconnecting (max c observed) 1, [EmitReconnecting 1, Backoff 1]) + Cancelled -> (Stopped StopCancelled, [Halt StopCancelled]) + Live c -> case input of + NamespaceWindowFetched evs frontier done -> (Live c, [DeliverNamespaceWindow evs frontier done]) + NamespaceWindowCompleted frontier _ -> (Live frontier, []) + 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 observed _ -> (Reconnecting (max c observed) 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 + NamespaceWindowFetched evs frontier done -> (CatchingUp c 0, [DeliverNamespaceWindow evs frontier done]) + NamespaceWindowCompleted frontier done -> if done then (Live frontier, [EmitCaughtUp]) else (CatchingUp frontier 0, []) + BatchFetched evs -> (CatchingUp (lastPos c evs) 0, [DeliverBatch evs]) + FetchEmpty -> (Live c, []) + FetchFailed _ -> (Reconnecting c (n + 1), [EmitReconnecting (n + 1), Backoff (n + 1)]) + ConnectionLost observed _ -> (Reconnecting (max c observed) (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 --- a/src/Kiroku/Store/Subscription/Stream.hs +++ b/src/Kiroku/Store/Subscription/Stream.hs @@ -1,32 +1,31 @@ -{- | 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. - -Both streams end normally when the subscription worker stops cleanly or is -cancelled. If the worker dies for any other reason, the next stream pull -rethrows the worker's exception to the stream consumer. --} -module Kiroku.Store.Subscription.Stream ( - -- * Plain pull stream +-- | 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. +-- +-- Both streams end normally when the subscription worker stops cleanly or is +-- cancelled. If the worker dies for any other reason, the next stream pull +-- rethrows the worker's exception to the stream consumer. +module Kiroku.Store.Subscription.Stream + ( -- * Plain pull stream subscriptionStream, -- * Ack-coupled pull stream @@ -37,12 +36,12 @@ streamBufferSizeValue, defaultStreamBufferSize, subscriptionAckStream, -) + ) where import Control.Concurrent.Async qualified as Async -import Control.Concurrent.STM ( - STM, +import Control.Concurrent.STM + ( STM, TMVar, TVar, atomically, @@ -57,59 +56,56 @@ takeTMVar, writeTBQueue, writeTVar, - ) + ) import Control.Exception (SomeException, fromException, mask, onException, throwIO) import Data.IORef (atomicModifyIORef', newIORef) import Kiroku.Store.Connection (KirokuStore) import Kiroku.Store.Subscription (subscribe) -import Kiroku.Store.Subscription.Types ( - SubscriptionConfig, +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. --} +-- | 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 - } - -{- | Construction error from 'mkStreamBufferSize' for a zero capacity. + { -- | the delivered event + ackEvent :: !RecordedEvent, + -- | 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). + ackAttempt :: !Word, + -- | one-shot reply the consumer must fill exactly once + ackReply :: !(TMVar SubscriptionResult) + } -A zero-capacity 'TBQueue' would make the bridge handler block forever on its -first delivery, before a stream consumer can ever see the event or reply to it. --} +-- | Construction error from 'mkStreamBufferSize' for a zero capacity. +-- +-- A zero-capacity 'TBQueue' would make the bridge handler block forever on its +-- first delivery, before a stream consumer can ever see the event or reply to it. newtype InvalidStreamBufferSize = InvalidStreamBufferSize Natural - deriving stock (Eq, Show) + deriving stock (Eq, Show) -- | Positive capacity, validated before allocating a bridge or starting a worker. newtype StreamBufferSize = StreamBufferSize Natural - deriving stock (Eq, Show) + deriving stock (Eq, Show) mkStreamBufferSize :: Natural -> Either InvalidStreamBufferSize StreamBufferSize mkStreamBufferSize n - | n >= 1 = Right (StreamBufferSize n) - | otherwise = Left (InvalidStreamBufferSize n) + | n >= 1 = Right (StreamBufferSize n) + | otherwise = Left (InvalidStreamBufferSize n) streamBufferSizeValue :: StreamBufferSize -> Natural streamBufferSizeValue (StreamBufferSize n) = n @@ -118,128 +114,126 @@ defaultStreamBufferSize = StreamBufferSize 256 data BridgeTermination - = BridgeClosedCleanly - | BridgeCrashed !SomeException + = BridgeClosedCleanly + | BridgeCrashed !SomeException closeBridge :: TVar (Maybe BridgeTermination) -> BridgeTermination -> STM () closeBridge closedVar termination = - readTVar closedVar >>= \case - Nothing -> writeTVar closedVar (Just termination) - Just _ -> pure () - -{- | 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 normally when the underlying -subscription stops cleanly or the returned cancel action runs. If the -underlying worker crashes, the next stream pull rethrows the worker exception -to the consumer. - -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. + readTVar closedVar >>= \case + Nothing -> writeTVar closedVar (Just termination) + Just _ -> pure () -The returned cancel action cancels the underlying subscription and wakes any -blocked reader without writing to the bounded queue. --} +-- | 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 normally when the underlying +-- subscription stops cleanly or the returned cancel action runs. If the +-- underlying worker crashes, the next stream pull rethrows the worker exception +-- to the consumer. +-- +-- 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 wakes any +-- blocked reader without writing to the bounded queue. subscriptionStream :: - KirokuStore -> - SubscriptionConfig -> - -- | TBQueue capacity for the bridge; must be at least 1. - StreamBufferSize -> - IO (Stream IO RecordedEvent, IO ()) + KirokuStore -> + SubscriptionConfig -> + -- | TBQueue capacity for the bridge; must be at least 1. + StreamBufferSize -> + 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. + (ackStream, cancelAction) <- subscriptionAckStream store config bufferSize + let stream = + Stream.mapM + ( \item -> do + atomically (putTMVar (ackReply item) Continue) + pure (ackEvent item) + ) + ackStream + pure (stream, cancelAction) -The returned cancel action cancels the underlying subscription (interrupting any -worker blocked waiting for a reply) and wakes any blocked reader without -writing to the bounded queue. A clean worker stop or cancellation ends the -stream normally; any other worker exception is rethrown from the next stream -pull. This includes overflow, handler exceptions, dead-letter database errors, -and decode-hook exceptions. --} +-- | 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 wakes any blocked reader without +-- writing to the bounded queue. A clean worker stop or cancellation ends the +-- stream normally; any other worker exception is rethrown from the next stream +-- pull. This includes overflow, handler exceptions, dead-letter database errors, +-- and decode-hook exceptions. subscriptionAckStream :: - KirokuStore -> - SubscriptionConfig -> - -- | TBQueue capacity for the bridge; must be at least 1. - StreamBufferSize -> - IO (Stream IO AckItem, IO ()) + KirokuStore -> + SubscriptionConfig -> + -- | TBQueue capacity for the bridge; must be at least 1. + StreamBufferSize -> + IO (Stream IO AckItem, IO ()) subscriptionAckStream store config bufferSize = mask $ \restore -> do - queue <- newTBQueueIO (streamBufferSizeValue bufferSize) - closedVar <- newTVarIO Nothing - -- 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)) + queue <- newTBQueueIO (streamBufferSizeValue bufferSize) + closedVar <- newTVarIO Nothing + -- 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 (AckItem event attempt reply)) - atomically (takeTMVar reply) + 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 (AckItem event attempt reply)) + atomically (takeTMVar reply) - let bridgeConfig = config{handler = bridgeHandler} + let bridgeConfig = config {handler = bridgeHandler} - subHandle <- restore (subscribe store bridgeConfig) - monitor <- - ( Async.async $ do - outcome <- wait subHandle - atomically . closeBridge closedVar $ case outcome of - Right () -> BridgeClosedCleanly - Left e - | Just Async.AsyncCancelled <- fromException e -> BridgeClosedCleanly - | otherwise -> BridgeCrashed e - ) - `onException` cancel subHandle + subHandle <- restore (subscribe store bridgeConfig) + monitor <- + ( Async.async $ do + outcome <- wait subHandle + atomically . closeBridge closedVar $ case outcome of + Right () -> BridgeClosedCleanly + Left e + | Just Async.AsyncCancelled <- fromException e -> BridgeClosedCleanly + | otherwise -> BridgeCrashed e + ) + `onException` cancel subHandle - let cancelAction = do - cancel subHandle - Async.wait monitor - atomically (closeBridge closedVar BridgeClosedCleanly) + let cancelAction = do + cancel subHandle + Async.wait monitor + atomically (closeBridge closedVar BridgeClosedCleanly) - let step :: () -> IO (Maybe (AckItem, ())) - step () = do - next <- - atomically $ - (Right <$> readTBQueue queue) - `orElse` (readTVar closedVar >>= maybe retry (pure . Left)) - case next of - Right item -> pure (Just (item, ())) - Left BridgeClosedCleanly -> pure Nothing - Left (BridgeCrashed e) -> throwIO e + let step :: () -> IO (Maybe (AckItem, ())) + step () = do + next <- + atomically $ + (Right <$> readTBQueue queue) + `orElse` (readTVar closedVar >>= maybe retry (pure . Left)) + case next of + Right item -> pure (Just (item, ())) + Left BridgeClosedCleanly -> pure Nothing + Left (BridgeCrashed e) -> throwIO e - pure (Stream.unfoldrM step (), cancelAction) + pure (Stream.unfoldrM step (), cancelAction) diff --git a/src/Kiroku/Store/Subscription/Types.hs b/src/Kiroku/Store/Subscription/Types.hs --- a/src/Kiroku/Store/Subscription/Types.hs +++ b/src/Kiroku/Store/Subscription/Types.hs @@ -1,25 +1,24 @@ {-# LANGUAGE ExistentialQuantification #-} -{- | 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 (..), +-- | 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 (..), MissingCheckpointPolicy (..), SubscriptionCheckpointKey (..), CheckpointInitialization (..), @@ -87,7 +86,8 @@ ConsumerGroupSizeMismatch (..), InvalidConsumerGroup (..), ConsumerGroupGuardConflict (..), -) where + ) +where import Control.Exception (Exception (..), SomeException) import Data.Aeson (Value) @@ -101,325 +101,313 @@ import Data.Vector (Vector) import GHC.Generics (Generic) import Kiroku.Store.Settings (DecodeFailure) -import Kiroku.Store.Subscription.Fsm ( - DeadLetterReason (..), +import Kiroku.Store.Subscription.Fsm + ( DeadLetterReason (..), RetryDelay (..), SubscriptionState, deadLetterReasonJson, deadLetterSummary, retryDelayMicros, - ) + ) import Kiroku.Store.Types (CategoryName, EventId, EventType, GlobalPosition, 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/. --} +-- | 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) + = -- | 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. --} +-- | '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'. +eventTypeMatches (OnlyEventTypes s) RecordedEvent {eventType = t} = Set.member t s -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. --} +-- | 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 + 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) + deriving newtype (Eq, Ord, Show) -{- | What a subscription does when its exact -@('SubscriptionName', consumer-group member)@ checkpoint key has no durable -row. The policy is consulted only for absence; an existing row always wins and -is never moved by initialization. --} +-- | What a subscription does when its exact +-- @('SubscriptionName', consumer-group member)@ checkpoint key has no durable +-- row. The policy is consulted only for absence; an existing row always wins and +-- is never moved by initialization. data MissingCheckpointPolicy - = -- | Materialize position zero and replay retained history. - FromBeginning - | -- | Atomically materialize the current @$all@ store head. - FromCurrentHead - | -- | Refuse startup without inserting a row. - FailIfMissing - deriving stock (Eq, Show, Generic) + = -- | Materialize position zero and replay retained history. + FromBeginning + | -- | Atomically materialize the current @$all@ store head. + FromCurrentHead + | -- | Refuse startup without inserting a row. + FailIfMissing + deriving stock (Eq, Show, Generic) -- | The durable identity of one subscription checkpoint row. data SubscriptionCheckpointKey = SubscriptionCheckpointKey - { subscriptionName :: !SubscriptionName - , consumerGroupMember :: !Int32 - } - deriving stock (Eq, Ord, Show, Generic) + { subscriptionName :: !SubscriptionName, + consumerGroupMember :: !Int32 + } + deriving stock (Eq, Ord, Show, Generic) -{- | The successful result of resolving one subscription checkpoint at -startup. 'ExistingCheckpoint' means a durable row already existed; -'InitializedCheckpoint' records the policy that created the row. In both -cases the position is the durable position returned by PostgreSQL. --} +-- | The successful result of resolving one subscription checkpoint at +-- startup. 'ExistingCheckpoint' means a durable row already existed; +-- 'InitializedCheckpoint' records the policy that created the row. In both +-- cases the position is the durable position returned by PostgreSQL. data CheckpointInitialization - = ExistingCheckpoint !SubscriptionCheckpointKey !GlobalPosition - | InitializedCheckpoint !MissingCheckpointPolicy !SubscriptionCheckpointKey !GlobalPosition - deriving stock (Eq, Show, Generic) + = ExistingCheckpoint !SubscriptionCheckpointKey !GlobalPosition + | InitializedCheckpoint !MissingCheckpointPolicy !SubscriptionCheckpointKey !GlobalPosition + deriving stock (Eq, Show, Generic) -- | Extract the durable position from either successful initialization result. checkpointInitializationPosition :: CheckpointInitialization -> GlobalPosition checkpointInitializationPosition = \case - ExistingCheckpoint _ position -> position - InitializedCheckpoint _ _ position -> position + ExistingCheckpoint _ position -> position + InitializedCheckpoint _ _ position -> position -{- | A typed startup refusal produced by 'FailIfMissing'. No checkpoint row is -inserted and a worker throws this exception before invoking its handler. --} +-- | A typed startup refusal produced by 'FailIfMissing'. No checkpoint row is +-- inserted and a worker throws this exception before invoking its handler. newtype SubscriptionCheckpointMissing = SubscriptionCheckpointMissing - { checkpointKey :: SubscriptionCheckpointKey - } - deriving stock (Eq, Show, Generic) + { checkpointKey :: SubscriptionCheckpointKey + } + deriving stock (Eq, Show, Generic) instance Exception SubscriptionCheckpointMissing where - toException = toException . SomeSubscriptionStartupFailure - fromException exception = do - SomeSubscriptionStartupFailure refusal <- fromException exception - cast refusal + toException = toException . SomeSubscriptionStartupFailure + fromException exception = do + SomeSubscriptionStartupFailure refusal <- fromException exception + cast refusal -- | One checkpoint row that has been durably persisted by a subscription. data SubscriptionCheckpoint = SubscriptionCheckpoint - { subscriptionName :: !SubscriptionName - , consumerGroupMember :: !Int32 - , checkpointPosition :: !GlobalPosition - , checkpointUpdatedAt :: !UTCTime - } - deriving stock (Eq, Show, Generic) + { subscriptionName :: !SubscriptionName, + consumerGroupMember :: !Int32, + checkpointPosition :: !GlobalPosition, + checkpointUpdatedAt :: !UTCTime + } + deriving stock (Eq, Show, Generic) -{- | A point-in-time view of the global store position and every durable -subscription checkpoint. The rows are ordered by 'subscriptionName' and then -'consumerGroupMember'. --} +-- | A point-in-time view of the global store position and every durable +-- subscription checkpoint. The rows are ordered by 'subscriptionName' and then +-- 'consumerGroupMember'. data SubscriptionCheckpointInventory = SubscriptionCheckpointInventory - { storePosition :: !GlobalPosition - , checkpoints :: !(Vector SubscriptionCheckpoint) - } - deriving stock (Eq, Show, Generic) + { storePosition :: !GlobalPosition, + checkpoints :: !(Vector SubscriptionCheckpoint) + } + deriving stock (Eq, Show, Generic) -- | A durably parked event. The worker's structured reason JSON is unchanged. data SubscriptionDeadLetter = SubscriptionDeadLetter - { deadLetterId :: !Int64 - , subscriptionName :: !SubscriptionName - , consumerGroupMember :: !Int32 - , globalPosition :: !GlobalPosition - , eventId :: !EventId - , reason :: !Value - , reasonSummary :: !Text - , attemptCount :: !Int32 - , createdAt :: !UTCTime - } - deriving stock (Eq, Show, Generic) + { deadLetterId :: !Int64, + subscriptionName :: !SubscriptionName, + consumerGroupMember :: !Int32, + globalPosition :: !GlobalPosition, + eventId :: !EventId, + reason :: !Value, + reasonSummary :: !Text, + attemptCount :: !Int32, + createdAt :: !UTCTime + } + deriving stock (Eq, Show, Generic) -{- | Exclusive cursor in descending (global position, dead-letter id) order. -It remains usable after the originating row is deleted. --} +-- | Exclusive cursor in descending (global position, dead-letter id) order. +-- It remains usable after the originating row is deleted. data SubscriptionDeadLetterCursor = SubscriptionDeadLetterCursor - { cursorGlobalPosition :: !GlobalPosition - , cursorDeadLetterId :: !Int64 - } - deriving stock (Eq, Ord, Show, Generic) + { cursorGlobalPosition :: !GlobalPosition, + cursorDeadLetterId :: !Int64 + } + deriving stock (Eq, Ord, Show, Generic) subscriptionDeadLetterCursor :: SubscriptionDeadLetter -> SubscriptionDeadLetterCursor -subscriptionDeadLetterCursor SubscriptionDeadLetter{globalPosition = position, deadLetterId = ident} = - SubscriptionDeadLetterCursor position ident +subscriptionDeadLetterCursor SubscriptionDeadLetter {globalPosition = position, deadLetterId = ident} = + SubscriptionDeadLetterCursor position ident -{- | Validated page size, 1 through 1,000. Use the smart constructor. -No Generic or numeric instance exposes a construction bypass. --} +-- | Validated page size, 1 through 1,000. Use the smart constructor. +-- No Generic or numeric instance exposes a construction bypass. newtype SubscriptionDeadLetterLimit = SubscriptionDeadLetterLimit Int32 - deriving stock (Eq, Ord, Show) + deriving stock (Eq, Ord, Show) newtype SubscriptionDeadLetterLimitOutOfRange = SubscriptionDeadLetterLimitOutOfRange Int32 - deriving stock (Eq, Show) + deriving stock (Eq, Show) + mkSubscriptionDeadLetterLimit :: Int32 -> Either SubscriptionDeadLetterLimitOutOfRange SubscriptionDeadLetterLimit mkSubscriptionDeadLetterLimit value - | value < 1 || value > 1000 = Left (SubscriptionDeadLetterLimitOutOfRange value) - | otherwise = Right (SubscriptionDeadLetterLimit value) + | value < 1 || value > 1000 = Left (SubscriptionDeadLetterLimitOutOfRange value) + | otherwise = Right (SubscriptionDeadLetterLimit value) + subscriptionDeadLetterLimitValue :: SubscriptionDeadLetterLimit -> Int32 subscriptionDeadLetterLimitValue (SubscriptionDeadLetterLimit value) = value + defaultSubscriptionDeadLetterLimit :: SubscriptionDeadLetterLimit defaultSubscriptionDeadLetterLimit = SubscriptionDeadLetterLimit 100 -- | Nothing selects all historical members, or starts at the newest row. data SubscriptionDeadLetterQuery = SubscriptionDeadLetterQuery - { subscriptionName :: !SubscriptionName - , consumerGroupMember :: !(Maybe Int32) - , after :: !(Maybe SubscriptionDeadLetterCursor) - , limit :: !SubscriptionDeadLetterLimit - } - deriving stock (Eq, Show, Generic) + { subscriptionName :: !SubscriptionName, + consumerGroupMember :: !(Maybe Int32), + after :: !(Maybe SubscriptionDeadLetterCursor), + limit :: !SubscriptionDeadLetterLimit + } + deriving stock (Eq, Show, Generic) defaultSubscriptionDeadLetterQuery :: SubscriptionName -> SubscriptionDeadLetterQuery defaultSubscriptionDeadLetterQuery name = SubscriptionDeadLetterQuery name Nothing Nothing defaultSubscriptionDeadLetterLimit -- | Trimmed page; a cursor is present exactly when another row exists. data SubscriptionDeadLetterPage = SubscriptionDeadLetterPage - { deadLetters :: !(Vector SubscriptionDeadLetter) - , nextCursor :: !(Maybe SubscriptionDeadLetterCursor) - } - deriving stock (Eq, Show, Generic) + { deadLetters :: !(Vector SubscriptionDeadLetter), + nextCursor :: !(Maybe SubscriptionDeadLetterCursor) + } + deriving stock (Eq, Show, Generic) --- | Which stream to subscribe to. +-- | Which events 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) + = -- | Subscribe to all events in global position order. + AllStreams + | -- | Subscribe to one exact category. + Category !CategoryName + | -- | A literal category namespace: @"pm"@ includes @pm@ and @pm:*@, + -- but not @pmm@. No trimming, case folding or wildcard interpretation. + -- Empty and trailing-colon values are literal too. Each worker scans + -- bounded global windows; its checkpoint records completed scan progress. + CategoryNamespace !Text + 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'), which counts total deliveries, not - redeliveries; 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) + = -- | 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'), which counts total deliveries, not + -- redeliveries; 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 how many total deliveries a single event gets 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. --} +-- | Bounds how many total deliveries a single event gets 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 total deliveries of one event before dead-lettering it. The - first delivery counts as attempt 1. A value @<= 1@ means the first 'Retry' - immediately dead-letters (no redelivery). - -} - } - deriving stock (Eq, Show) + { -- | Maximum total deliveries of one event before dead-lettering it. The + -- first delivery counts as attempt 1. A value @<= 1@ means the first 'Retry' + -- immediately dead-letters (no redelivery). + retryMaxAttempts :: Int + } + deriving stock (Eq, Show) -{- | The default 'RetryPolicy': up to five total deliveries of a single event — -the first delivery plus four redeliveries — before it is dead-lettered with -'DeadLetterMaxAttempts'. Handlers that never return 'Retry' are unaffected by -this default. --} +-- | The default 'RetryPolicy': up to five total deliveries of a single event — +-- the first delivery plus four redeliveries — 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. +defaultRetryPolicy = RetryPolicy {retryMaxAttempts = 5} -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. --} +-- | 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) + = -- | 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'. --} +-- | 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) + { subscriptionName :: SubscriptionName + } + deriving stock (Show) + deriving anyclass (Exception) -{- | Default decode retries exhausted. Wait returns this exception and the -stopped event carries StopUndecodable; the durable checkpoint is still before -the failed event. Fix the hook and restart to replay it. --} +-- | Default decode retries exhausted. Wait returns this exception and the +-- stopped event carries StopUndecodable; the durable checkpoint is still before +-- the failed event. Fix the hook and restart to replay it. newtype SubscriptionUndecodable = SubscriptionUndecodable - { subscriptionDecodeFailure :: DecodeFailure - } - deriving stock (Eq, Show) - deriving anyclass (Exception) + { subscriptionDecodeFailure :: DecodeFailure + } + deriving stock (Eq, Show) + deriving anyclass (Exception) -- | Handler callback invoked for each event, parameterized by monad. type EventHandlerM m = RecordedEvent -> m SubscriptionResult @@ -429,191 +417,179 @@ -- | Configuration for starting a subscription, parameterized by monad. data SubscriptionConfigM m = SubscriptionConfig - { name :: !SubscriptionName - , target :: !SubscriptionTarget - , handler :: !(EventHandlerM m) - , undecodableHandler :: !(Maybe (RecordedEvent -> DecodeFailure -> m SubscriptionResult)) - {- ^ Optional disposition of a raw undecodable event. Default Nothing: - retry at one-second spacing and then stop without skipping the event. - A callback uses the ordinary Continue/Stop/Retry/DeadLetter vocabulary. - -} - , handlerStallWarnAfter :: !(Maybe NominalDiffTime) - {- ^ Optional positive warning interval for a handler holding one event. - Default Nothing allocates no diagnostic cell, watchdog or timer and does - no diagnostic work per delivery. Warnings are advisory and never finalize - an acknowledgement or advance a checkpoint. Nonpositive values fail startup. - -} - , batchSize :: !BatchSize - -- ^ 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'. Applies only to non-group - 'AllStreams' subscriptions, because Category and consumer-group - subscriptions do not create publisher queues. 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. - Applies only to non-group 'AllStreams' subscriptions, because Category - and consumer-group subscriptions are DB-driven and have no publisher - queue. 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 at construction by 'mkConsumerGroupSize' and 'mkConsumerGroup'. - -} - , 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'. - -} - , missingCheckpointPolicy :: !MissingCheckpointPolicy - {- ^ What startup does only when the exact @(name, member)@ checkpoint row - is absent. 'FromBeginning' is the compatibility default and materializes - position zero. 'FromCurrentHead' atomically seeds the current store head, - and 'FailIfMissing' refuses startup before the handler runs. Existing rows - always take precedence, so changing this field never rewinds or advances - durable progress. - -} - , targetBindingPolicy :: !TargetBindingPolicy - -- ^ Adopt legacy unbound checkpoints (default) or require an existing binding. - , 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). - -} - } + { name :: !SubscriptionName, + target :: !SubscriptionTarget, + handler :: !(EventHandlerM m), + -- | Optional disposition of a raw undecodable event. Default Nothing: + -- retry at one-second spacing and then stop without skipping the event. + -- A callback uses the ordinary Continue/Stop/Retry/DeadLetter vocabulary. + undecodableHandler :: !(Maybe (RecordedEvent -> DecodeFailure -> m SubscriptionResult)), + -- | Optional positive warning interval for a handler holding one event. + -- Default Nothing allocates no diagnostic cell, watchdog or timer and does + -- no diagnostic work per delivery. Warnings are advisory and never finalize + -- an acknowledgement or advance a checkpoint. Nonpositive values fail startup. + handlerStallWarnAfter :: !(Maybe NominalDiffTime), + -- | Number of events to fetch per batch during catch-up (default: 100) + batchSize :: !BatchSize, + -- | Maximum number of /batches/ the publisher may enqueue for this + -- subscriber before applying 'overflowPolicy'. Applies only to non-group + -- 'AllStreams' subscriptions, because Category and consumer-group + -- subscriptions do not create publisher queues. 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). + queueCapacity :: !Natural, + -- | What the publisher does when this subscriber's queue is full. + -- Applies only to non-group 'AllStreams' subscriptions, because Category + -- and consumer-group subscriptions are DB-driven and have no publisher + -- queue. 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. + overflowPolicy :: !OverflowPolicy, + -- | '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 at construction by 'mkConsumerGroupSize' and 'mkConsumerGroup'. + consumerGroup :: !(Maybe ConsumerGroup), + -- | 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'. + consumerGroupGuard :: !Bool, + -- | What startup does only when the exact @(name, member)@ checkpoint row + -- is absent. 'FromBeginning' is the compatibility default and materializes + -- position zero. 'FromCurrentHead' atomically seeds the current store head, + -- and 'FailIfMissing' refuses startup before the handler runs. Existing rows + -- always take precedence, so changing this field never rewinds or advances + -- durable progress. + missingCheckpointPolicy :: !MissingCheckpointPolicy, + -- | Adopt legacy unbound checkpoints (default) or require an existing binding. + targetBindingPolicy :: !TargetBindingPolicy, + -- | 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. + retryPolicy :: !RetryPolicy, + -- | 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'). + eventTypeFilter :: !EventTypeFilter, + -- | 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). + selector :: !(Maybe (RecordedEvent -> Bool)) + } -- | 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. - -The missing-checkpoint policy defaults to 'FromBeginning' for source -compatibility. New call sites should override 'missingCheckpointPolicy' -deliberately when a future-only or pre-provisioned worker is intended. - -@ -let cfg = (defaultSubscriptionConfig "my-projection" AllStreams handler) - { missingCheckpointPolicy = FromBeginning } -withSubscription store cfg $ \\h -> wait h -@ --} +-- | 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. +-- +-- The missing-checkpoint policy defaults to 'FromBeginning' for source +-- compatibility. New call sites should override 'missingCheckpointPolicy' +-- deliberately when a future-only or pre-provisioned worker is intended. +-- +-- @ +-- let cfg = (defaultSubscriptionConfig "my-projection" AllStreams handler) +-- { missingCheckpointPolicy = FromBeginning } +-- withSubscription store cfg $ \\h -> wait h +-- @ defaultSubscriptionConfig :: - SubscriptionName -> - SubscriptionTarget -> - EventHandlerM m -> - SubscriptionConfigM m + SubscriptionName -> + SubscriptionTarget -> + EventHandlerM m -> + SubscriptionConfigM m defaultSubscriptionConfig name' target' handler' = - SubscriptionConfig - { name = name' - , target = target' - , handler = handler' - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , batchSize = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = PauseAndResume - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , retryPolicy = defaultRetryPolicy - , eventTypeFilter = AllEventTypes - , selector = Nothing - } + SubscriptionConfig + { name = name', + target = target', + handler = handler', + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + batchSize = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = PauseAndResume, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + 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. - -} - } + { -- | Cancel the subscription gracefully + cancel :: !(m ()), + -- | Block until the subscription completes or fails + wait :: !(m (Either SomeException ())), + -- | 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. + currentState :: !(m (Maybe SubscriptionState)) + } -- | Handle defaulting to 'IO'. type SubscriptionHandle = SubscriptionHandleM IO -- | A positive group size, validated once before starting any workers. newtype ConsumerGroupSize = ConsumerGroupSize Int32 - deriving stock (Eq, Show) + deriving stock (Eq, Show) consumerGroupSizeValue :: ConsumerGroupSize -> Int32 consumerGroupSizeValue (ConsumerGroupSize n) = n mkConsumerGroupSize :: Int32 -> Either InvalidConsumerGroup ConsumerGroupSize mkConsumerGroupSize n - | n >= 1 = Right (ConsumerGroupSize n) - | otherwise = Left (InvalidConsumerGroup 0 n) + | n >= 1 = Right (ConsumerGroupSize n) + | otherwise = Left (InvalidConsumerGroup 0 n) -- | Static membership. Use 'mkConsumerGroup'; accessors cannot update the pair. data ConsumerGroup = ConsumerGroup !Int32 !ConsumerGroupSize - deriving stock (Eq, Show) + deriving stock (Eq, Show) member :: ConsumerGroup -> Int32 member (ConsumerGroup m _) = m @@ -623,97 +599,95 @@ mkConsumerGroup :: Int32 -> ConsumerGroupSize -> Either InvalidConsumerGroup ConsumerGroup mkConsumerGroup m n - | m >= 0 && m < consumerGroupSizeValue n = Right (ConsumerGroup m n) - | otherwise = Left (InvalidConsumerGroup m (consumerGroupSizeValue n)) + | m >= 0 && m < consumerGroupSizeValue n = Right (ConsumerGroup m n) + | otherwise = Left (InvalidConsumerGroup m (consumerGroupSizeValue n)) -- | Construction error; invalid configuration never reaches a worker. data InvalidConsumerGroup = InvalidConsumerGroup - { invalidMember :: !Int32 - , invalidSize :: !Int32 - } - deriving stock (Eq, Show) + { invalidMember :: !Int32, + invalidSize :: !Int32 + } + deriving stock (Eq, Show) -{- | Stored topology disagrees with the configured size. Stop all members and -use 'Kiroku.Store.Subscription.Checkpoint.resizeConsumerGroupTx' before restart. --} +-- | Stored topology disagrees with the configured size. Stop all members and +-- use 'Kiroku.Store.Subscription.Checkpoint.resizeConsumerGroupTx' before restart. data ConsumerGroupSizeMismatch = ConsumerGroupSizeMismatch - { mismatchName :: !SubscriptionName - , configuredSize :: !Int32 - , observedSizes :: !(Vector Int32) - } - deriving stock (Eq, Show) + { mismatchName :: !SubscriptionName, + configuredSize :: !Int32, + observedSizes :: !(Vector Int32) + } + deriving stock (Eq, Show) instance Exception ConsumerGroupSizeMismatch where - toException = toException . SomeSubscriptionStartupFailure - fromException exception = do - SomeSubscriptionStartupFailure refusal <- fromException exception - cast refusal + toException = toException . SomeSubscriptionStartupFailure + fromException exception = do + SomeSubscriptionStartupFailure refusal <- fromException exception + cast refusal -{- | 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@. --} +-- | 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 (Eq, Show) + { conflictName :: !SubscriptionName, + conflictMember :: !Int32 + } + deriving stock (Eq, Show) instance Exception ConsumerGroupGuardConflict where - toException = toException . SomeSubscriptionStartupFailure - fromException exception = do - SomeSubscriptionStartupFailure refusal <- fromException exception - cast refusal + toException = toException . SomeSubscriptionStartupFailure + fromException exception = do + SomeSubscriptionStartupFailure refusal <- fromException exception + cast refusal -- | A nonpositive handler-stall warning interval was configured. newtype InvalidHandlerStallWarnAfter = InvalidHandlerStallWarnAfter NominalDiffTime - deriving stock (Eq, Show) + deriving stock (Eq, Show) instance Exception InvalidHandlerStallWarnAfter where - toException = toException . SomeSubscriptionStartupFailure - fromException exception = do - SomeSubscriptionStartupFailure refusal <- fromException exception - cast refusal + toException = toException . SomeSubscriptionStartupFailure + fromException exception = do + SomeSubscriptionStartupFailure refusal <- fromException exception + cast refusal -- | A catchable family of subscription startup refusals. Concrete catches work too. data SomeSubscriptionStartupFailure = forall e. (Exception e) => SomeSubscriptionStartupFailure e instance Show SomeSubscriptionStartupFailure where - show (SomeSubscriptionStartupFailure e) = show e + show (SomeSubscriptionStartupFailure e) = show e instance Exception SomeSubscriptionStartupFailure -- | Policy for checkpoint rows created before target identity was persisted. data TargetBindingPolicy = AdoptUnbound | RequireBound - deriving stock (Eq, Show) + deriving stock (Eq, Show) -- | Stored bindings differ from the requested target, or strict startup found unbound rows. data SubscriptionTargetMismatch = SubscriptionTargetMismatch - { targetMismatchName :: !SubscriptionName - , configuredTarget :: !SubscriptionTarget - , observedTargets :: !(Vector (Maybe SubscriptionTarget)) - } - deriving stock (Eq, Show) + { targetMismatchName :: !SubscriptionName, + configuredTarget :: !SubscriptionTarget, + observedTargets :: !(Vector (Maybe SubscriptionTarget)) + } + deriving stock (Eq, Show) instance Exception SubscriptionTargetMismatch where - toException = toException . SomeSubscriptionStartupFailure - fromException exception = do - SomeSubscriptionStartupFailure refusal <- fromException exception - cast refusal + toException = toException . SomeSubscriptionStartupFailure + fromException exception = do + SomeSubscriptionStartupFailure refusal <- fromException exception + cast refusal -- | A positive catch-up fetch size. The constructor is deliberately hidden. newtype BatchSize = BatchSize Int32 - deriving stock (Eq, Show) + deriving stock (Eq, Show) newtype InvalidBatchSize = InvalidBatchSize Int32 - deriving stock (Eq, Show) + deriving stock (Eq, Show) mkBatchSize :: Int32 -> Either InvalidBatchSize BatchSize mkBatchSize n - | n >= 1 = Right (BatchSize n) - | otherwise = Left (InvalidBatchSize n) + | n >= 1 = Right (BatchSize n) + | otherwise = Left (InvalidBatchSize n) batchSizeValue :: BatchSize -> Int32 batchSizeValue (BatchSize n) = n diff --git a/src/Kiroku/Store/Subscription/Worker.hs b/src/Kiroku/Store/Subscription/Worker.hs --- a/src/Kiroku/Store/Subscription/Worker.hs +++ b/src/Kiroku/Store/Subscription/Worker.hs @@ -1,944 +1,1083 @@ -{- | 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', 'withLoadCheckpointHookForTest', and -'withSaveCheckpointHookForTest' are test-only seams for controlling fetch, -checkpoint-load, and checkpoint-save boundaries. --} -module Kiroku.Store.Subscription.Worker ( - LiveSource (..), - runWorker, - configMember, - withFetchBatchHookForTest, - withLoadCheckpointHookForTest, - withSaveCheckpointHookForTest, -) where - -import Contravariant.Extras (contrazip2) -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async qualified as Async -import Control.Concurrent.STM (TBQueue, TVar, atomically, check, newTVarIO, orElse, readTBQueue, readTVar, registerDelay, tryReadTBQueue, writeTVar) -import Control.Concurrent.STM qualified as STM -import Control.Exception (SomeException, bracket, finally, fromException, mask, throwIO, toException, try) -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.Int (Int32) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Data.Vector (Vector) -import Data.Vector qualified as V -import Data.Word (Word64) -import GHC.Clock (getMonotonicTimeNSec) -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 (..), - emitOrDrop, - ) -import Kiroku.Store.SQL qualified as SQL -import Kiroku.Store.Settings (DecodedBatch (..), DecodedEvent (..), StoreSettings, decodeEvent, decodeEvents, decodedBatchLastEvent, decodedBatchLength, decodedEventRecorded, filterDecodedBatch) -import Kiroku.Store.Subscription.Checkpoint.SQL qualified as CheckpointSQL -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 hiding (eventId, globalPosition) -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))) - -type LoadCheckpointHook = - SubscriptionConfig -> - IO - ( Maybe - ( Either - Pool.UsageError - (Either SubscriptionCheckpointMissing CheckpointInitialization) - ) - ) - -type SaveCheckpointHook = - SubscriptionConfig -> - GlobalPosition -> - IO () - -{-# NOINLINE fetchBatchHookRef #-} -fetchBatchHookRef :: IORef (Maybe FetchBatchHook) -fetchBatchHookRef = unsafePerformIO (newIORef Nothing) - -{-# NOINLINE loadCheckpointHookRef #-} -loadCheckpointHookRef :: IORef (Maybe LoadCheckpointHook) -loadCheckpointHookRef = unsafePerformIO (newIORef Nothing) - -{-# NOINLINE saveCheckpointHookRef #-} -saveCheckpointHookRef :: IORef (Maybe SaveCheckpointHook) -saveCheckpointHookRef = 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) - -{- | Install a process-local checkpoint-load hook for tests that need -deterministic subscription-startup fault injection. Production code leaves the -hook unset. --} -withLoadCheckpointHookForTest :: LoadCheckpointHook -> IO a -> IO a -withLoadCheckpointHookForTest hook action = - bracket - ( do - previous <- readIORef loadCheckpointHookRef - writeIORef loadCheckpointHookRef (Just hook) - pure previous - ) - (writeIORef loadCheckpointHookRef) - (const action) - -{- | Install a process-local checkpoint-save boundary hook for lifecycle tests. - -The hook runs immediately before the database statement. Production code leaves -it unset. --} -withSaveCheckpointHookForTest :: SaveCheckpointHook -> IO a -> IO a -withSaveCheckpointHookForTest hook action = - bracket - ( do - previous <- readIORef saveCheckpointHookRef - writeIORef saveCheckpointHookRef (Just hook) - pure previous - ) - (writeIORef saveCheckpointHookRef) - (const action) - -fetchRetryDelayMicros :: Int -> Int -fetchRetryDelayMicros attempt = - min categorySafetyPollMicros (100_000 * (2 ^ min attempt 9 :: Int)) - -{- | How a worker obtains live-mode batches, fixed at 'subscribe' time from the -config's (consumerGroup, target) shape. - -Only 'LiveFromPublisherQueue' owns a registration with the EventPublisher. The -other shapes are DB-driven and the publisher must do no fan-out work for them. --} -data LiveSource - = {- | Non-group AllStreams: read the publisher's bounded queue; the status - TVar carries Paused/Overflowed backpressure signals. - -} - LiveFromPublisherQueue !(TBQueue DecodedBatch) !(TVar SubscriberStatus) - | {- | Category, plain or consumer-group member: wake on the named - category's NOTIFY generation counter and re-query the database (with the - partition predicate, for a member). - -} - LiveFromCategoryNotify !Text - | {- | Consumer-group member of AllStreams: wake when the global position - advances and re-query with the partition predicate. - -} - LiveFromGroupPolling - -{- | Run the subscription worker loop. Two phases: - -Phase 1 (catch-up): queries database directly until reaching publisherPosition. -Phase 2 (live): for 'LiveFromPublisherQueue', reads from the bounded TBQueue -the publisher delivers to; for 'LiveFromCategoryNotify' and -'LiveFromGroupPolling', re-queries the database, and no publisher queue exists. - -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.KirokuEventSubscriptionCheckpointResolved' once - when startup resumes or initializes a checkpoint, followed by - 'Kiroku.Store.Observability.KirokuEventSubscriptionStarted'. A refused - missing checkpoint emits - 'Kiroku.Store.Observability.KirokuEventSubscriptionCheckpointMissing' - instead and fails before delivery. -* '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 -> - LiveSource -> - {- | 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 liveSource stateVar pubPosVar catGenVar config mHandler stSettings = liftIO $ - withHandlerStallDiagnostics config (emitOrDrop mHandler) $ \deliveryConfig -> - runWorkerBody pool liveSource stateVar pubPosVar catGenVar deliveryConfig mHandler stSettings - --- Select the delivery handler once per worker. The disabled arm returns the --- original config directly, with no per-delivery diagnostic branch or work. -withHandlerStallDiagnostics :: SubscriptionConfig -> (KirokuEvent -> IO ()) -> (SubscriptionConfig -> IO a) -> IO a -withHandlerStallDiagnostics config emit action = case handlerStallWarnAfter config of - Nothing -> action config - Just threshold - | threshold <= 0 -> throwIO (InvalidHandlerStallWarnAfter threshold) - | otherwise -> do - pending <- newTVarIO Nothing - let tracked event = mask $ \restore -> do - started <- getMonotonicTimeNSec - let delivery = StalledDelivery (globalPosition event) (eventId event) started - atomically (writeTVar pending (Just delivery)) - restore (handler config event) `finally` atomically (writeTVar pending Nothing) - Async.withAsync (watchHandler pending threshold) $ \watchdog -> do - Async.link watchdog - action config{handler = tracked} - where - -- Park while idle. Reuse a pending interval across completed/replaced - -- invocations, rather than abandoning a registerDelay timer per event. - watchHandler pending threshold = awaitDelivery - where - awaitDelivery = do - _ <- atomically $ readTVar pending >>= maybe STM.retry pure - waitInterval threshold - waitInterval delay = do - timer <- registerDelay (durationMicros delay) - atomically (readTVar timer >>= check) - current <- atomically (readTVar pending) - case current of - Nothing -> awaitDelivery - Just delivery@(StalledDelivery pos eid started) -> do - now <- getMonotonicTimeNSec - let elapsed = fromRational (fromIntegral (now - started) / 1_000_000_000) - if elapsed < threshold - then waitInterval (threshold - elapsed) - else do - stillPending <- atomically ((== Just delivery) <$> readTVar pending) - when stillPending $ - emit (KirokuEventSubscriptionHandlerStalled (name config) pos eid elapsed (groupCtxOf config)) - waitInterval threshold - --- One cell per enabled worker, not one timer/thread per handler invocation. -data StalledDelivery = StalledDelivery !GlobalPosition !EventId !Word64 - deriving stock (Eq) - --- registerDelay accepts an Int. Cap huge intervals safely and round positive --- sub-microsecond intervals up instead of creating a zero-delay polling loop. -durationMicros :: NominalDiffTime -> Int -durationMicros duration = fromInteger (max 1 (min (toInteger (maxBound :: Int)) (ceiling (duration * 1_000_000)))) - -runWorkerBody :: Pool -> LiveSource -> TVar SubscriptionState -> TVar GlobalPosition -> TVar (Map Text Word64) -> SubscriptionConfig -> Maybe (KirokuEvent -> IO ()) -> StoreSettings -> IO () -runWorkerBody pool liveSource stateVar pubPosVar catGenVar config mHandler stSettings = do - let emit = emitOrDrop mHandler - 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 cg) -> guardMember pool subName (member cg) - _ -> pure () - resolution <- loadCheckpoint pool config emit - checkpoint <- case resolution of - Left missing -> do - emit (KirokuEventSubscriptionCheckpointMissing missing groupCtx) - throwIO missing - Right initialization -> do - emit (KirokuEventSubscriptionCheckpointResolved initialization groupCtx) - pure (checkpointInitializationPosition initialization) - 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 - | decodedBatchLength events == 0 -> pure CaughtUp - | otherwise -> pure (BatchFetched events) - Live c -> case liveSource of - LiveFromPublisherQueue liveQueue statusVar -> 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 = filterDecodedBatch ((> c) . globalPosition) events - pure (if decodedBatchLength fresh == 0 then FetchEmpty else BatchFetched fresh) - LiveFromCategoryNotify cat -> - liveExitToInput =<< liveLoopCategoryNotify pool config stateVar catGenVar cat emit posRef c stSettings - LiveFromGroupPolling -> - 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 - case liveSource of - LiveFromPublisherQueue liveQueue statusVar -> do - atomically $ do - drainQueue liveQueue - writeTVar statusVar Pub.Active - pure QueueDrained - -- Defensive totality: only the queue branch can produce - -- QueueBackpressured, so DB-driven sources should never - -- enter Paused. - LiveFromCategoryNotify{} -> pure QueueDrained - LiveFromGroupPolling -> 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 - | decodedBatchLength events == 0 -> pure FetchEmpty - | otherwise -> pure (BatchFetched events) - -- Defensive totality: 'Retrying' is a surfaced observability state - -- that the delivery primitive writes into the state TVar and then - -- restores, so it is never a driving state reaching this function. - -- Mirror 'step''s defensive 'Retrying' clause, which returns to - -- 'Live' at the same cursor. - Retrying c _ -> nextInput (Live c) - 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 stSettings - 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 - StopUndecodable failure -> throwIO (SubscriptionUndecodable failure) - - lastPosOf events = globalPosition (decodedBatchLastEvent 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 -> do - position <- readIORef posRef - pure (ConnectionLost position 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 (\cg -> GroupMember (member cg) (size cg)) (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 - | Just (SubscriptionUndecodable failure) <- fromException e = StopUndecodable failure - | 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) - -configSize :: SubscriptionConfig -> Int32 -configSize config = maybe 1 size (consumerGroup config) - --- Resolve the exact checkpoint key through the shared initializer. A database --- error is emitted and rethrown so startup fails loudly. A semantic --- 'FailIfMissing' result remains typed so the caller can emit the distinct --- refusal event before throwing it. Each group member resolves its own key. -loadCheckpoint :: - Pool -> - SubscriptionConfig -> - (KirokuEvent -> IO ()) -> - IO (Either SubscriptionCheckpointMissing CheckpointInitialization) -loadCheckpoint pool config emit = do - let subName = name config - mem = configMember config - mHook <- readIORef loadCheckpointHookRef - injected <- maybe (pure Nothing) (\hook -> hook config) mHook - result <- case injected of - Just hooked -> pure (fmap (either (Left . SomeSubscriptionStartupFailure) (Right . (,False))) hooked) - Nothing -> - Pool.use pool $ - CheckpointSQL.initializeWorkerCheckpointSession - subName - mem - (configSize config) - (target config) - (targetBindingPolicy config) - (missingCheckpointPolicy config) - case result of - Left err -> do - emit (KirokuEventSubscriptionDbError subName LoadCheckpoint err (groupCtxOf config)) - throwIO err - Right (Left refusal@(SomeSubscriptionStartupFailure concrete)) -> - case fromException (toException concrete) of - Just missing -> pure (Left missing) - Nothing -> do - case fromException (toException concrete) of - Just mismatch -> emit (KirokuEventSubscriptionGroupSizeMismatch mismatch (groupCtxOf config)) - Nothing -> pure () - throwIO refusal - Right (Right (resolution, adopted)) -> do - when adopted $ emit (KirokuEventSubscriptionTargetBound subName (target config) (groupCtxOf config)) - pure (Right resolution) - --- 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 every `Category` subscription, plain or consumer-group. A --- member cannot tell from a NOTIFY payload whether the stream is in its slice --- (that is `hashtextextended(stream_id) % size = member`, a Postgres hash), but --- it can gate on the category: the category generation advances on every append --- to a stream of the category, a superset of the member's own streams, and --- `fetchBatch` applies the partition predicate in SQL. So a member of an idle --- category does no live database work while other categories are busy, and a --- member whose sibling received the append does one empty fetch. -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) (decodedBatchLength events) (groupCtxOf config)) - if decodedBatchLength events == 0 - then pure (Right (Just c)) - else do - result <- processEvents pool config stateVar events emit posRef stSettings - case result of - Nothing -> pure (Right Nothing) -- handler said Stop - Just newPos -> drainTo newPos - --- Phase 2: live (DB-driven, consumer-group members of AllStreams). 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) (decodedBatchLength events) (groupCtxOf config)) - if decodedBatchLength events == 0 - then pure (Right (Just c)) - else do - result <- processEvents pool config stateVar events emit posRef stSettings - 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 DecodedBatch) -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, batchSizeValue (batchSize config)) SQL.readAllForwardStmt) - handle result - (Nothing, Category (CategoryName cat)) -> do - result <- Pool.use pool (Session.statement (pos, cat, batchSizeValue (batchSize config)) SQL.readCategoryForwardStmt) - handle result - (Just cg, AllStreams) -> do - let m = member cg; n = size cg - result <- Pool.use pool (Session.statement (pos, m, n, batchSizeValue (batchSize config)) SQL.readAllForwardConsumerGroupStmt) - handle result - (Just cg, Category (CategoryName cat)) -> do - let m = member cg; n = size cg - result <- Pool.use pool (Session.statement (pos, cat, m, n, batchSizeValue (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 -> - DecodedBatch -> - (KirokuEvent -> IO ()) -> - IORef GlobalPosition -> - StoreSettings -> - IO (Maybe GlobalPosition) -processEvents pool config stateVar batch emit posRef stSettings = do - driving <- atomically (readTVar stateVar) - let phase = case driving of - CatchingUp{} -> DeliveredCatchUp - _ -> DeliveredLive - emit (KirokuEventSubscriptionDelivered subName (decodedBatchLength batch) phase groupCtx) - -- Choose the vector representation once per batch. The unchanged arm walks - -- RecordedEvent directly, with no per-event Decoded/Undecodable allocation. - case batch of - UnchangedBatch events -> walk events id (\event pos -> deliver driving event pos 1) - TransformedBatch events -> walk events decodedEventRecorded (\event pos -> dispatch driving event pos 1) - where - subName = name config - groupCtx = groupCtxOf config - maxAttempts = retryMaxAttempts (retryPolicy config) - - walk :: Vector a -> (a -> RecordedEvent) -> (a -> GlobalPosition -> IO Bool) -> IO (Maybe GlobalPosition) - walk events rawOf consume = go 0 - where - go i - | i >= V.length events = do - let newPos = globalPosition (rawOf (V.last events)) - writeIORef posRef newPos - saveCheckpoint pool config newPos emit - pure (Just newPos) - | otherwise = do - let item = events V.! i - event = rawOf item - evtPos = globalPosition event - keepGoing <- - if shouldDeliver (eventTypeFilter config) (selector config) event - then consume item evtPos - else pure True - if keepGoing - then writeIORef posRef evtPos >> go (i + 1) - else pure Nothing - - deliver driving event evtPos attempt = do - writeIORef posRef evtPos - result <- handler config event - resolve driving event evtPos attempt result (deliver driving event evtPos (attempt + 1)) - - dispatch driving outcome evtPos attempt = case outcome of - Decoded event -> deliver driving event evtPos attempt - Undecodable raw failure -> case undecodableHandler config of - Nothing - | attempt >= maxAttempts -> throwIO (SubscriptionUndecodable failure) - | otherwise -> do - pause driving evtPos attempt (RetryDelay 1) - retryDecode driving raw evtPos (attempt + 1) - Just callback -> do - result <- callback raw failure - resolve driving raw evtPos attempt result (retryDecode driving raw evtPos (attempt + 1)) - - retryDecode driving raw evtPos attempt = do - outcome <- decodeEvent stSettings raw - case outcome of - Decoded event | not (shouldDeliver (eventTypeFilter config) (selector config) event) -> pure True - _ -> dispatch driving outcome evtPos attempt - - -- Ordinary and explicitly chosen undecodable dispositions share exactly - -- one checkpoint/dead-letter/retry resolver. The absent callback never - -- enters its exhausted-Retry dead-letter branch. - resolve driving event evtPos attempt result retry = case result of - Continue -> pure True - Stop -> do - writeIORef posRef evtPos - saveCheckpoint pool config evtPos emit - pure False - DeadLetter reason -> do - writeDeadLetter pool config evtPos event reason attempt emit - pure True - Retry delay - | attempt >= maxAttempts -> do - writeDeadLetter pool config evtPos event (DeadLetterMaxAttempts attempt) attempt emit - pure True - | otherwise -> pause driving evtPos attempt delay >> retry - - pause driving evtPos attempt delay = do - atomically (writeTVar stateVar (Retrying evtPos attempt)) - emit (KirokuEventSubscriptionRetrying subName evtPos attempt groupCtx) - threadDelay (retryDelayMicros delay) - atomically (writeTVar stateVar driving) - --- 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 - (kind, category) = CheckpointSQL.targetColumns (Just (target config)) - EventId uuid = eventId event - params = - SQL.DeadLetterParams - { SQL.dlSubscriptionName = name' - , SQL.dlMember = mem - , SQL.dlTargetKind = kind - , SQL.dlTargetCategory = category - , SQL.dlGroupSize = configSize config - , 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 position@(GlobalPosition pos) emit = do - let subName@(SubscriptionName name') = name config - mem = configMember config - mHook <- readIORef saveCheckpointHookRef - mapM_ (\hook -> hook config position) mHook - result <- Pool.use pool (CheckpointSQL.saveBoundCheckpointSession (target config) name' mem pos (configSize config)) - case result of - Left err -> emit (KirokuEventSubscriptionDbError subName SaveCheckpoint err (groupCtxOf config)) - Right () -> pure () +-- | 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', 'withLoadCheckpointHookForTest', and +-- 'withSaveCheckpointHookForTest' are test-only seams for controlling fetch, +-- checkpoint-load, and checkpoint-save boundaries. +module Kiroku.Store.Subscription.Worker + ( LiveSource (..), + runWorker, + configMember, + withFetchBatchHookForTest, + withLoadCheckpointHookForTest, + withSaveCheckpointHookForTest, + withNamespaceSafetyPollForTest, + withNamespaceWindowHookForTest, + ) +where + +import Contravariant.Extras (contrazip2) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async qualified as Async +import Control.Concurrent.STM (TBQueue, TVar, atomically, check, newTVarIO, orElse, readTBQueue, readTVar, registerDelay, tryReadTBQueue, writeTVar) +import Control.Concurrent.STM qualified as STM +import Control.Exception (SomeException, bracket, finally, fromException, mask, throwIO, toException, try) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Int (Int32) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Data.Vector (Vector) +import Data.Vector qualified as V +import Data.Word (Word64) +import GHC.Clock (getMonotonicTimeNSec) +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 (..), + emitOrDrop, + ) +import Kiroku.Store.SQL qualified as SQL +import Kiroku.Store.Settings (DecodedBatch (..), DecodedEvent (..), StoreSettings, decodeEvent, decodeEvents, decodedBatchLastEvent, decodedBatchLength, decodedEventRecorded, filterDecodedBatch) +import Kiroku.Store.Subscription.Checkpoint.SQL qualified as CheckpointSQL +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 hiding (eventId, globalPosition) +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))) + +type LoadCheckpointHook = + SubscriptionConfig -> + IO + ( Maybe + ( Either + Pool.UsageError + (Either SubscriptionCheckpointMissing CheckpointInitialization) + ) + ) + +type SaveCheckpointHook = + SubscriptionConfig -> + GlobalPosition -> + IO () + +{-# NOINLINE fetchBatchHookRef #-} +fetchBatchHookRef :: IORef (Maybe FetchBatchHook) +fetchBatchHookRef = unsafePerformIO (newIORef Nothing) + +{-# NOINLINE loadCheckpointHookRef #-} +loadCheckpointHookRef :: IORef (Maybe LoadCheckpointHook) +loadCheckpointHookRef = unsafePerformIO (newIORef Nothing) + +{-# NOINLINE saveCheckpointHookRef #-} +saveCheckpointHookRef :: IORef (Maybe SaveCheckpointHook) +saveCheckpointHookRef = 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) + +-- | Install a process-local checkpoint-load hook for tests that need +-- deterministic subscription-startup fault injection. Production code leaves the +-- hook unset. +withLoadCheckpointHookForTest :: LoadCheckpointHook -> IO a -> IO a +withLoadCheckpointHookForTest hook action = + bracket + ( do + previous <- readIORef loadCheckpointHookRef + writeIORef loadCheckpointHookRef (Just hook) + pure previous + ) + (writeIORef loadCheckpointHookRef) + (const action) + +-- | Install a process-local checkpoint-save boundary hook for lifecycle tests. +-- +-- The hook runs immediately before the database statement. Production code leaves +-- it unset. +withSaveCheckpointHookForTest :: SaveCheckpointHook -> IO a -> IO a +withSaveCheckpointHookForTest hook action = + bracket + ( do + previous <- readIORef saveCheckpointHookRef + writeIORef saveCheckpointHookRef (Just hook) + pure previous + ) + (writeIORef saveCheckpointHookRef) + (const action) + +-- | Test timing and fetch injection; production uses the normal safety interval. +{-# NOINLINE namespaceSafetyPollRef #-} +namespaceSafetyPollRef :: IORef Int +namespaceSafetyPollRef = unsafePerformIO (newIORef categorySafetyPollMicros) + +withNamespaceSafetyPollForTest :: Int -> IO a -> IO a +withNamespaceSafetyPollForTest micros action = + bracket + (readIORef namespaceSafetyPollRef <* writeIORef namespaceSafetyPollRef micros) + (writeIORef namespaceSafetyPollRef) + (const action) + +type NamespaceWindowHook = SubscriptionConfig -> GlobalPosition -> GlobalPosition -> IO (Maybe (Either Pool.UsageError SQL.NamespaceWindow)) + +{-# NOINLINE namespaceWindowHookRef #-} +namespaceWindowHookRef :: IORef (Maybe NamespaceWindowHook) +namespaceWindowHookRef = unsafePerformIO (newIORef Nothing) + +withNamespaceWindowHookForTest :: NamespaceWindowHook -> IO a -> IO a +withNamespaceWindowHookForTest hook action = + bracket + (readIORef namespaceWindowHookRef <* writeIORef namespaceWindowHookRef (Just hook)) + (writeIORef namespaceWindowHookRef) + (const action) + +fetchRetryDelayMicros :: Int -> Int +fetchRetryDelayMicros attempt = + min categorySafetyPollMicros (100_000 * (2 ^ min attempt 9 :: Int)) + +-- | How a worker obtains live-mode batches, fixed at 'subscribe' time from the +-- config's (consumerGroup, target) shape. +-- +-- Only 'LiveFromPublisherQueue' owns a registration with the EventPublisher. The +-- other shapes are DB-driven and the publisher must do no fan-out work for them. +data LiveSource + = -- | Non-group AllStreams: read the publisher's bounded queue; the status + -- TVar carries Paused/Overflowed backpressure signals. + LiveFromPublisherQueue !(TBQueue DecodedBatch) !(TVar SubscriberStatus) + | -- | Category, plain or consumer-group member: wake on the named + -- category's NOTIFY generation counter and re-query the database (with the + -- partition predicate, for a member). + LiveFromCategoryNotify !Text + | -- | Namespace workers share only their active namespace's wake cell. + LiveFromNamespaceNotify !(TVar Word64) + | -- | Consumer-group member of AllStreams: wake when the global position + -- advances and re-query with the partition predicate. + LiveFromGroupPolling + +-- | Run the subscription worker loop. Two phases: +-- +-- Phase 1 (catch-up): queries database directly until reaching publisherPosition. +-- Phase 2 (live): for 'LiveFromPublisherQueue', reads from the bounded TBQueue +-- the publisher delivers to; for 'LiveFromCategoryNotify' and +-- 'LiveFromGroupPolling', re-queries the database, and no publisher queue exists. +-- +-- 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.KirokuEventSubscriptionCheckpointResolved' once +-- when startup resumes or initializes a checkpoint, followed by +-- 'Kiroku.Store.Observability.KirokuEventSubscriptionStarted'. A refused +-- missing checkpoint emits +-- 'Kiroku.Store.Observability.KirokuEventSubscriptionCheckpointMissing' +-- instead and fails before delivery. +-- * '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 -> + LiveSource -> + -- | 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 liveSource stateVar pubPosVar catGenVar config mHandler stSettings = liftIO $ + withHandlerStallDiagnostics config (emitOrDrop mHandler) $ \deliveryConfig -> + runWorkerBody pool liveSource stateVar pubPosVar catGenVar deliveryConfig mHandler stSettings + +-- Select the delivery handler once per worker. The disabled arm returns the +-- original config directly, with no per-delivery diagnostic branch or work. +withHandlerStallDiagnostics :: SubscriptionConfig -> (KirokuEvent -> IO ()) -> (SubscriptionConfig -> IO a) -> IO a +withHandlerStallDiagnostics config emit action = case handlerStallWarnAfter config of + Nothing -> action config + Just threshold + | threshold <= 0 -> do + let refusal = InvalidHandlerStallWarnAfter threshold + emit (KirokuEventSubscriptionStopped (name config) (GlobalPosition 0) (StopWorkerCrashed (toException refusal)) (groupCtxOf config)) + throwIO refusal + | otherwise -> do + pending <- newTVarIO Nothing + let tracked event = mask $ \restore -> do + started <- getMonotonicTimeNSec + let delivery = StalledDelivery (globalPosition event) (eventId event) started + atomically (writeTVar pending (Just delivery)) + restore (handler config event) `finally` atomically (writeTVar pending Nothing) + Async.withAsync (watchHandler pending threshold) $ \watchdog -> do + Async.link watchdog + action config {handler = tracked} + where + -- Park while idle. Reuse a pending interval across completed/replaced + -- invocations, rather than abandoning a registerDelay timer per event. + watchHandler pending threshold = awaitDelivery + where + awaitDelivery = do + _ <- atomically $ readTVar pending >>= maybe STM.retry pure + waitInterval threshold + waitInterval delay = do + timer <- registerDelay (durationMicros delay) + atomically (readTVar timer >>= check) + current <- atomically (readTVar pending) + case current of + Nothing -> awaitDelivery + Just delivery@(StalledDelivery pos eid started) -> do + now <- getMonotonicTimeNSec + let elapsed = fromRational (fromIntegral (now - started) / 1_000_000_000) + if elapsed < threshold + then waitInterval (threshold - elapsed) + else do + stillPending <- atomically ((== Just delivery) <$> readTVar pending) + when stillPending $ + emit (KirokuEventSubscriptionHandlerStalled (name config) pos eid elapsed (groupCtxOf config)) + waitInterval threshold + +-- One cell per enabled worker, not one timer/thread per handler invocation. +data StalledDelivery = StalledDelivery !GlobalPosition !EventId !Word64 + deriving stock (Eq) + +-- registerDelay accepts an Int. Cap huge intervals safely and round positive +-- sub-microsecond intervals up instead of creating a zero-delay polling loop. +durationMicros :: NominalDiffTime -> Int +durationMicros duration = fromInteger (max 1 (min (toInteger (maxBound :: Int)) (ceiling (duration * 1_000_000)))) + +-- Allocated only for namespace workers; old targets keep their startup path. +data NamespaceScanState = NamespaceScanState + { scanSweep :: !(IORef (Maybe GlobalPosition)), + scanGeneration :: !(IORef (Maybe Word64)), + scanEmptyWindows :: !(IORef Int), + scanSaved :: !(IORef GlobalPosition) + } + +runWorkerBody :: Pool -> LiveSource -> TVar SubscriptionState -> TVar GlobalPosition -> TVar (Map Text Word64) -> SubscriptionConfig -> Maybe (KirokuEvent -> IO ()) -> StoreSettings -> IO () +runWorkerBody pool liveSource stateVar pubPosVar catGenVar config mHandler stSettings = do + let emit = emitOrDrop mHandler + subName = name config + groupCtx = groupCtxOf config + posRef <- newIORef (GlobalPosition 0) + -- One captured database head per sweep and a generation snapshotted before it. + namespaceState <- case liveSource of + LiveFromNamespaceNotify _ -> Just <$> (NamespaceScanState <$> newIORef Nothing <*> newIORef Nothing <*> newIORef 0 <*> newIORef (GlobalPosition 0)) + _ -> pure Nothing + + let namespaceScan = case namespaceState of + Just state -> state + Nothing -> error "namespace scan state requested for a legacy target" + 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 cg) -> guardMember pool subName (member cg) + _ -> pure () + resolution <- loadCheckpoint pool config emit + checkpoint <- case resolution of + Left missing -> do + emit (KirokuEventSubscriptionCheckpointMissing missing groupCtx) + throwIO missing + Right initialization -> do + emit (KirokuEventSubscriptionCheckpointResolved initialization groupCtx) + pure (checkpointInitializationPosition initialization) + mapM_ (\scan -> writeIORef (scanSaved scan) checkpoint) namespaceState + 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) + + namespaceInput :: Bool -> GlobalPosition -> TVar Word64 -> IO Input + namespaceInput live cursor generation = do + sweep <- readIORef (scanSweep namespaceScan) + captured <- case sweep of + Just headPosition -> pure (Right headPosition) + Nothing -> do + previous <- readIORef (scanGeneration namespaceScan) + when live $ case previous of + Nothing -> pure () + Just before -> do + micros <- readIORef namespaceSafetyPollRef + timer <- registerDelay micros + atomically $ + (readTVar generation >>= \g -> check (g /= before)) + `orElse` (readTVar timer >>= check) + -- Snapshot BEFORE the head read, including on initial catch-up. + before <- atomically (readTVar generation) + result <- Pool.use pool (Session.statement () SQL.currentGlobalPositionStmt) + case result of + Left err -> pure (Left err) + Right headPosition -> do + writeIORef (scanGeneration namespaceScan) (Just before) + writeIORef (scanSweep namespaceScan) (Just (GlobalPosition headPosition)) + pure (Right (GlobalPosition headPosition)) + result <- case captured of + Left err -> pure (Left err) + Right headPosition + | cursor >= headPosition -> pure (Right (SQL.NamespaceWindow V.empty cursor 0 True)) + | otherwise -> fetchNamespaceWindow pool config cursor headPosition + case result of + Left err -> do + emit (KirokuEventSubscriptionDbError subName FetchBatch err groupCtx) + pure (if live then ConnectionLost cursor err else FetchFailed err) + Right window -> do + events <- decodeEvents stSettings (SQL.namespaceEvents window) + emit (KirokuEventSubscriptionFetched subName (decodedBatchLength events) groupCtx) + pure (NamespaceWindowFetched events (SQL.scannedThrough window) (SQL.exhausted window)) + + -- 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 _ + | LiveFromNamespaceNotify generation <- liveSource -> + namespaceInput False c generation + 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 + | decodedBatchLength events == 0 -> pure CaughtUp + | otherwise -> pure (BatchFetched events) + Live c -> case liveSource of + LiveFromPublisherQueue liveQueue statusVar -> 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 = filterDecodedBatch ((> c) . globalPosition) events + pure (if decodedBatchLength fresh == 0 then FetchEmpty else BatchFetched fresh) + LiveFromCategoryNotify cat -> + liveExitToInput =<< liveLoopCategoryNotify pool config stateVar catGenVar cat emit posRef c stSettings + LiveFromNamespaceNotify generation -> namespaceInput True c generation + LiveFromGroupPolling -> + 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 + case liveSource of + LiveFromPublisherQueue liveQueue statusVar -> do + atomically $ do + drainQueue liveQueue + writeTVar statusVar Pub.Active + pure QueueDrained + -- Defensive totality: only the queue branch can produce + -- QueueBackpressured, so DB-driven sources should never + -- enter Paused. + LiveFromCategoryNotify {} -> pure QueueDrained + LiveFromNamespaceNotify {} -> pure QueueDrained + LiveFromGroupPolling -> 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 _ + | LiveFromNamespaceNotify generation <- liveSource -> + namespaceInput False c generation + Reconnecting c _ -> do + writeIORef posRef c + fetchResult <- fetchBatch pool config c emit stSettings + case fetchResult of + Left err -> pure (FetchFailed err) + Right events + | decodedBatchLength events == 0 -> pure FetchEmpty + | otherwise -> pure (BatchFetched events) + -- Defensive totality: 'Retrying' is a surfaced observability state + -- that the delivery primitive writes into the state TVar and then + -- restores, so it is never a driving state reaching this function. + -- Mirror 'step''s defensive 'Retrying' clause, which returns to + -- 'Live' at the same cursor. + Retrying c _ -> nextInput (Live c) + 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 + DeliverNamespaceWindow events frontier done -> do + result <- + if decodedBatchLength events == 0 + then do + count <- readIORef (scanEmptyWindows namespaceScan) + writeIORef (scanEmptyWindows namespaceScan) (count + 1) + saved <- readIORef (scanSaved namespaceScan) + when (frontier > saved && (done || count + 1 >= 32)) $ do + success <- saveCheckpointResult pool config frontier emit + when success $ do + writeIORef (scanSaved namespaceScan) frontier + writeIORef (scanEmptyWindows namespaceScan) 0 + writeIORef posRef frontier + pure (Just frontier) + else processEventsWithCompletion (Just (frontier, (scanSaved namespaceScan))) pool config stateVar events emit posRef stSettings + case result of + Nothing -> Just . HandlerStopped <$> readIORef posRef + Just completed -> do + -- A nonempty window already attempted one tail save; remember + -- pending progress after failures for a later empty sweep. + when (decodedBatchLength events > 0) (writeIORef (scanEmptyWindows namespaceScan) 0) + when done (writeIORef (scanSweep namespaceScan) Nothing) + pure (Just (NamespaceWindowCompleted completed done)) + DeliverBatch events -> do + result <- processEvents pool config stateVar events emit posRef stSettings + 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 + StopUndecodable failure -> throwIO (SubscriptionUndecodable failure) + + lastPosOf events = globalPosition (decodedBatchLastEvent 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 -> do + position <- readIORef posRef + pure (ConnectionLost position 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 (\cg -> GroupMember (member cg) (size cg)) (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 + | Just (SubscriptionUndecodable failure) <- fromException e = StopUndecodable failure + | 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) + +configSize :: SubscriptionConfig -> Int32 +configSize config = maybe 1 size (consumerGroup config) + +-- Resolve the exact checkpoint key through the shared initializer. A database +-- error is emitted and rethrown so startup fails loudly. A semantic +-- 'FailIfMissing' result remains typed so the caller can emit the distinct +-- refusal event before throwing it. Each group member resolves its own key. +loadCheckpoint :: + Pool -> + SubscriptionConfig -> + (KirokuEvent -> IO ()) -> + IO (Either SubscriptionCheckpointMissing CheckpointInitialization) +loadCheckpoint pool config emit = do + let subName = name config + mem = configMember config + mHook <- readIORef loadCheckpointHookRef + injected <- maybe (pure Nothing) (\hook -> hook config) mHook + result <- case injected of + Just hooked -> pure (fmap (either (Left . SomeSubscriptionStartupFailure) (Right . (,False))) hooked) + Nothing -> + Pool.use pool $ + CheckpointSQL.initializeWorkerCheckpointSession + subName + mem + (configSize config) + (target config) + (targetBindingPolicy config) + (missingCheckpointPolicy config) + case result of + Left err -> do + emit (KirokuEventSubscriptionDbError subName LoadCheckpoint err (groupCtxOf config)) + throwIO err + Right (Left refusal@(SomeSubscriptionStartupFailure concrete)) -> + case fromException (toException concrete) of + Just missing -> pure (Left missing) + Nothing -> do + case fromException (toException concrete) of + Just mismatch -> emit (KirokuEventSubscriptionGroupSizeMismatch mismatch (groupCtxOf config)) + Nothing -> pure () + case fromException (toException concrete) of + Just mismatch -> emit (KirokuEventSubscriptionTargetMismatch mismatch (groupCtxOf config)) + Nothing -> pure () + throwIO refusal + Right (Right (resolution, adopted)) -> do + when adopted $ emit (KirokuEventSubscriptionTargetBound subName (target config) (groupCtxOf config)) + pure (Right resolution) + +-- 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 every `Category` subscription, plain or consumer-group. A +-- member cannot tell from a NOTIFY payload whether the stream is in its slice +-- (that is `hashtextextended(stream_id) % size = member`, a Postgres hash), but +-- it can gate on the category: the category generation advances on every append +-- to a stream of the category, a superset of the member's own streams, and +-- `fetchBatch` applies the partition predicate in SQL. So a member of an idle +-- category does no live database work while other categories are busy, and a +-- member whose sibling received the append does one empty fetch. +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) (decodedBatchLength events) (groupCtxOf config)) + if decodedBatchLength events == 0 + then pure (Right (Just c)) + else do + result <- processEvents pool config stateVar events emit posRef stSettings + case result of + Nothing -> pure (Right Nothing) -- handler said Stop + Just newPos -> drainTo newPos + +-- Phase 2: live (DB-driven, consumer-group members of AllStreams). 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) (decodedBatchLength events) (groupCtxOf config)) + if decodedBatchLength events == 0 + then pure (Right (Just c)) + else do + result <- processEvents pool config stateVar events emit posRef stSettings + 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 DecodedBatch) +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 + (_, CategoryNamespace _) -> error "namespace workers fetch bounded windows" + (Nothing, AllStreams) -> do + result <- Pool.use pool (Session.statement (pos, batchSizeValue (batchSize config)) SQL.readAllForwardStmt) + handle result + (Nothing, Category (CategoryName cat)) -> do + result <- Pool.use pool (Session.statement (pos, cat, batchSizeValue (batchSize config)) SQL.readCategoryForwardStmt) + handle result + (Just cg, AllStreams) -> do + let m = member cg; n = size cg + result <- Pool.use pool (Session.statement (pos, m, n, batchSizeValue (batchSize config)) SQL.readAllForwardConsumerGroupStmt) + handle result + (Just cg, Category (CategoryName cat)) -> do + let m = member cg; n = size cg + result <- Pool.use pool (Session.statement (pos, cat, m, n, batchSizeValue (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 + +-- Fetch only one bounded window. No request is made at/beyond the captured head. +fetchNamespaceWindow :: Pool -> SubscriptionConfig -> GlobalPosition -> GlobalPosition -> IO (Either Pool.UsageError SQL.NamespaceWindow) +fetchNamespaceWindow pool config cursor@(GlobalPosition position) headPosition@(GlobalPosition upper) = do + hook <- readIORef namespaceWindowHookRef + injected <- maybe (pure Nothing) (\f -> f config cursor headPosition) hook + case injected of + Just result -> pure result + Nothing -> case target config of + CategoryNamespace namespace -> + let width = min 1024 (batchSizeValue (batchSize config)) + in Pool.use pool $ case consumerGroup config of + Nothing -> Session.statement (position, upper, namespace, width) SQL.readNamespaceWindowStmt + Just cg -> Session.statement (position, upper, namespace, width, member cg, size cg) SQL.readNamespaceGroupWindowStmt + _ -> error "fetchNamespaceWindow requires a namespace target" + +-- 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 -> + DecodedBatch -> + (KirokuEvent -> IO ()) -> + IORef GlobalPosition -> + StoreSettings -> + IO (Maybe GlobalPosition) +processEvents = processEventsWithCompletion Nothing + +-- A fully resolved namespace window saves its completed scan frontier once. +-- Stop and atomic dead letters retain their per-event positions. +processEventsWithCompletion :: Maybe (GlobalPosition, IORef GlobalPosition) -> Pool -> SubscriptionConfig -> TVar SubscriptionState -> DecodedBatch -> (KirokuEvent -> IO ()) -> IORef GlobalPosition -> StoreSettings -> IO (Maybe GlobalPosition) +processEventsWithCompletion completion pool config stateVar batch emit posRef stSettings = do + driving <- atomically (readTVar stateVar) + let phase = case driving of + CatchingUp {} -> DeliveredCatchUp + _ -> DeliveredLive + emit (KirokuEventSubscriptionDelivered subName (decodedBatchLength batch) phase groupCtx) + -- Choose the vector representation once per batch. The unchanged arm walks + -- RecordedEvent directly, with no per-event Decoded/Undecodable allocation. + case batch of + UnchangedBatch events -> walk events id (\event pos -> deliver driving event pos 1) + TransformedBatch events -> walk events decodedEventRecorded (\event pos -> dispatch driving event pos 1) + where + subName = name config + groupCtx = groupCtxOf config + maxAttempts = retryMaxAttempts (retryPolicy config) + + walk :: Vector a -> (a -> RecordedEvent) -> (a -> GlobalPosition -> IO Bool) -> IO (Maybe GlobalPosition) + walk events rawOf consume = go 0 + where + go i + | i >= V.length events = do + let newPos = maybe (globalPosition (rawOf (V.last events))) fst completion + writeIORef posRef newPos + success <- saveCheckpointResult pool config newPos emit + when success $ case completion of + Nothing -> pure () + Just (_, saved) -> writeIORef saved newPos + pure (Just newPos) + | otherwise = do + let item = events V.! i + event = rawOf item + evtPos = globalPosition event + keepGoing <- + if shouldDeliver (eventTypeFilter config) (selector config) event + then consume item evtPos + else pure True + if keepGoing + then writeIORef posRef evtPos >> go (i + 1) + else pure Nothing + + deliver driving event evtPos attempt = do + writeIORef posRef evtPos + result <- handler config event + resolve driving event evtPos attempt result (deliver driving event evtPos (attempt + 1)) + + dispatch driving outcome evtPos attempt = case outcome of + Decoded event -> deliver driving event evtPos attempt + Undecodable raw failure -> case undecodableHandler config of + Nothing + | attempt >= maxAttempts -> throwIO (SubscriptionUndecodable failure) + | otherwise -> do + pause driving evtPos attempt (RetryDelay 1) + retryDecode driving raw evtPos (attempt + 1) + Just callback -> do + result <- callback raw failure + resolve driving raw evtPos attempt result (retryDecode driving raw evtPos (attempt + 1)) + + retryDecode driving raw evtPos attempt = do + outcome <- decodeEvent stSettings raw + -- walk already accepted the initial outcome. Recovery may rewrite its + -- type or payload; retain that decision throughout this delivery. + dispatch driving outcome evtPos attempt + + -- Ordinary and explicitly chosen undecodable dispositions share exactly + -- one checkpoint/dead-letter/retry resolver. The absent callback never + -- enters its exhausted-Retry dead-letter branch. + resolve driving event evtPos attempt result retry = case result of + Continue -> pure True + Stop -> do + writeIORef posRef evtPos + saveCheckpoint pool config evtPos emit + pure False + DeadLetter reason -> do + writeDeadLetter pool config evtPos event reason attempt emit + pure True + Retry delay + | attempt >= maxAttempts -> do + writeDeadLetter pool config evtPos event (DeadLetterMaxAttempts attempt) attempt emit + pure True + | otherwise -> pause driving evtPos attempt delay >> retry + + pause driving evtPos attempt delay = do + atomically (writeTVar stateVar (Retrying evtPos attempt)) + emit (KirokuEventSubscriptionRetrying subName evtPos attempt groupCtx) + threadDelay (retryDelayMicros delay) + atomically (writeTVar stateVar driving) + +-- 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 + (kind, category) = CheckpointSQL.targetColumns (Just (target config)) + EventId uuid = eventId event + params = + SQL.DeadLetterParams + { SQL.dlSubscriptionName = name', + SQL.dlMember = mem, + SQL.dlTargetKind = kind, + SQL.dlTargetCategory = category, + SQL.dlGroupSize = configSize config, + 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 position emit = do + _ <- saveCheckpointResult pool config position emit + pure () + +-- Failed empty-window flushes must remain pending rather than looking durable. +saveCheckpointResult :: Pool -> SubscriptionConfig -> GlobalPosition -> (KirokuEvent -> IO ()) -> IO Bool +saveCheckpointResult pool config position@(GlobalPosition pos) emit = do + let subName@(SubscriptionName name') = name config + mem = configMember config + mHook <- readIORef saveCheckpointHookRef + mapM_ (\hook -> hook config position) mHook + result <- Pool.use pool (CheckpointSQL.saveBoundCheckpointSession (target config) name' mem pos (configSize config)) + case result of + Left err -> emit (KirokuEventSubscriptionDbError subName SaveCheckpoint err (groupCtxOf config)) >> pure False + Right () -> pure True diff --git a/src/Kiroku/Store/Transaction.hs b/src/Kiroku/Store/Transaction.hs --- a/src/Kiroku/Store/Transaction.hs +++ b/src/Kiroku/Store/Transaction.hs @@ -1,46 +1,45 @@ -{- | 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. - -Replay-history leases and one-stream repair guards are exposed separately by -'Kiroku.Store.HistoryRetention' as @Tx.Transaction@ combinators. When composing -both in one body, acquire or renew the lease before taking the stream guard. -The transactional read deliberately bypasses the IO-only decode hook. - -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 +-- | 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. +-- +-- Replay-history leases and one-stream repair guards are exposed separately by +-- 'Kiroku.Store.HistoryRetention' as @Tx.Transaction@ combinators. When composing +-- both in one body, acquire or renew the lease before taking the stream guard. +-- The transactional read deliberately bypasses the IO-only decode hook. +-- +-- 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, @@ -61,7 +60,8 @@ -- * Append-precondition conflicts AppendConflict (..), appendConflictToStoreError, -) where + ) +where import Control.Lens ((^.)) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -79,295 +79,285 @@ 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 from both 'Tx.sql' scripts and 'Tx.statement' preserve PostgreSQL -SQLSTATE and message through 'UnexpectedServerError' or -'TransientTransactionFailure'. Event-ID duplicates retain 'DuplicateEvent'; -opaque bodies do not fabricate stream context for other constraints. -Connection failures use 'ConnectionLost', and pool acquisition timeouts use -'PoolAcquisitionTimeout'. Unsupported driver errors retain '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. --} +-- | 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 from both 'Tx.sql' scripts and 'Tx.statement' preserve PostgreSQL +-- SQLSTATE and message through 'UnexpectedServerError' or +-- 'TransientTransactionFailure'. Event-ID duplicates retain 'DuplicateEvent'; +-- opaque bodies do not fabricate stream context for other constraints. +-- Connection failures use 'ConnectionLost', and pool acquisition timeouts use +-- 'PoolAcquisitionTimeout'. Unsupported driver errors retain '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 + (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. Serialization -failures (@40001@) and deadlocks (@40P01@) surface as -'TransientTransactionFailure' with the original SQLSTATE and server message. -Use this entry point for a body that persistently raises those errors; the -retrying runner can keep re-executing it. --} +-- | Like 'runTransaction' but uses +-- 'Hasql.Transaction.Sessions.transactionNoRetry' — the body is executed +-- exactly once even on PostgreSQL serialization conflicts. Serialization +-- failures (@40001@) and deadlocks (@40P01@) surface as +-- 'TransientTransactionFailure' with the original SQLSTATE and server message. +-- Use this entry point for a body that persistently raises those errors; the +-- retrying runner can keep re-executing it. runTransactionNoRetry :: - (HasCallStack, Store :> es) => - Tx.Transaction a -> - Eff es a + (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'. --} +-- | 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. - -Lock-hold note: this append statement updates Kiroku's global @$all@ -stream row and PostgreSQL holds that row lock until the surrounding -transaction commits or rolls back. Any statements the caller runs -after a successful 'appendToStreamTx' keep that global append lock -held, blocking other appends store-wide. Prefer the higher-level -'runTransactionAppending' wrappers unless you need custom transaction -shaping; when using this function directly, run any append-independent -work before calling it. - -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. This function returns -@'Left' ('EmptyAppendBatchConflict' …)@ without dispatching a statement; -the high-level @runTransactionAppending*@ wrappers return -@'Left' ('EmptyAppendBatch' …)@ before opening a transaction. --} +-- | 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. +-- +-- Lock-hold note: this append statement updates Kiroku's global @$all@ +-- stream row and PostgreSQL holds that row lock until the surrounding +-- transaction commits or rolls back. Any statements the caller runs +-- after a successful 'appendToStreamTx' keep that global append lock +-- held, blocking other appends store-wide. Prefer the higher-level +-- 'runTransactionAppending' wrappers unless you need custom transaction +-- shaping; when using this function directly, run any append-independent +-- work before calling it. +-- +-- 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. This function returns +-- @'Left' ('EmptyAppendBatchConflict' …)@ without dispatching a statement; +-- the high-level @runTransactionAppending*@ wrappers return +-- @'Left' ('EmptyAppendBatch' …)@ before opening a transaction. appendToStreamTx :: - StreamName -> - ExpectedVersion -> - [PreparedEvent] -> - UTCTime -> - Tx.Transaction (Either AppendConflict AppendResult) + StreamName -> + ExpectedVersion -> + [PreparedEvent] -> + UTCTime -> + Tx.Transaction (Either AppendConflict AppendResult) appendToStreamTx sn@(StreamName name) expected prepared now = do - case prepared of - [] -> - pure (Left (EmptyAppendBatchConflict sn)) - _ -> do - let params = buildAppendParams name now prepared - mResult <- appendDispatchTx expected params - pure $ case mResult of - Just r -> Right r - Nothing -> Left (emptyResultConflict sn expected) + case prepared of + [] -> + pure (Left (EmptyAppendBatchConflict sn)) + _ -> 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 name is invalid (reserved @$all@ or longer than - 'Kiroku.Store.Error.maxStreamNameBytes'), the call rejects with - @'Left'@ /before/ opening any transaction; the continuation is not - invoked. -* If the event list is empty, the call rejects with - @'Left' ('EmptyAppendBatch' …)@ /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. - -Lock-hold guidance: - -* The append updates Kiroku's global @$all@ stream row. PostgreSQL - holds that row lock until this transaction commits or rolls back. -* The continuation runs /after/ the append, so every SQL statement it - executes extends the interval during which all other appends in the - store are blocked on the @$all@ row. -* Keep the continuation minimal: pre-compute values before entering - the transaction, avoid unbounded loops or per-row work that could - have been batched, and never wait on external systems. A - 'Tx.Transaction' cannot perform arbitrary 'IO', but it can still - contain many database round trips. -* Work that does not need the new 'AppendResult' should run before the - append, either outside this wrapper or in a custom 'runTransaction' - body that calls 'appendToStreamTx' last. - -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. --} +-- | 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 name is invalid (reserved @$all@ or longer than +-- 'Kiroku.Store.Error.maxStreamNameBytes'), the call rejects with +-- @'Left'@ /before/ opening any transaction; the continuation is not +-- invoked. +-- * If the event list is empty, the call rejects with +-- @'Left' ('EmptyAppendBatch' …)@ /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. +-- +-- Lock-hold guidance: +-- +-- * The append updates Kiroku's global @$all@ stream row. PostgreSQL +-- holds that row lock until this transaction commits or rolls back. +-- * The continuation runs /after/ the append, so every SQL statement it +-- executes extends the interval during which all other appends in the +-- store are blocked on the @$all@ row. +-- * Keep the continuation minimal: pre-compute values before entering +-- the transaction, avoid unbounded loops or per-row work that could +-- have been batched, and never wait on external systems. A +-- 'Tx.Transaction' cannot perform arbitrary 'IO', but it can still +-- contain many database round trips. +-- * Work that does not need the new 'AppendResult' should run before the +-- append, either outside this wrapper or in a custom 'runTransaction' +-- body that calls 'appendToStreamTx' last. +-- +-- 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) + (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 and for the -@$all@ lock-hold warning that applies equally here. --} +-- | 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 and for the +-- @$all@ lock-hold warning that applies equally here. runTransactionAppendingNoRetry :: - (HasCallStack, IOE :> es, Store :> es) => - StreamName -> - ExpectedVersion -> - [EventData] -> - (AppendResult -> Tx.Transaction a) -> - Eff es (Either StoreError a) + (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. The continuation still runs -after the append; see 'runTransactionAppending' for the @$all@ -lock-hold warning and keep resource-aware continuations just as small. --} +-- | 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. The continuation still runs +-- after the append; see 'runTransactionAppending' for the @$all@ +-- lock-hold warning and keep resource-aware continuations just as small. runTransactionAppendingResource :: - (HasCallStack, IOE :> es, KirokuStoreResource :> es, Store :> es) => - StreamName -> - ExpectedVersion -> - [EventData] -> - (AppendResult -> Tx.Transaction a) -> - Eff es (Either StoreError a) + (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 + store <- getKirokuStore + events' <- liftIO $ enrichEventsIO store events + runTransactionAppendingWith RunTransaction sn expected events' k -{- | Like 'runTransactionAppendingResource' but uses -'Hasql.Transaction.Sessions.transactionNoRetry' under the hood. The -@$all@ lock-hold guidance from 'runTransactionAppending' applies -unchanged. --} +-- | Like 'runTransactionAppendingResource' but uses +-- 'Hasql.Transaction.Sessions.transactionNoRetry' under the hood. The +-- @$all@ lock-hold guidance from 'runTransactionAppending' applies +-- unchanged. runTransactionAppendingResourceNoRetry :: - (HasCallStack, IOE :> es, KirokuStoreResource :> es, Store :> es) => - StreamName -> - ExpectedVersion -> - [EventData] -> - (AppendResult -> Tx.Transaction a) -> - Eff es (Either StoreError a) + (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. + store <- getKirokuStore + events' <- liftIO $ enrichEventsIO store events + runTransactionAppendingWith RunTransactionNoRetry sn expected events' k -When 'Kiroku.Store.Settings.enrichEvent' is 'Nothing' the function -returns the input list unchanged with no traversal. --} +-- | 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. --} +-- | 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) + (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 _) expected events k - | Left err <- validateStreamName sn = pure (Left err) - | null events = pure (Left (EmptyAppendBatch 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) + | Left err <- validateStreamName sn = pure (Left err) + | null events = pure (Left (EmptyAppendBatch 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 --- a/src/Kiroku/Store/Types.hs +++ b/src/Kiroku/Store/Types.hs @@ -1,5 +1,5 @@ -module Kiroku.Store.Types ( - StreamName (..), +module Kiroku.Store.Types + ( StreamName (..), StreamId (..), EventId (..), EventType (..), @@ -19,7 +19,8 @@ BrowsePageSizeError (..), mkBrowsePageSize, browsePageSizeValue, -) where + ) +where import Data.Aeson (Value) import Data.Int (Int32, Int64) @@ -31,330 +32,294 @@ -- 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. --} +-- | 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) + 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. --} +-- | 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) + 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'. --} +-- | 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) + 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. --} +-- | 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) + 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). --} +-- | 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) + deriving stock (Eq, Ord, Show, Generic) -{- | Global position of an event in the @$all@ ordering, shared across all -streams. __Contract:__ strictly increasing per successful append, and totally -ordered — nothing more. Treat values as opaque cursors: construct a -'GlobalPosition' only from @0@ (the beginning of the store) or from a value -previously returned by this store; never derive one by arithmetic, and never -assume positions are dense (@pos + 1@ may not exist). The current -implementation happens to assign contiguous positions (see EP-1's audit), but -contiguity is an implementation detail, not an API guarantee, and is the part -that would change under a sequence-based allocation scheme — see -docs/architecture/global-position-migration-path.md. Used by the @$all@ read -path and by subscriptions as the cursor key. --} +-- | Global position of an event in the @$all@ ordering, shared across all +-- streams. __Contract:__ strictly increasing per successful append, and totally +-- ordered — nothing more. Treat values as opaque cursors: construct a +-- 'GlobalPosition' only from @0@ (the beginning of the store) or from a value +-- previously returned by this store; never derive one by arithmetic, and never +-- assume positions are dense (@pos + 1@ may not exist). The current +-- implementation happens to assign contiguous positions (see EP-1's audit), but +-- contiguity is an implementation detail, not an API guarantee, and is the part +-- that would change under a sequence-based allocation scheme — see +-- docs/architecture/global-position-migration-path.md. 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. + deriving stock (Eq, Ord, Show, Generic) -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. --} +-- | 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. + = -- | 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) -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'. --} +-- | 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'. + { -- | '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). + eventId :: !(Maybe EventId), + -- | Application-level discriminator. Free-form; the store does not + -- interpret it but it is indexed for queries. + eventType :: !EventType, + -- | The event's JSONB payload. + payload :: !Value, + -- | Optional JSONB metadata. Often used for tenant ids, trace + -- contexts, and correlation data. + metadata :: !(Maybe Value), + -- | Optional id of the event that caused this one (the immediate + -- cause). Used to reconstruct chains. + causationId :: !(Maybe UUID), + -- | Optional correlation id (the saga / transaction this event + -- belongs to). Distinct from @causationId@. + correlationId :: !(Maybe UUID) + } + deriving stock (Show, Generic) -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. --} +-- | 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. - -} - , truncateBefore :: !StreamVersion - {- ^ The logical truncate-before marker. Ordered per-stream reads - ('Kiroku.Store.Read.readStreamForward' / 'readStreamBackward') return only - events whose per-stream version is >= this value. 0 (the default) keeps the - whole stream. Does not affect the @$all@ global log, category reads, or - subscriptions. Set with 'Kiroku.Store.Lifecycle.setStreamTruncateBefore'. - -} - } - deriving stock (Eq, Show, Generic) - -{- | What comes back from reading events. + { -- | The stream's database surrogate id. Stable for the row's + -- lifetime. + id :: !StreamId, + -- | The stream's human-readable name as supplied at creation. + name :: !StreamName, + -- | The stream's current version (count of appended events). + version :: !StreamVersion, + -- | When the stream row was first inserted. + createdAt :: !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. + deletedAt :: !(Maybe UTCTime), + -- | The logical truncate-before marker. Ordered per-stream reads + -- ('Kiroku.Store.Read.readStreamForward' / 'readStreamBackward') return only + -- events whose per-stream version is >= this value. 0 (the default) keeps the + -- whole stream. Does not affect the @$all@ global log, category reads, or + -- subscriptions. Set with 'Kiroku.Store.Lifecycle.setStreamTruncateBefore'. + truncateBefore :: !StreamVersion + } + deriving stock (Eq, Show, Generic) -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. --} +-- | 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) + { -- | The event's stable id (UUIDv7 by default). + eventId :: !EventId, + -- | The application-level type discriminator. + eventType :: !EventType, + -- | 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. + streamVersion :: !StreamVersion, + -- | Position in the global @$all@ sequence at original-append time. + -- Stable across links; used as the subscription cursor. + globalPosition :: !GlobalPosition, + -- | 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'. + originalStreamId :: !StreamId, + -- | The position the event was assigned in its source stream. + originalVersion :: !StreamVersion, + 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. + { -- | The id of the stream that was appended to (created if it did + -- not exist). + streamId :: !StreamId, + -- | The stream's version after the append (the position of the + -- /last/ event in the batch). + streamVersion :: !StreamVersion, + -- | The global position assigned to the /last/ event in the batch. + globalPosition :: !GlobalPosition + } + deriving stock (Eq, Show, Generic) -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. --} +-- | 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 id of the link target (created if it did not exist). + streamId :: !StreamId, + -- | The target's version after the link (position of the /last/ + -- linked event in the target). + streamVersion :: !StreamVersion + } + 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. --} +-- | 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) - -{- | The category of a stream name: the substring before the first @-@. This -is the canonical Haskell mirror of the -@streams.category GENERATED ALWAYS AS split_part(stream_name,'-',1)@ column and -of the category rule used by 'Kiroku.Store.Read.readCategory' and -category-targeted subscriptions. A category never contains @-@, so this is -exact. - ->>> categoryName (StreamName "orders-1") -CategoryName "orders" - -A name without a dash is its own category: + deriving stock (Eq, Ord, Show, Generic) ->>> categoryName (StreamName "singleton") -CategoryName "singleton" --} +-- | The category of a stream name: the substring before the first @-@. This +-- is the canonical Haskell mirror of the +-- @streams.category GENERATED ALWAYS AS split_part(stream_name,'-',1)@ column and +-- of the category rule used by 'Kiroku.Store.Read.readCategory' and +-- category-targeted subscriptions. A category never contains @-@, so this is +-- exact. +-- +-- >>> categoryName (StreamName "orders-1") +-- CategoryName "orders" +-- +-- A name without a dash is its own category: +-- +-- >>> categoryName (StreamName "singleton") +-- CategoryName "singleton" categoryName :: StreamName -> CategoryName categoryName (StreamName t) = CategoryName (Text.takeWhile (/= '-') t) -{- | Build the stream name for a category and an id segment, i.e. -@\-\@. The dual of 'categoryName': for any dash-free category, -@'categoryName' ('streamNameInCategory' cat seg) == cat@. - -This is permissive — it does not reject a hyphenated 'CategoryName' or an empty -segment (the store accepts such names); opinionated validation is the caller's -concern. - ->>> streamNameInCategory (CategoryName "orders") "1" -StreamName "orders-1" --} +-- | Build the stream name for a category and an id segment, i.e. +-- @\-\@. The dual of 'categoryName': for any dash-free category, +-- @'categoryName' ('streamNameInCategory' cat seg) == cat@. +-- +-- This is permissive — it does not reject a hyphenated 'CategoryName' or an empty +-- segment (the store accepts such names); opinionated validation is the caller's +-- concern. +-- +-- >>> streamNameInCategory (CategoryName "orders") "1" +-- StreamName "orders-1" streamNameInCategory :: CategoryName -> Text -> StreamName streamNameInCategory (CategoryName cat) seg = StreamName (cat <> "-" <> seg) -{- | 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. --} +-- | 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) + = -- | 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) -{- | Validated catalog page size: 1–1001, including one HTTP over-fetch row. -The constructor is private; arithmetic on untrusted limits cannot overflow. --} +-- | Validated catalog page size: 1–1001, including one HTTP over-fetch row. +-- The constructor is private; arithmetic on untrusted limits cannot overflow. newtype BrowsePageSize = BrowsePageSize Int32 - deriving stock (Eq, Show) + deriving stock (Eq, Show) data BrowsePageSizeError = InvalidBrowsePageSize !Int - deriving stock (Eq, Show) + deriving stock (Eq, Show) mkBrowsePageSize :: Int -> Either BrowsePageSizeError BrowsePageSize mkBrowsePageSize n - | n >= 1 && n <= 1001 = Right (BrowsePageSize (fromIntegral n)) - | otherwise = Left (InvalidBrowsePageSize n) + | n >= 1 && n <= 1001 = Right (BrowsePageSize (fromIntegral n)) + | otherwise = Left (InvalidBrowsePageSize n) browsePageSizeValue :: BrowsePageSize -> Int32 browsePageSizeValue (BrowsePageSize n) = n diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -45,2189 +45,2193 @@ import Test.HistoryRetentionMock qualified as HistoryRetentionMock import Test.Hspec import Test.InterpreterHooks qualified as InterpreterHooks -import Test.NotifyGuard qualified as NotifyGuard -import Test.PerformanceStructure qualified as PerformanceStructure -import Test.Properties qualified as Properties -import Test.PublisherCallbackResilience qualified as PublisherCallbackResilience -import Test.PublisherDropCounter qualified as PublisherDropCounter -import Test.PublisherIdleAdvance qualified as PublisherIdleAdvance -import Test.PublisherRestartNoRebroadcast qualified as PublisherRestartNoRebroadcast -import Test.ReadStream qualified as ReadStream -import Test.ScriptSessionErrors qualified as ScriptSessionErrors -import Test.StartupFailureSurfacing qualified as StartupFailureSurfacing -import Test.StreamBridgeTermination qualified as StreamBridgeTermination -import Test.StreamHead qualified as StreamHead -import Test.StreamHeadIsolation qualified as StreamHeadIsolation -import Test.StreamHeadMock qualified as StreamHeadMock -import Test.StreamHistoryGuard qualified as StreamHistoryGuard -import Test.StreamNameLookup qualified as StreamNameLookup -import Test.SubscriptionCheckpointInitialization qualified as SubscriptionCheckpointInitialization -import Test.SubscriptionCheckpointInitializationMock qualified as SubscriptionCheckpointInitializationMock -import Test.SubscriptionCheckpointInventory qualified as SubscriptionCheckpointInventory -import Test.SubscriptionCheckpointInventoryMock qualified as SubscriptionCheckpointInventoryMock -import Test.SubscriptionCheckpointReset qualified as SubscriptionCheckpointReset -import Test.SubscriptionCheckpointWorker qualified as SubscriptionCheckpointWorker -import Test.SubscriptionDeadLetters qualified as SubscriptionDeadLetters -import Test.SubscriptionDeadLettersMock qualified as SubscriptionDeadLettersMock -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.SubscriptionTarget qualified as SubscriptionTarget -import Test.Transaction qualified as Transaction -import Test.TruncateBefore qualified as TruncateBefore -import Test.UniqueViolationMapping qualified as UniqueViolationMapping -import Test.VisibleGlobalHeadPosition qualified as VisibleGlobalHeadPosition -import Test.VisibleGlobalHeadPositionMock qualified as VisibleGlobalHeadPositionMock - -main :: IO () -main = withSharedMigratedPostgres $ hspec $ do - BrowseReads.spec - BrowseReadsMock.spec - SubscriptionDeadLetters.spec - SubscriptionDeadLettersMock.spec - UniqueViolationMapping.spec - SubscriptionTarget.spec - Category.spec - Properties.spec - Concurrency.spec - FailureInjection.spec - HistoryRetention.spec - HistoryRetentionMock.spec - Transaction.spec - ScriptSessionErrors.spec - TruncateBefore.spec - ReadStream.spec - StreamNameLookup.spec - StreamBridgeTermination.spec - StreamHistoryGuard.spec - InterpreterHooks.spec - Causation.spec - ConsumerGroupSql.spec - ConsumerGroupResize.spec - ConsumerGroup.spec - ConsumerGroupEffect.spec - describe "performance structure" $ do - BrowseQueryPlans.spec - StreamHeadIsolation.spec - PerformanceStructure.spec - NotifyGuard.spec - StreamNameLookup.noOpSpec - CategoryIdleNoSpin.spec - HandlerStall.spec - PublisherCallbackResilience.spec - PublisherDropCounter.spec - PublisherIdleAdvance.spec - PublisherRestartNoRebroadcast.spec - CatchupDbErrorNoPrematureSwitch.spec - SubscriptionPauseResume.spec - SubscriptionCheckpointInitialization.spec - SubscriptionCheckpointInitializationMock.spec - SubscriptionCheckpointWorker.spec - SubscriptionCheckpointInventory.spec - SubscriptionCheckpointInventoryMock.spec - SubscriptionCheckpointReset.spec - SubscriptionReconnect.spec - StartupFailureSurfacing.spec - SubscriptionState.spec - SubscriptionRegistry.spec - SubscriptionRetryDeadLetter.spec - EventTypeFilter.spec - StreamHead.spec - StreamHeadMock.spec - VisibleGlobalHeadPosition.spec - VisibleGlobalHeadPositionMock.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 "empty event batches" $ do - it "rejects NoStream without creating a phantom stream or advancing $all" $ \store -> do - Right allBefore <- runStoreIO store $ readAllForward (GlobalPosition 0) 10 - result <- runStoreIO store $ appendToStream (StreamName "empty-nostream") NoStream [] - result `shouldBe` Left (EmptyAppendBatch (StreamName "empty-nostream")) - runStoreIO store (getStream (StreamName "empty-nostream")) `shouldReturn` Right Nothing - Right allAfter <- runStoreIO store $ readAllForward (GlobalPosition 0) 10 - fmap (^. #globalPosition) (V.toList allAfter) `shouldBe` fmap (^. #globalPosition) (V.toList allBefore) - - it "rejects empty batches for existing-stream expectations without changing version" $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "empty-existing") NoStream [makeEvent "Created" (Aeson.object [])] - let assertEmptyRejected expected = do - result <- runStoreIO store $ appendToStream (StreamName "empty-existing") expected [] - result `shouldBe` Left (EmptyAppendBatch (StreamName "empty-existing")) - Right (Just info) <- runStoreIO store $ getStream (StreamName "empty-existing") - (info ^. #version) `shouldBe` StreamVersion 1 - assertEmptyRejected (ExactVersion (StreamVersion 1)) - assertEmptyRejected StreamExists - assertEmptyRejected AnyVersion - - it "rejects an empty per-stream batch in appendMultiStream without committing any stream" $ \store -> do - let ok = StreamName "empty-multi-ok" - bad = StreamName "empty-multi-bad" - result <- - runStoreIO store $ - appendMultiStream - [ (ok, NoStream, [makeEvent "Created" (Aeson.object [])]) - , (bad, NoStream, []) - ] - result `shouldBe` Left (EmptyAppendBatch bad) - runStoreIO store (getStream ok) `shouldReturn` Right Nothing - runStoreIO store (getStream bad) `shouldReturn` Right Nothing - - it "treats an empty appendMultiStream operation list as a no-op" $ \store -> do - result <- runStoreIO store $ appendMultiStream [] - result `shouldBe` Right [] - - 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 "returns the caller event id on same-stream retry and leaves one stored event" $ \store -> do - let eid = EventId (UUID.fromWords 0x01234567 0x89ab7def 0x80123456 0x7890abcd) - event = makeEvent "Created" (Aeson.object []) & #eventId .~ Just eid - stream = StreamName "same-stream-duplicate" - Right _ <- runStoreIO store $ appendToStream stream NoStream [event] - forM_ [AnyVersion, StreamExists, ExactVersion (StreamVersion 1)] $ \expected -> do - result <- runStoreIO store $ appendToStream stream expected [event] - result `shouldBe` Left (DuplicateEvent (Just eid)) - countEvents store `shouldReturn` 1 - Right stored <- runStoreIO store $ readStreamForward stream (StreamVersion 0) 100 - Right global <- runStoreIO store $ readAllForward (GlobalPosition 0) 100 - map (\e -> e ^. #eventId) (V.toList stored) `shouldBe` [eid] - map (\e -> e ^. #eventId) (V.toList global) `shouldBe` [eid] - Right info <- runStoreIO store $ getStream stream - fmap (\s -> s ^. #version) info `shouldBe` Just (StreamVersion 1) - - 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" - - it "rejects stream names longer than 512 UTF-8 bytes before creating streams" $ \store -> do - let overAscii = StreamName (T.replicate 513 "a") - overUtf8 = StreamName (T.replicate 171 (T.singleton '\12354')) - assertTooLong sn = do - result <- runStoreIO store $ appendToStream sn NoStream [makeEvent "TooLong" (Aeson.object [])] - result `shouldBe` Left (StreamNameTooLong sn 513) - runStoreIO store (getStream sn) `shouldReturn` Right Nothing - assertTooLong overAscii - assertTooLong overUtf8 - - it "rejects oversized link targets without creating the target stream" $ \store -> do - let over = StreamName (T.replicate 513 "l") - Right _ <- runStoreIO store $ appendToStream (StreamName "length-link-source") NoStream [makeEvent "Source" (Aeson.object [])] - Right events <- runStoreIO store $ readStreamForward (StreamName "length-link-source") (StreamVersion 0) 10 - let eid = V.head events ^. #eventId - result <- runStoreIO store $ linkToStream over [eid] - result `shouldBe` Left (StreamNameTooLong over 513) - runStoreIO store (getStream over) `shouldReturn` Right Nothing - - it "rejects oversized multi-stream targets without partial commit" $ \store -> do - let ok = StreamName "length-multi-ok" - over = StreamName (T.replicate 513 "m") - result <- - runStoreIO store $ - appendMultiStream - [ (ok, NoStream, [makeEvent "ShouldRollback" (Aeson.object [])]) - , (over, NoStream, [makeEvent "TooLong" (Aeson.object [])]) - ] - result `shouldBe` Left (StreamNameTooLong over 513) - runStoreIO store (getStream ok) `shouldReturn` Right Nothing - runStoreIO store (getStream over) `shouldReturn` Right Nothing - - it "accepts a 512-byte stream name" $ \store -> do - let exact = StreamName (T.replicate 512 "e") - result <- runStoreIO store $ appendToStream exact NoStream [makeEvent "ExactLength" (Aeson.object [])] - case result of - Right r -> (r ^. #streamVersion) `shouldBe` StreamVersion 1 - Left err -> expectationFailure ("Expected 512-byte stream name to append, got: " <> show err) - - 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 - - it "paginates backward using stream version as an exclusive cursor" $ \store -> do - let events = map (\i -> makeEvent ("E" <> T.pack (show i)) (Aeson.object [])) [1 .. 5 :: Int] - Right _ <- runStoreIO store $ appendToStream (StreamName "read-bwd-page") NoStream events - - Right page1 <- runStoreIO store $ readStreamBackward (StreamName "read-bwd-page") (StreamVersion 0) 2 - fmap (^. #streamVersion) (V.toList page1) `shouldBe` [StreamVersion 5, StreamVersion 4] - - let cursor1 = V.last page1 ^. #streamVersion - Right page2 <- runStoreIO store $ readStreamBackward (StreamName "read-bwd-page") cursor1 2 - fmap (^. #streamVersion) (V.toList page2) `shouldBe` [StreamVersion 3, StreamVersion 2] - - let cursor2 = V.last page2 ^. #streamVersion - Right page3 <- runStoreIO store $ readStreamBackward (StreamName "read-bwd-page") cursor2 2 - fmap (^. #streamVersion) (V.toList page3) `shouldBe` [StreamVersion 1] - - Right page4 <- runStoreIO store $ readStreamBackward (StreamName "read-bwd-page") (V.last page3 ^. #streamVersion) 2 - V.length page4 `shouldBe` 0 - - 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" - - it "paginates backward using global position as an exclusive cursor" $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "allb-page-s1") NoStream [makeEvent "X" (Aeson.object [])] - Right _ <- runStoreIO store $ appendToStream (StreamName "allb-page-s2") NoStream [makeEvent "Y" (Aeson.object [])] - Right _ <- runStoreIO store $ appendToStream (StreamName "allb-page-s3") NoStream [makeEvent "Z" (Aeson.object [])] - - Right page1 <- runStoreIO store $ readAllBackward (GlobalPosition 0) 2 - fmap (^. #globalPosition) (V.toList page1) `shouldBe` [GlobalPosition 3, GlobalPosition 2] - - Right page2 <- runStoreIO store $ readAllBackward (GlobalPosition 2) 2 - fmap (^. #globalPosition) (V.toList page2) `shouldBe` [GlobalPosition 1] - - Right page3 <- runStoreIO store $ readAllBackward (GlobalPosition 1) 2 - V.length page3 `shouldBe` 0 - - 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 (EventAlreadyLinked (StreamName "linked-dup") mEid) -> - mEid `shouldBe` Just eid - Left err -> expectationFailure ("Expected EventAlreadyLinked, got: " <> show err) - 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 (LinkSourceEventMissing (StreamName "f3-bogus")) -> pure () - Left err -> expectationFailure ("Expected LinkSourceEventMissing, got: " <> show err) - 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 (LinkSourceEventMissing (StreamName "f3-mixed-tgt")) -> pure () - Left err -> expectationFailure ("Expected LinkSourceEventMissing, got: " <> show err) - 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 - countBefore <- countEvents store - Right _ <- runStoreIO store $ hardDeleteStream (StreamName "f1-orphan") - countAfter <- countEvents store - (countBefore - countAfter) `shouldBe` 3 - - it "removes dead letters for orphaned events before deleting their payloads" $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "dl-hard-source") NoStream [makeEvent "DeadLettered" (Aeson.object [])] - Right events <- runStoreIO store $ readStreamForward (StreamName "dl-hard-source") (StreamVersion 0) 10 - let event = V.head events - eid = event ^. #eventId - insertDeadLetterForEvent store "dl-hard-subscription" event - countDeadLettersForEvents store [eid] `shouldReturn` 1 - - Right mId <- runStoreIO store $ hardDeleteStream (StreamName "dl-hard-source") - mId `shouldSatisfy` (/= Nothing) - countDeadLettersForEvents store [eid] `shouldReturn` 0 - Right remaining <- runStoreIO store $ readAllForward (GlobalPosition 0) 100 - V.filter (\recorded -> (recorded ^. #eventId) == eid) remaining `shouldBe` V.empty - - it "keeps dead letters for linked-in events that survive a hard delete" $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "dl-origin") NoStream [makeEvent "Survivor" (Aeson.object [])] - Right originEvents <- runStoreIO store $ readStreamForward (StreamName "dl-origin") (StreamVersion 0) 10 - let event = V.head originEvents - eid = event ^. #eventId - Right _ <- runStoreIO store $ linkToStream (StreamName "dl-link-target") [eid] - insertDeadLetterForEvent store "dl-survivor-subscription" event - countDeadLettersForEvents store [eid] `shouldReturn` 1 - - Right _ <- runStoreIO store $ hardDeleteStream (StreamName "dl-link-target") - countDeadLettersForEvents store [eid] `shouldReturn` 1 - Right afterTargetDelete <- runStoreIO store $ readStreamForward (StreamName "dl-origin") (StreamVersion 0) 10 - fmap (^. #eventId) (V.toList afterTargetDelete) `shouldBe` [eid] - - Right _ <- runStoreIO store $ hardDeleteStream (StreamName "dl-origin") - countDeadLettersForEvents store [eid] `shouldReturn` 0 - Right afterOriginDelete <- runStoreIO store $ readAllForward (GlobalPosition 0) 100 - V.filter (\recorded -> (recorded ^. #eventId) == eid) afterOriginDelete `shouldBe` V.empty - - -- 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = either (error . show) Prelude.id (mkBatchSize 2) - , queueCapacity = 32 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = either (error . show) Prelude.id (mkBatchSize 2) - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , -- 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 - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 1 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , retryPolicy = defaultRetryPolicy - , eventTypeFilter = AllEventTypes - , selector = Nothing - } - handle <- subscribe store cfg - -- This fixture requires a live handler; catch-up could otherwise - -- consume the queued range before observing overflow. - let awaitLive = do - st <- currentState handle - case st of - Just Fsm.Live{} -> pure () - _ -> threadDelay 1_000 >> awaitLive - Async.race (threadDelay 5_000_000) awaitLive >>= (`shouldBe` Right ()) - -- 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 - - describe "isTransientSerializationError" $ do - let serverUsage code = - SessionUsageError $ - Errors.StatementSessionError - 1 - 0 - "" - [] - True - ( Errors.ServerStatementError $ - Errors.ServerError code "server error" Nothing Nothing Nothing - ) - it "recognizes only serialization and deadlock SQLSTATEs" $ do - isTransientSerializationError (serverUsage "40P01") `shouldBe` True - isTransientSerializationError (serverUsage "40001") `shouldBe` True - isTransientSerializationError (serverUsage "23505") `shouldBe` False - isTransientSerializationError AcquisitionTimeoutUsageError `shouldBe` False - - -- The store retries an append once on these codes, so a caller only - -- sees one when the conflict repeated. It must arrive as the retryable - -- constructor: 'UnexpectedServerError' documents itself as "not - -- generally retryable — investigate", which would send a caller to - -- diagnose a condition whose correct handling is to retry. - it "maps both transient SQLSTATEs to TransientTransactionFailure" $ do - forM_ ["40001", "40P01"] $ \code -> do - mapUsageError "orders-1" AnyVersion (serverUsage code) - `shouldBe` TransientTransactionFailure code "server error" - mapGenericUsageError (serverUsage code) - `shouldBe` TransientTransactionFailure code "server error" - mapTransactionUsageError (serverUsage code) - `shouldBe` TransientTransactionFailure code "server error" - mapLinkUsageError (StreamName "orders-1") (serverUsage code) - `shouldBe` TransientTransactionFailure code "server error" - attributeMultiStreamError - [(StreamName "orders-1", AnyVersion)] - (serverUsage code) - `shouldBe` TransientTransactionFailure code "server error" - - it "leaves non-transient server codes on UnexpectedServerError" $ do - mapGenericUsageError (serverUsage "42883") - `shouldBe` UnexpectedServerError "42883" "server error" - - -- ================================================================= - -- 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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"] +import Test.NamespaceQueryPlans qualified as NamespaceQueryPlans +import Test.NotifyGuard qualified as NotifyGuard +import Test.PerformanceStructure qualified as PerformanceStructure +import Test.Properties qualified as Properties +import Test.PublisherCallbackResilience qualified as PublisherCallbackResilience +import Test.PublisherDropCounter qualified as PublisherDropCounter +import Test.PublisherIdleAdvance qualified as PublisherIdleAdvance +import Test.PublisherRestartNoRebroadcast qualified as PublisherRestartNoRebroadcast +import Test.ReadStream qualified as ReadStream +import Test.ScriptSessionErrors qualified as ScriptSessionErrors +import Test.StartupFailureSurfacing qualified as StartupFailureSurfacing +import Test.StreamBridgeTermination qualified as StreamBridgeTermination +import Test.StreamHead qualified as StreamHead +import Test.StreamHeadIsolation qualified as StreamHeadIsolation +import Test.StreamHeadMock qualified as StreamHeadMock +import Test.StreamHistoryGuard qualified as StreamHistoryGuard +import Test.StreamNameLookup qualified as StreamNameLookup +import Test.SubscriptionCheckpointInitialization qualified as SubscriptionCheckpointInitialization +import Test.SubscriptionCheckpointInitializationMock qualified as SubscriptionCheckpointInitializationMock +import Test.SubscriptionCheckpointInventory qualified as SubscriptionCheckpointInventory +import Test.SubscriptionCheckpointInventoryMock qualified as SubscriptionCheckpointInventoryMock +import Test.SubscriptionCheckpointReset qualified as SubscriptionCheckpointReset +import Test.SubscriptionCheckpointWorker qualified as SubscriptionCheckpointWorker +import Test.SubscriptionDeadLetters qualified as SubscriptionDeadLetters +import Test.SubscriptionDeadLettersMock qualified as SubscriptionDeadLettersMock +import Test.SubscriptionNamespace qualified as SubscriptionNamespace +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.SubscriptionTarget qualified as SubscriptionTarget +import Test.Transaction qualified as Transaction +import Test.TruncateBefore qualified as TruncateBefore +import Test.UniqueViolationMapping qualified as UniqueViolationMapping +import Test.VisibleGlobalHeadPosition qualified as VisibleGlobalHeadPosition +import Test.VisibleGlobalHeadPositionMock qualified as VisibleGlobalHeadPositionMock + +main :: IO () +main = withSharedMigratedPostgres $ hspec $ do + BrowseReads.spec + BrowseReadsMock.spec + SubscriptionDeadLetters.spec + SubscriptionDeadLettersMock.spec + UniqueViolationMapping.spec + SubscriptionTarget.spec + SubscriptionNamespace.spec + NamespaceQueryPlans.spec + Category.spec + Properties.spec + Concurrency.spec + FailureInjection.spec + HistoryRetention.spec + HistoryRetentionMock.spec + Transaction.spec + ScriptSessionErrors.spec + TruncateBefore.spec + ReadStream.spec + StreamNameLookup.spec + StreamBridgeTermination.spec + StreamHistoryGuard.spec + InterpreterHooks.spec + Causation.spec + ConsumerGroupSql.spec + ConsumerGroupResize.spec + ConsumerGroup.spec + ConsumerGroupEffect.spec + describe "performance structure" $ do + BrowseQueryPlans.spec + StreamHeadIsolation.spec + PerformanceStructure.spec + NotifyGuard.spec + StreamNameLookup.noOpSpec + CategoryIdleNoSpin.spec + HandlerStall.spec + PublisherCallbackResilience.spec + PublisherDropCounter.spec + PublisherIdleAdvance.spec + PublisherRestartNoRebroadcast.spec + CatchupDbErrorNoPrematureSwitch.spec + SubscriptionPauseResume.spec + SubscriptionCheckpointInitialization.spec + SubscriptionCheckpointInitializationMock.spec + SubscriptionCheckpointWorker.spec + SubscriptionCheckpointInventory.spec + SubscriptionCheckpointInventoryMock.spec + SubscriptionCheckpointReset.spec + SubscriptionReconnect.spec + StartupFailureSurfacing.spec + SubscriptionState.spec + SubscriptionRegistry.spec + SubscriptionRetryDeadLetter.spec + EventTypeFilter.spec + StreamHead.spec + StreamHeadMock.spec + VisibleGlobalHeadPosition.spec + VisibleGlobalHeadPositionMock.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 "empty event batches" $ do + it "rejects NoStream without creating a phantom stream or advancing $all" $ \store -> do + Right allBefore <- runStoreIO store $ readAllForward (GlobalPosition 0) 10 + result <- runStoreIO store $ appendToStream (StreamName "empty-nostream") NoStream [] + result `shouldBe` Left (EmptyAppendBatch (StreamName "empty-nostream")) + runStoreIO store (getStream (StreamName "empty-nostream")) `shouldReturn` Right Nothing + Right allAfter <- runStoreIO store $ readAllForward (GlobalPosition 0) 10 + fmap (^. #globalPosition) (V.toList allAfter) `shouldBe` fmap (^. #globalPosition) (V.toList allBefore) + + it "rejects empty batches for existing-stream expectations without changing version" $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "empty-existing") NoStream [makeEvent "Created" (Aeson.object [])] + let assertEmptyRejected expected = do + result <- runStoreIO store $ appendToStream (StreamName "empty-existing") expected [] + result `shouldBe` Left (EmptyAppendBatch (StreamName "empty-existing")) + Right (Just info) <- runStoreIO store $ getStream (StreamName "empty-existing") + (info ^. #version) `shouldBe` StreamVersion 1 + assertEmptyRejected (ExactVersion (StreamVersion 1)) + assertEmptyRejected StreamExists + assertEmptyRejected AnyVersion + + it "rejects an empty per-stream batch in appendMultiStream without committing any stream" $ \store -> do + let ok = StreamName "empty-multi-ok" + bad = StreamName "empty-multi-bad" + result <- + runStoreIO store $ + appendMultiStream + [ (ok, NoStream, [makeEvent "Created" (Aeson.object [])]), + (bad, NoStream, []) + ] + result `shouldBe` Left (EmptyAppendBatch bad) + runStoreIO store (getStream ok) `shouldReturn` Right Nothing + runStoreIO store (getStream bad) `shouldReturn` Right Nothing + + it "treats an empty appendMultiStream operation list as a no-op" $ \store -> do + result <- runStoreIO store $ appendMultiStream [] + result `shouldBe` Right [] + + 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 "returns the caller event id on same-stream retry and leaves one stored event" $ \store -> do + let eid = EventId (UUID.fromWords 0x01234567 0x89ab7def 0x80123456 0x7890abcd) + event = makeEvent "Created" (Aeson.object []) & #eventId .~ Just eid + stream = StreamName "same-stream-duplicate" + Right _ <- runStoreIO store $ appendToStream stream NoStream [event] + forM_ [AnyVersion, StreamExists, ExactVersion (StreamVersion 1)] $ \expected -> do + result <- runStoreIO store $ appendToStream stream expected [event] + result `shouldBe` Left (DuplicateEvent (Just eid)) + countEvents store `shouldReturn` 1 + Right stored <- runStoreIO store $ readStreamForward stream (StreamVersion 0) 100 + Right global <- runStoreIO store $ readAllForward (GlobalPosition 0) 100 + map (\e -> e ^. #eventId) (V.toList stored) `shouldBe` [eid] + map (\e -> e ^. #eventId) (V.toList global) `shouldBe` [eid] + Right info <- runStoreIO store $ getStream stream + fmap (\s -> s ^. #version) info `shouldBe` Just (StreamVersion 1) + + 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" + + it "rejects stream names longer than 512 UTF-8 bytes before creating streams" $ \store -> do + let overAscii = StreamName (T.replicate 513 "a") + overUtf8 = StreamName (T.replicate 171 (T.singleton '\12354')) + assertTooLong sn = do + result <- runStoreIO store $ appendToStream sn NoStream [makeEvent "TooLong" (Aeson.object [])] + result `shouldBe` Left (StreamNameTooLong sn 513) + runStoreIO store (getStream sn) `shouldReturn` Right Nothing + assertTooLong overAscii + assertTooLong overUtf8 + + it "rejects oversized link targets without creating the target stream" $ \store -> do + let over = StreamName (T.replicate 513 "l") + Right _ <- runStoreIO store $ appendToStream (StreamName "length-link-source") NoStream [makeEvent "Source" (Aeson.object [])] + Right events <- runStoreIO store $ readStreamForward (StreamName "length-link-source") (StreamVersion 0) 10 + let eid = V.head events ^. #eventId + result <- runStoreIO store $ linkToStream over [eid] + result `shouldBe` Left (StreamNameTooLong over 513) + runStoreIO store (getStream over) `shouldReturn` Right Nothing + + it "rejects oversized multi-stream targets without partial commit" $ \store -> do + let ok = StreamName "length-multi-ok" + over = StreamName (T.replicate 513 "m") + result <- + runStoreIO store $ + appendMultiStream + [ (ok, NoStream, [makeEvent "ShouldRollback" (Aeson.object [])]), + (over, NoStream, [makeEvent "TooLong" (Aeson.object [])]) + ] + result `shouldBe` Left (StreamNameTooLong over 513) + runStoreIO store (getStream ok) `shouldReturn` Right Nothing + runStoreIO store (getStream over) `shouldReturn` Right Nothing + + it "accepts a 512-byte stream name" $ \store -> do + let exact = StreamName (T.replicate 512 "e") + result <- runStoreIO store $ appendToStream exact NoStream [makeEvent "ExactLength" (Aeson.object [])] + case result of + Right r -> (r ^. #streamVersion) `shouldBe` StreamVersion 1 + Left err -> expectationFailure ("Expected 512-byte stream name to append, got: " <> show err) + + 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 + + it "paginates backward using stream version as an exclusive cursor" $ \store -> do + let events = map (\i -> makeEvent ("E" <> T.pack (show i)) (Aeson.object [])) [1 .. 5 :: Int] + Right _ <- runStoreIO store $ appendToStream (StreamName "read-bwd-page") NoStream events + + Right page1 <- runStoreIO store $ readStreamBackward (StreamName "read-bwd-page") (StreamVersion 0) 2 + fmap (^. #streamVersion) (V.toList page1) `shouldBe` [StreamVersion 5, StreamVersion 4] + + let cursor1 = V.last page1 ^. #streamVersion + Right page2 <- runStoreIO store $ readStreamBackward (StreamName "read-bwd-page") cursor1 2 + fmap (^. #streamVersion) (V.toList page2) `shouldBe` [StreamVersion 3, StreamVersion 2] + + let cursor2 = V.last page2 ^. #streamVersion + Right page3 <- runStoreIO store $ readStreamBackward (StreamName "read-bwd-page") cursor2 2 + fmap (^. #streamVersion) (V.toList page3) `shouldBe` [StreamVersion 1] + + Right page4 <- runStoreIO store $ readStreamBackward (StreamName "read-bwd-page") (V.last page3 ^. #streamVersion) 2 + V.length page4 `shouldBe` 0 + + 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" + + it "paginates backward using global position as an exclusive cursor" $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "allb-page-s1") NoStream [makeEvent "X" (Aeson.object [])] + Right _ <- runStoreIO store $ appendToStream (StreamName "allb-page-s2") NoStream [makeEvent "Y" (Aeson.object [])] + Right _ <- runStoreIO store $ appendToStream (StreamName "allb-page-s3") NoStream [makeEvent "Z" (Aeson.object [])] + + Right page1 <- runStoreIO store $ readAllBackward (GlobalPosition 0) 2 + fmap (^. #globalPosition) (V.toList page1) `shouldBe` [GlobalPosition 3, GlobalPosition 2] + + Right page2 <- runStoreIO store $ readAllBackward (GlobalPosition 2) 2 + fmap (^. #globalPosition) (V.toList page2) `shouldBe` [GlobalPosition 1] + + Right page3 <- runStoreIO store $ readAllBackward (GlobalPosition 1) 2 + V.length page3 `shouldBe` 0 + + 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 (EventAlreadyLinked (StreamName "linked-dup") mEid) -> + mEid `shouldBe` Just eid + Left err -> expectationFailure ("Expected EventAlreadyLinked, got: " <> show err) + 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 (LinkSourceEventMissing (StreamName "f3-bogus")) -> pure () + Left err -> expectationFailure ("Expected LinkSourceEventMissing, got: " <> show err) + 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 (LinkSourceEventMissing (StreamName "f3-mixed-tgt")) -> pure () + Left err -> expectationFailure ("Expected LinkSourceEventMissing, got: " <> show err) + 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 + countBefore <- countEvents store + Right _ <- runStoreIO store $ hardDeleteStream (StreamName "f1-orphan") + countAfter <- countEvents store + (countBefore - countAfter) `shouldBe` 3 + + it "removes dead letters for orphaned events before deleting their payloads" $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "dl-hard-source") NoStream [makeEvent "DeadLettered" (Aeson.object [])] + Right events <- runStoreIO store $ readStreamForward (StreamName "dl-hard-source") (StreamVersion 0) 10 + let event = V.head events + eid = event ^. #eventId + insertDeadLetterForEvent store "dl-hard-subscription" event + countDeadLettersForEvents store [eid] `shouldReturn` 1 + + Right mId <- runStoreIO store $ hardDeleteStream (StreamName "dl-hard-source") + mId `shouldSatisfy` (/= Nothing) + countDeadLettersForEvents store [eid] `shouldReturn` 0 + Right remaining <- runStoreIO store $ readAllForward (GlobalPosition 0) 100 + V.filter (\recorded -> (recorded ^. #eventId) == eid) remaining `shouldBe` V.empty + + it "keeps dead letters for linked-in events that survive a hard delete" $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "dl-origin") NoStream [makeEvent "Survivor" (Aeson.object [])] + Right originEvents <- runStoreIO store $ readStreamForward (StreamName "dl-origin") (StreamVersion 0) 10 + let event = V.head originEvents + eid = event ^. #eventId + Right _ <- runStoreIO store $ linkToStream (StreamName "dl-link-target") [eid] + insertDeadLetterForEvent store "dl-survivor-subscription" event + countDeadLettersForEvents store [eid] `shouldReturn` 1 + + Right _ <- runStoreIO store $ hardDeleteStream (StreamName "dl-link-target") + countDeadLettersForEvents store [eid] `shouldReturn` 1 + Right afterTargetDelete <- runStoreIO store $ readStreamForward (StreamName "dl-origin") (StreamVersion 0) 10 + fmap (^. #eventId) (V.toList afterTargetDelete) `shouldBe` [eid] + + Right _ <- runStoreIO store $ hardDeleteStream (StreamName "dl-origin") + countDeadLettersForEvents store [eid] `shouldReturn` 0 + Right afterOriginDelete <- runStoreIO store $ readAllForward (GlobalPosition 0) 100 + V.filter (\recorded -> (recorded ^. #eventId) == eid) afterOriginDelete `shouldBe` V.empty + + -- 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = either (error . show) Prelude.id (mkBatchSize 2), + queueCapacity = 32, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = either (error . show) Prelude.id (mkBatchSize 2), + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + -- 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, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 1, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + retryPolicy = defaultRetryPolicy, + eventTypeFilter = AllEventTypes, + selector = Nothing + } + handle <- subscribe store cfg + -- This fixture requires a live handler; catch-up could otherwise + -- consume the queued range before observing overflow. + let awaitLive = do + st <- currentState handle + case st of + Just Fsm.Live {} -> pure () + _ -> threadDelay 1_000 >> awaitLive + Async.race (threadDelay 5_000_000) awaitLive >>= (`shouldBe` Right ()) + -- 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 + + describe "isTransientSerializationError" $ do + let serverUsage code = + SessionUsageError $ + Errors.StatementSessionError + 1 + 0 + "" + [] + True + ( Errors.ServerStatementError $ + Errors.ServerError code "server error" Nothing Nothing Nothing + ) + it "recognizes only serialization and deadlock SQLSTATEs" $ do + isTransientSerializationError (serverUsage "40P01") `shouldBe` True + isTransientSerializationError (serverUsage "40001") `shouldBe` True + isTransientSerializationError (serverUsage "23505") `shouldBe` False + isTransientSerializationError AcquisitionTimeoutUsageError `shouldBe` False + + -- The store retries an append once on these codes, so a caller only + -- sees one when the conflict repeated. It must arrive as the retryable + -- constructor: 'UnexpectedServerError' documents itself as "not + -- generally retryable — investigate", which would send a caller to + -- diagnose a condition whose correct handling is to retry. + it "maps both transient SQLSTATEs to TransientTransactionFailure" $ do + forM_ ["40001", "40P01"] $ \code -> do + mapUsageError "orders-1" AnyVersion (serverUsage code) + `shouldBe` TransientTransactionFailure code "server error" + mapGenericUsageError (serverUsage code) + `shouldBe` TransientTransactionFailure code "server error" + mapTransactionUsageError (serverUsage code) + `shouldBe` TransientTransactionFailure code "server error" + mapLinkUsageError (StreamName "orders-1") (serverUsage code) + `shouldBe` TransientTransactionFailure code "server error" + attributeMultiStreamError + [(StreamName "orders-1", AnyVersion)] + (serverUsage code) + `shouldBe` TransientTransactionFailure code "server error" + + it "leaves non-transient server codes on UnexpectedServerError" $ do + mapGenericUsageError (serverUsage "42883") + `shouldBe` UnexpectedServerError "42883" "server error" + + -- ================================================================= + -- 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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/BrowseQueryPlans.hs b/test/Test/BrowseQueryPlans.hs --- a/test/Test/BrowseQueryPlans.hs +++ b/test/Test/BrowseQueryPlans.hs @@ -25,72 +25,74 @@ spec :: Spec spec = describe "browse reads prepared query work" $ do - around withTestStore $ it "bounds production generic and custom index seeks on a 40000-stream catalog" preparedChecks - it "uses the same bounded production statements in an English ICU database" $ withIcuStore $ \store -> do - preparedChecks store - Right _ <- runStoreIO store $ appendToStream (StreamName "orders-éclair") NoStream [EventData Nothing (EventType "Created") (Aeson.object []) Nothing Nothing Nothing] - Right _ <- runStoreIO store $ appendToStream (StreamName "orders-éclair") NoStream [EventData Nothing (EventType "Created") (Aeson.object []) Nothing Nothing Nothing] - let page = either (error . show) (\size -> size) (mkBrowsePageSize 11) - Right rows <- runStoreIO store $ listStreams (Just (CategoryName "orders")) (Just "orders-é") Nothing page - map (\row -> row ^. #name) (V.toList rows) `shouldBe` [StreamName "orders-éclair"] + around withTestStore $ it "bounds production generic and custom index seeks on a 40000-stream catalog" preparedChecks + it "uses the same bounded production statements in an English ICU database" $ withIcuStore $ \store -> do + preparedChecks store + Right _ <- runStoreIO store $ appendToStream (StreamName "orders-éclair") NoStream [EventData Nothing (EventType "Created") (Aeson.object []) Nothing Nothing Nothing] + Right _ <- runStoreIO store $ appendToStream (StreamName "orders-éclair") NoStream [EventData Nothing (EventType "Created") (Aeson.object []) Nothing Nothing Nothing] + let page = either (error . show) (\size -> size) (mkBrowsePageSize 11) + Right rows <- runStoreIO store $ listStreams (Just (CategoryName "orders")) (Just "orders-é") Nothing page + map (\row -> row ^. #name) (V.toList rows) `shouldBe` [StreamName "orders-éclair"] preparedChecks :: KirokuStore -> IO () preparedChecks store = do - seeded <- - Pool.use (store ^. #pool) $ - Session.script - "INSERT INTO streams(stream_name) SELECT c || '-' || lpad(n::text,10,'0') FROM unnest(ARRAY['orders','noise']) c CROSS JOIN generate_series(1,20000) n; ANALYZE streams;" - seeded `shouldBe` Right () - forM_ ["force_generic_plan", "force_custom_plan"] $ \mode -> do - forM_ [(SQL.InclusiveLower, "'orders-', 'orders.', 11"), (SQL.ExclusiveLower, "'orders-0000019990', 'orders.', 11"), (SQL.InclusiveLower, "'absent', 'absenu', 11"), (SQL.InclusiveLower, "'', NULL, 11")] $ \(bound, args) -> do - plan <- explainPrepared store mode "text,text,int4" args (SQL.listStreamsRangeStmt bound) - expectBounded plan 11 - plan <- explainPrepared store mode "text,text,text,text,int4" "'orders', NULL, 'orders-', 'orders.', 11" (SQL.listStreamsPairStmt SQL.ExactName SQL.InclusiveLower) - expectBounded plan 22 - forM_ [(False, "NULL, 11"), (True, "'orders', 11")] $ \(hasCursor, args) -> do - categoryPlan <- explainPrepared store mode "text,int4" args (SQL.listCategoriesStmt hasCursor) - indexNames categoryPlan `shouldContain` ["ix_streams_category"] - -- Each loose-index seek returns at most one distinct category. - scannedRows categoryPlan `shouldSatisfy` (<= 12) + seeded <- + Pool.use (store ^. #pool) $ + Session.script + "INSERT INTO streams(stream_name) SELECT c || '-' || lpad(n::text,10,'0') FROM unnest(ARRAY['orders','noise']) c CROSS JOIN generate_series(1,20000) n; ANALYZE streams;" + seeded `shouldBe` Right () + forM_ ["force_generic_plan", "force_custom_plan"] $ \mode -> do + forM_ [(SQL.InclusiveLower, "'orders-', 'orders.', 11"), (SQL.ExclusiveLower, "'orders-0000019990', 'orders.', 11"), (SQL.InclusiveLower, "'absent', 'absenu', 11"), (SQL.InclusiveLower, "'', NULL, 11")] $ \(bound, args) -> do + plan <- explainPrepared store mode "text,text,int4" args (SQL.listStreamsRangeStmt bound) + expectBounded plan 11 + plan <- explainPrepared store mode "text,text,text,text,int4" "'orders', NULL, 'orders-', 'orders.', 11" (SQL.listStreamsPairStmt SQL.ExactName SQL.InclusiveLower) + expectBounded plan 22 + forM_ [(False, "NULL, 11"), (True, "'orders', 11")] $ \(hasCursor, args) -> do + categoryPlan <- explainPrepared store mode "text,int4" args (SQL.listCategoriesStmt hasCursor) + indexNames categoryPlan `shouldContain` ["ix_streams_category"] + -- Each loose-index seek returns at most one distinct category. + scannedRows categoryPlan `shouldSatisfy` (<= 12) explainPrepared :: KirokuStore -> Text -> Text -> Text -> Statement p r -> IO Value explainPrepared store mode types args statement = do - result <- Pool.use (store ^. #pool) $ do - Session.script ("SET plan_cache_mode=" <> mode <> "; PREPARE mp13_browse(" <> types <> ") AS " <> Statement.toSql statement) - bytes <- Session.statement () (unpreparable ("EXPLAIN (ANALYZE, BUFFERS, TIMING OFF, FORMAT JSON) EXECUTE mp13_browse(" <> args <> ")") E.noParams (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right))))) - Session.script "DEALLOCATE mp13_browse; RESET plan_cache_mode" - pure bytes - case result of - Left err -> expectationFailure (show err) >> fail "EXPLAIN failed" - Right bytes -> decodePlan bytes + result <- Pool.use (store ^. #pool) $ do + Session.script ("SET plan_cache_mode=" <> mode <> "; PREPARE mp13_browse(" <> types <> ") AS " <> Statement.toSql statement) + bytes <- Session.statement () (unpreparable ("EXPLAIN (ANALYZE, BUFFERS, TIMING OFF, FORMAT JSON) EXECUTE mp13_browse(" <> args <> ")") E.noParams (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right))))) + Session.script "DEALLOCATE mp13_browse; RESET plan_cache_mode" + pure bytes + case result of + Left err -> expectationFailure (show err) >> fail "EXPLAIN failed" + Right bytes -> decodePlan bytes where decodePlan :: ByteString -> IO Value decodePlan bytes = either fail pure (Aeson.eitherDecodeStrict' bytes) expectBounded :: Value -> Double -> Expectation expectBounded plan budget = do - indexNames plan `shouldContain` ["ix_streams_browse_name"] - scannedRows plan `shouldSatisfy` (<= budget) - case plan of - Array entries - | Object entry <- V.head entries - , Just (Object top) <- KM.lookup "Plan" entry -> - number "Shared Hit Blocks" top + number "Shared Read Blocks" top `shouldSatisfy` (<= 64) - _ -> expectationFailure (show plan) + indexNames plan `shouldContain` ["ix_streams_browse_name"] + scannedRows plan `shouldSatisfy` (<= budget) + case plan of + Array entries + | Object entry <- V.head entries, + Just (Object top) <- KM.lookup "Plan" entry -> + number "Shared Hit Blocks" top + number "Shared Read Blocks" top `shouldSatisfy` (<= 64) + _ -> expectationFailure (show plan) -- Count rows examined at relation scans (including filters), not only results. scannedRows :: Value -> Double scannedRows (Object fields) = current + sum (map scannedRows (KM.elems fields)) where current = case KM.lookup "Relation Name" fields of - Just (String "streams") -> (number "Actual Rows" fields + number "Rows Removed by Filter" fields + number "Rows Removed by Index Recheck" fields) * number "Actual Loops" fields - _ -> 0 + Just (String "streams") -> (number "Actual Rows" fields + number "Rows Removed by Filter" fields + number "Rows Removed by Index Recheck" fields) * number "Actual Loops" fields + _ -> 0 scannedRows (Array values) = sum (map scannedRows (foldr (:) [] values)) scannedRows _ = 0 + indexNames :: Value -> [Text] indexNames (Object fields) = [name | Just (String name) <- [KM.lookup "Index Name" fields]] <> concatMap indexNames (KM.elems fields) indexNames (Array values) = concatMap indexNames (foldr (:) [] values) indexNames _ = [] + number :: Aeson.Key -> Aeson.Object -> Double number key fields = case KM.lookup key fields of Just (Number n) -> realToFrac n; _ -> 0 @@ -98,12 +100,12 @@ -- rather than altering existing columns or using a different hand-written query. withIcuStore :: (KirokuStore -> IO ()) -> IO () withIcuStore action = withMigratedTestDatabase $ \connection -> - withStore (defaultConnectionSettings connection) $ \admin -> do - let sql command = Pool.use (admin ^. #pool) (Session.script command) >>= either (fail . show) pure - newConnection = T.unwords (filter (not . T.isPrefixOf "dbname=") (T.words connection) <> ["dbname=mp13_browse_icu"]) - bracket_ - (sql "CREATE DATABASE mp13_browse_icu TEMPLATE template0 LOCALE_PROVIDER icu ICU_LOCALE 'en'") - (sql "DROP DATABASE mp13_browse_icu") - $ do - migrateTestDatabase newConnection - withStore (defaultConnectionSettings newConnection) action + withStore (defaultConnectionSettings connection) $ \admin -> do + let sql command = Pool.use (admin ^. #pool) (Session.script command) >>= either (fail . show) pure + newConnection = T.unwords (filter (not . T.isPrefixOf "dbname=") (T.words connection) <> ["dbname=mp13_browse_icu"]) + bracket_ + (sql "CREATE DATABASE mp13_browse_icu TEMPLATE template0 LOCALE_PROVIDER icu ICU_LOCALE 'en'") + (sql "DROP DATABASE mp13_browse_icu") + $ do + migrateTestDatabase newConnection + withStore (defaultConnectionSettings newConnection) action diff --git a/test/Test/BrowseReads.hs b/test/Test/BrowseReads.hs --- a/test/Test/BrowseReads.hs +++ b/test/Test/BrowseReads.hs @@ -22,73 +22,73 @@ seed :: KirokuStore -> [Text] -> IO () seed store = mapM_ $ \name -> do - result <- runStoreIO store $ appendToStream (StreamName name) NoStream [makeEvent "Created" (Aeson.object [])] - result `shouldSatisfy` either (const False) (const True) + result <- runStoreIO store $ appendToStream (StreamName name) NoStream [makeEvent "Created" (Aeson.object [])] + result `shouldSatisfy` either (const False) (const True) spec :: Spec spec = describe "browse reads" $ do - it "validates bounded page sizes" $ do - forM_ [minBound, -1, 0, 1002, maxBound] $ \n -> mkBrowsePageSize n `shouldBe` Left (InvalidBrowsePageSize n) - forM_ [1, 1000, 1001] $ \n -> fmap browsePageSizeValue (mkBrowsePageSize n) `shouldBe` Right (fromIntegral n) - around withTestStore $ do - it "excludes only the reserved all row and pages in UTF-8 byte order" $ \store -> do - runStoreIO store (listStreams Nothing Nothing Nothing (page 10)) `shouldReturn` Right V.empty - let values = ["orders-2", "orders", "orders-1", "$all-x", "singleton", "é-1", "Z-1", "-empty-category"] - seed store values - Right first <- runStoreIO store $ listStreams Nothing Nothing Nothing (page 3) - names first `shouldBe` take 3 (sort values) - Right rest <- runStoreIO store $ listStreams Nothing Nothing (Just (StreamName (last (names first)))) (page 100) - names first <> names rest `shouldBe` sort values - runStoreIO store (listStreams Nothing Nothing (Just (StreamName (last (sort values)))) (page 10)) `shouldReturn` Right V.empty - it "intersects exact categories, literal prefixes and exclusive cursors" $ \store -> do - let maxScalar = T.singleton (chr 0x10ffff) - values = ["orders", "orders-1", "orders-2", "orders:other-1", "orders_-1", "orders%-1", "$all-x", "-a", "é-a", "é-a", maxScalar, maxScalar <> "-a", "\xD7FF-a", "\xE000-a"] - seed store values - forM_ [Nothing, Just (CategoryName "orders"), Just (CategoryName ""), Just (CategoryName "$all"), Just (CategoryName "not-a-category"), Just (CategoryName maxScalar)] $ \category -> - forM_ [Nothing, Just "", Just "orders", Just "orders-", Just "orders%", Just "orders_", Just "absent", Just "é", Just maxScalar, Just "\xD7FF"] $ \prefix -> - forM_ [Nothing, Just (StreamName "orders"), Just (StreamName "orders-1"), Just (StreamName "zzz")] $ \cursor -> do - let expected = sort [v | v <- values, maybe True (== categoryName (StreamName v)) category, maybe True (`T.isPrefixOf` v) prefix, maybe True (\(StreamName c) -> v > c) cursor] - Right actual <- runStoreIO store $ listStreams category prefix cursor (page 100) - names actual `shouldBe` expected - it "enumerates distinct categories including bare and empty categories" $ \store -> do - seed store ["orders", "orders-1", "orders-2", "$all-x", "-a", "singleton"] - Right first <- runStoreIO store $ listCategories Nothing (page 2) - V.toList first `shouldBe` [CategoryName "", CategoryName "$all"] - Right rest <- runStoreIO store $ listCategories (Just (V.last first)) (page 10) - V.toList rest `shouldBe` [CategoryName "orders", CategoryName "singleton"] - it "keeps soft-deleted summaries and removes hard-deleted summaries" $ \store -> do - seed store ["orders-soft", "orders-hard"] - void $ runStoreIO store $ softDeleteStream (StreamName "orders-soft") - void $ runStoreIO store $ setStreamTruncateBefore (StreamName "orders-soft") (StreamVersion 1) - void $ runStoreIO store $ hardDeleteStream (StreamName "orders-hard") - Right rows <- runStoreIO store $ listStreams Nothing Nothing Nothing (page 10) - names rows `shouldBe` ["orders-soft"] - (V.head rows ^. #deletedAt) `shouldSatisfy` maybe False (const True) - it "returns the canonical global row once even when linked, then nothing after hard deletion" $ \store -> do - seed store ["orders-1"] - Right events <- runStoreIO store $ readAllForward (GlobalPosition 0) 10 - let event = V.head events - Right _ <- runStoreIO store $ linkToStream (StreamName "links-1") [event ^. #eventId] - runStoreIO store (getEvent (event ^. #eventId)) `shouldReturn` Right (Just event) - runStoreIO store (getEvent (EventId UUID.nil)) `shouldReturn` Right Nothing - Right _ <- runStoreIO store $ hardDeleteStream (StreamName "orders-1") - runStoreIO store (getEvent (event ^. #eventId)) `shouldReturn` Right Nothing - it "applies the configured decode hook to event lookup" $ do - let marker = Aeson.object ["decoded" Aeson..= True] - hook event = pure (Right (event & #metadata .~ Just marker)) - withTestStoreSettings (\settings -> settings & #storeSettings .~ defaultStoreSettings{decodeHook = Just hook}) $ \store -> do - seed store ["orders-1"] - Right events <- runStoreIO store $ readAllForward (GlobalPosition 0) 10 - Right (Just event) <- runStoreIO store $ getEvent (V.head events ^. #eventId) - (event ^. #metadata) `shouldBe` Just marker + it "validates bounded page sizes" $ do + forM_ [minBound, -1, 0, 1002, maxBound] $ \n -> mkBrowsePageSize n `shouldBe` Left (InvalidBrowsePageSize n) + forM_ [1, 1000, 1001] $ \n -> fmap browsePageSizeValue (mkBrowsePageSize n) `shouldBe` Right (fromIntegral n) + around withTestStore $ do + it "excludes only the reserved all row and pages in UTF-8 byte order" $ \store -> do + runStoreIO store (listStreams Nothing Nothing Nothing (page 10)) `shouldReturn` Right V.empty + let values = ["orders-2", "orders", "orders-1", "$all-x", "singleton", "é-1", "Z-1", "-empty-category"] + seed store values + Right first <- runStoreIO store $ listStreams Nothing Nothing Nothing (page 3) + names first `shouldBe` take 3 (sort values) + Right rest <- runStoreIO store $ listStreams Nothing Nothing (Just (StreamName (last (names first)))) (page 100) + names first <> names rest `shouldBe` sort values + runStoreIO store (listStreams Nothing Nothing (Just (StreamName (last (sort values)))) (page 10)) `shouldReturn` Right V.empty + it "intersects exact categories, literal prefixes and exclusive cursors" $ \store -> do + let maxScalar = T.singleton (chr 0x10ffff) + values = ["orders", "orders-1", "orders-2", "orders:other-1", "orders_-1", "orders%-1", "$all-x", "-a", "é-a", "é-a", maxScalar, maxScalar <> "-a", "\xD7FF-a", "\xE000-a"] + seed store values + forM_ [Nothing, Just (CategoryName "orders"), Just (CategoryName ""), Just (CategoryName "$all"), Just (CategoryName "not-a-category"), Just (CategoryName maxScalar)] $ \category -> + forM_ [Nothing, Just "", Just "orders", Just "orders-", Just "orders%", Just "orders_", Just "absent", Just "é", Just maxScalar, Just "\xD7FF"] $ \prefix -> + forM_ [Nothing, Just (StreamName "orders"), Just (StreamName "orders-1"), Just (StreamName "zzz")] $ \cursor -> do + let expected = sort [v | v <- values, maybe True (== categoryName (StreamName v)) category, maybe True (`T.isPrefixOf` v) prefix, maybe True (\(StreamName c) -> v > c) cursor] + Right actual <- runStoreIO store $ listStreams category prefix cursor (page 100) + names actual `shouldBe` expected + it "enumerates distinct categories including bare and empty categories" $ \store -> do + seed store ["orders", "orders-1", "orders-2", "$all-x", "-a", "singleton"] + Right first <- runStoreIO store $ listCategories Nothing (page 2) + V.toList first `shouldBe` [CategoryName "", CategoryName "$all"] + Right rest <- runStoreIO store $ listCategories (Just (V.last first)) (page 10) + V.toList rest `shouldBe` [CategoryName "orders", CategoryName "singleton"] + it "keeps soft-deleted summaries and removes hard-deleted summaries" $ \store -> do + seed store ["orders-soft", "orders-hard"] + void $ runStoreIO store $ softDeleteStream (StreamName "orders-soft") + void $ runStoreIO store $ setStreamTruncateBefore (StreamName "orders-soft") (StreamVersion 1) + void $ runStoreIO store $ hardDeleteStream (StreamName "orders-hard") + Right rows <- runStoreIO store $ listStreams Nothing Nothing Nothing (page 10) + names rows `shouldBe` ["orders-soft"] + (V.head rows ^. #deletedAt) `shouldSatisfy` maybe False (const True) + it "returns the canonical global row once even when linked, then nothing after hard deletion" $ \store -> do + seed store ["orders-1"] + Right events <- runStoreIO store $ readAllForward (GlobalPosition 0) 10 + let event = V.head events + Right _ <- runStoreIO store $ linkToStream (StreamName "links-1") [event ^. #eventId] + runStoreIO store (getEvent (event ^. #eventId)) `shouldReturn` Right (Just event) + runStoreIO store (getEvent (EventId UUID.nil)) `shouldReturn` Right Nothing + Right _ <- runStoreIO store $ hardDeleteStream (StreamName "orders-1") + runStoreIO store (getEvent (event ^. #eventId)) `shouldReturn` Right Nothing + it "applies the configured decode hook to event lookup" $ do + let marker = Aeson.object ["decoded" Aeson..= True] + hook event = pure (Right (event & #metadata .~ Just marker)) + withTestStoreSettings (\settings -> settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook}) $ \store -> do + seed store ["orders-1"] + Right events <- runStoreIO store $ readAllForward (GlobalPosition 0) 10 + Right (Just event) <- runStoreIO store $ getEvent (V.head events ^. #eventId) + (event ^. #metadata) `shouldBe` Just marker - it "propagates typed decode failure from event lookup" $ do - let hook event = pure (Left (DecodeFailure (event ^. #eventId) "failure")) - withTestStoreSettings (\settings -> settings & #storeSettings .~ defaultStoreSettings{decodeHook = Just hook}) $ \store -> do - seed store ["orders-1"] - Right rows <- runStoreIO store $ readStreamForward (StreamName "missing") (StreamVersion 0) 1 - rows `shouldBe` V.empty - -- Use the append-provided id to avoid decoding a fixture through the failing hook. - let event = makeEvent "Created" (Aeson.object []) & #eventId .~ Just (EventId UUID.nil) - Right _ <- runStoreIO store $ appendToStream (StreamName "orders-2") NoStream [event] - runStoreIO store (getEvent (EventId UUID.nil)) `shouldReturn` Left (EventDecodeFailed (DecodeFailure (EventId UUID.nil) "failure")) + it "propagates typed decode failure from event lookup" $ do + let hook event = pure (Left (DecodeFailure (event ^. #eventId) "failure")) + withTestStoreSettings (\settings -> settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook}) $ \store -> do + seed store ["orders-1"] + Right rows <- runStoreIO store $ readStreamForward (StreamName "missing") (StreamVersion 0) 1 + rows `shouldBe` V.empty + -- Use the append-provided id to avoid decoding a fixture through the failing hook. + let event = makeEvent "Created" (Aeson.object []) & #eventId .~ Just (EventId UUID.nil) + Right _ <- runStoreIO store $ appendToStream (StreamName "orders-2") NoStream [event] + runStoreIO store (getEvent (EventId UUID.nil)) `shouldReturn` Left (EventDecodeFailed (DecodeFailure (EventId UUID.nil) "failure")) diff --git a/test/Test/BrowseReadsMock.hs b/test/Test/BrowseReadsMock.hs --- a/test/Test/BrowseReadsMock.hs +++ b/test/Test/BrowseReadsMock.hs @@ -13,24 +13,24 @@ spec :: Spec spec = describe "browse reads mock" $ it "dispatches each public wrapper exactly once with its parameters" $ do - calls <- newIORef ([] :: [String]) - let page = either (error . show) (\size -> size) (mkBrowsePageSize 7) - runner = interpret_ $ \case - ListStreams category prefix cursor size -> do - liftIO $ (category, prefix, cursor, size) `shouldBe` (Just (CategoryName "orders"), Just "orders-", Just (StreamName "orders-1"), page) - liftIO $ modifyIORef' calls (<> ["streams"]) - pure V.empty - ListCategories cursor size -> do - liftIO $ (cursor, size) `shouldBe` (Just (CategoryName "orders"), page) - liftIO $ modifyIORef' calls (<> ["categories"]) - pure V.empty - GetEvent eid -> do - liftIO $ eid `shouldBe` EventId UUID.nil - liftIO $ modifyIORef' calls (<> ["event"]) - pure Nothing - _ -> error "unexpected browse mock operation" - _ <- runEff $ runner $ do - _ <- listStreams (Just (CategoryName "orders")) (Just "orders-") (Just (StreamName "orders-1")) page - _ <- listCategories (Just (CategoryName "orders")) page - getEvent (EventId UUID.nil) - readIORef calls `shouldReturn` ["streams", "categories", "event"] + calls <- newIORef ([] :: [String]) + let page = either (error . show) (\size -> size) (mkBrowsePageSize 7) + runner = interpret_ $ \case + ListStreams category prefix cursor size -> do + liftIO $ (category, prefix, cursor, size) `shouldBe` (Just (CategoryName "orders"), Just "orders-", Just (StreamName "orders-1"), page) + liftIO $ modifyIORef' calls (<> ["streams"]) + pure V.empty + ListCategories cursor size -> do + liftIO $ (cursor, size) `shouldBe` (Just (CategoryName "orders"), page) + liftIO $ modifyIORef' calls (<> ["categories"]) + pure V.empty + GetEvent eid -> do + liftIO $ eid `shouldBe` EventId UUID.nil + liftIO $ modifyIORef' calls (<> ["event"]) + pure Nothing + _ -> error "unexpected browse mock operation" + _ <- runEff $ runner $ do + _ <- listStreams (Just (CategoryName "orders")) (Just "orders-") (Just (StreamName "orders-1")) page + _ <- listCategories (Just (CategoryName "orders")) page + getEvent (EventId UUID.nil) + readIORef calls `shouldReturn` ["streams", "categories", "event"] diff --git a/test/Test/CatchupDbErrorNoPrematureSwitch.hs b/test/Test/CatchupDbErrorNoPrematureSwitch.hs --- a/test/Test/CatchupDbErrorNoPrematureSwitch.hs +++ b/test/Test/CatchupDbErrorNoPrematureSwitch.hs @@ -12,91 +12,91 @@ import Kiroku.Store import Kiroku.Store.Subscription.Types qualified as SubTypes import Kiroku.Store.Subscription.Worker (withFetchBatchHookForTest) -import Test.Helpers ( - caughtUpEventHandler, +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 + 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 + 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 + 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] + 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 - ] + 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 + any isFetchDbError observed `shouldBe` True + V.fromList caughtUpPositions `shouldBe` V.singleton targetTail diff --git a/test/Test/Category.hs b/test/Test/Category.hs --- a/test/Test/Category.hs +++ b/test/Test/Category.hs @@ -1,14 +1,13 @@ -{- | Pure laws for the category accessor and safe stream-name constructor -('Kiroku.Store.Types.categoryName' and 'streamNameInCategory'). - -These pin the "category = substring before the first @-@" rule — enforced by -the @streams.category GENERATED ALWAYS AS split_part(stream_name,'-',1)@ column -and re-derived in 'Kiroku.Store.Notification' — so the public accessor cannot -drift from it. The round-trip law is the contract keiro's typed @Category@ API -(ExecPlan #66) builds on. - -Pure; no database. Runs inside hspec via 'hspec-hedgehog'. --} +-- | Pure laws for the category accessor and safe stream-name constructor +-- ('Kiroku.Store.Types.categoryName' and 'streamNameInCategory'). +-- +-- These pin the "category = substring before the first @-@" rule — enforced by +-- the @streams.category GENERATED ALWAYS AS split_part(stream_name,'-',1)@ column +-- and re-derived in 'Kiroku.Store.Notification' — so the public accessor cannot +-- drift from it. The round-trip law is the contract keiro's typed @Category@ API +-- (ExecPlan #66) builds on. +-- +-- Pure; no database. Runs inside hspec via 'hspec-hedgehog'. module Test.Category (spec) where import Data.Text (Text) @@ -20,17 +19,15 @@ import Test.Hspec import Test.Hspec.Hedgehog (hedgehog) -{- | A non-empty, dash-free category. Includes @:@ and @$@ to exercise the -sub-namespacing convention (e.g. @"wf:orders"@) without the @-@ boundary. --} +-- | A non-empty, dash-free category. Includes @:@ and @$@ to exercise the +-- sub-namespacing convention (e.g. @"wf:orders"@) without the @-@ boundary. genCategoryText :: Gen Text genCategoryText = Gen.text (Range.linear 1 16) (Gen.element categoryChars) where categoryChars = ['a' .. 'z'] <> ['0' .. '9'] <> [':', '$', '_'] -{- | An arbitrary id segment. May contain @-@: the id lives after the first -@-@, so embedded dashes must not change the leading category. --} +-- | An arbitrary id segment. May contain @-@: the id lives after the first +-- @-@, so embedded dashes must not change the leading category. genSegment :: Gen Text genSegment = Gen.text (Range.linear 0 16) (Gen.element segmentChars) where @@ -44,27 +41,27 @@ spec :: Spec spec = describe "Kiroku.Store.Types category rule" $ do - describe "categoryName" $ do - it "takes the substring before the first dash" $ - categoryName (StreamName "orders-1") `shouldBe` CategoryName "orders" + describe "categoryName" $ do + it "takes the substring before the first dash" $ + categoryName (StreamName "orders-1") `shouldBe` CategoryName "orders" - it "treats a dashless name as its own category" $ - categoryName (StreamName "singleton") `shouldBe` CategoryName "singleton" + it "treats a dashless name as its own category" $ + categoryName (StreamName "singleton") `shouldBe` CategoryName "singleton" - it "stops at the first dash even with later dashes" $ - categoryName (StreamName "orders-a-b-c") `shouldBe` CategoryName "orders" + it "stops at the first dash even with later dashes" $ + categoryName (StreamName "orders-a-b-c") `shouldBe` CategoryName "orders" - it "never yields a category containing a dash" $ hedgehog $ do - name <- forAll genStreamNameText - let CategoryName cat = categoryName (StreamName name) - assert (not (T.isInfixOf "-" cat)) + it "never yields a category containing a dash" $ hedgehog $ do + name <- forAll genStreamNameText + let CategoryName cat = categoryName (StreamName name) + assert (not (T.isInfixOf "-" cat)) - describe "streamNameInCategory" $ do - it "joins category and segment with a dash" $ - streamNameInCategory (CategoryName "orders") "1" `shouldBe` StreamName "orders-1" + describe "streamNameInCategory" $ do + it "joins category and segment with a dash" $ + streamNameInCategory (CategoryName "orders") "1" `shouldBe` StreamName "orders-1" - describe "round-trip" $ do - it "categoryName . streamNameInCategory == id, for dash-free categories" $ hedgehog $ do - cat <- forAll genCategoryText - seg <- forAll genSegment - categoryName (streamNameInCategory (CategoryName cat) seg) === CategoryName cat + describe "round-trip" $ do + it "categoryName . streamNameInCategory == id, for dash-free categories" $ hedgehog $ do + cat <- forAll genCategoryText + seg <- forAll genSegment + categoryName (streamNameInCategory (CategoryName cat) seg) === CategoryName cat diff --git a/test/Test/CategoryIdleNoSpin.hs b/test/Test/CategoryIdleNoSpin.hs --- a/test/Test/CategoryIdleNoSpin.hs +++ b/test/Test/CategoryIdleNoSpin.hs @@ -1,41 +1,40 @@ {-# 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 members of a @Category@ (plan 91 M5): they share the plain - category loop and its per-category generation, so both members of an idle - category do __zero__ fetches while another category is busy, and an append - to the category wakes them and the owning member delivers it. - * Consumer-group member of @AllStreams@ - ('Kiroku.Store.Subscription.Worker.liveLoopDbDriven', corrected gate): the - 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 @Category@ subscriptions back -through it — the idle fetch counts then explode and the assertions fail. Routing -only @(Just _, Category{})@ back through the corrected 'liveLoopDbDriven' fails -the zero-fetch assertion for group category members. --} +-- | 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 members of a @Category@ (plan 91 M5): they share the plain +-- category loop and its per-category generation, so both members of an idle +-- category do __zero__ fetches while another category is busy, and an append +-- to the category wakes them and the owning member delivers it. +-- * Consumer-group member of @AllStreams@ +-- ('Kiroku.Store.Subscription.Worker.liveLoopDbDriven', corrected gate): the +-- 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 @Category@ subscriptions back +-- through it — the idle fetch counts then explode and the assertions fail. Routing +-- only @(Just _, Category{})@ back through the corrected 'liveLoopDbDriven' fails +-- the zero-fetch assertion for group category members. module Test.CategoryIdleNoSpin (spec) where import Control.Concurrent (threadDelay) @@ -53,162 +52,162 @@ -- | 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 + | 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 + 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 + 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 + -- 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 + 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 + -- 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 "idle consumer-group category members do zero fetches while another category is active, then the owner wakes on its own event" $ do - -- Two members (0 and 1 of size 2) over category "quiet". Each runs under - -- its own subscription name so each has its own live barrier and fetch - -- counter; the partition predicate depends only on (member, size). - let names = [SubscriptionName "quiet-grp-0", SubscriptionName "quiet-grp-1"] - deliveredVar <- newTVarIO (0 :: Int) - fetchVars <- mapM (const (newTVarIO (0 :: Int))) names - barriers <- mapM (const newEmptyMVar) names - let countFetch evt = case evt of - KirokuEventSubscriptionFetched n _ _ -> - sequence_ - [ atomically (modifyTVar' v (+ 1)) - | (subName, v) <- zip names fetchVars - , n == subName - ] - _ -> pure () - obsHandler evt = do - sequence_ [caughtUpEventHandler subName barrier Nothing evt | (subName, barrier) <- zip names barriers] - countFetch evt - deliver _evt = do - atomically (modifyTVar' deliveredVar (+ 1)) - pure Continue - memberConfig subName member = - (defaultSubscriptionConfig subName (Category (CategoryName "quiet")) deliver) - { consumerGroup = Just (validConsumerGroup member 2) - } - withTestStoreSettings (\s -> s & #eventHandler .~ Just obsHandler) $ \store -> - bracket (subscribe store (memberConfig (names !! 0) 0)) cancel $ \_ -> - bracket (subscribe store (memberConfig (names !! 1) 1)) cancel $ \_ -> do - -- Settle: each member reaches live mode and finishes its initial - -- post-catch-up drain (one empty fetch). - mapM_ waitForSubscriptionLive barriers - mapM_ (\v -> waitUntil 5_000_000 ((>= 1) <$> readTVarIO v)) fetchVars - bases <- mapM readTVarIO fetchVars + it "idle consumer-group category members do zero fetches while another category is active, then the owner wakes on its own event" $ do + -- Two members (0 and 1 of size 2) over category "quiet". Each runs under + -- its own subscription name so each has its own live barrier and fetch + -- counter; the partition predicate depends only on (member, size). + let names = [SubscriptionName "quiet-grp-0", SubscriptionName "quiet-grp-1"] + deliveredVar <- newTVarIO (0 :: Int) + fetchVars <- mapM (const (newTVarIO (0 :: Int))) names + barriers <- mapM (const newEmptyMVar) names + let countFetch evt = case evt of + KirokuEventSubscriptionFetched n _ _ -> + sequence_ + [ atomically (modifyTVar' v (+ 1)) + | (subName, v) <- zip names fetchVars, + n == subName + ] + _ -> pure () + obsHandler evt = do + sequence_ [caughtUpEventHandler subName barrier Nothing evt | (subName, barrier) <- zip names barriers] + countFetch evt + deliver _evt = do + atomically (modifyTVar' deliveredVar (+ 1)) + pure Continue + memberConfig subName member = + (defaultSubscriptionConfig subName (Category (CategoryName "quiet")) deliver) + { consumerGroup = Just (validConsumerGroup member 2) + } + withTestStoreSettings (\s -> s & #eventHandler .~ Just obsHandler) $ \store -> + bracket (subscribe store (memberConfig (names !! 0) 0)) cancel $ \_ -> + bracket (subscribe store (memberConfig (names !! 1) 1)) cancel $ \_ -> do + -- Settle: each member reaches live mode and finishes its initial + -- post-catch-up drain (one empty fetch). + mapM_ waitForSubscriptionLive barriers + mapM_ (\v -> waitUntil 5_000_000 ((>= 1) <$> readTVarIO v)) fetchVars + bases <- mapM readTVarIO fetchVars - -- Drive a different category. Before plan 91 M5 each member woke on - -- every global advance and ran one empty fetch per wake; now both - -- wait on the "quiet" category's generation, which never moves. - let busyCount = 20 :: Int - busyStreams = ["busy-" <> T.pack (show i) | i <- [1 .. busyCount]] - appendEach store busyStreams "Busy" - waitForPublisher store (GlobalPosition (fromIntegral busyCount)) - threadDelay 500_000 + -- Drive a different category. Before plan 91 M5 each member woke on + -- every global advance and ran one empty fetch per wake; now both + -- wait on the "quiet" category's generation, which never moves. + let busyCount = 20 :: Int + busyStreams = ["busy-" <> T.pack (show i) | i <- [1 .. busyCount]] + appendEach store busyStreams "Busy" + waitForPublisher store (GlobalPosition (fromIntegral busyCount)) + threadDelay 500_000 - afterIdle <- mapM readTVarIO fetchVars - zipWith (-) afterIdle bases `shouldBe` [0, 0] - readTVarIO deliveredVar `shouldReturn` 0 + afterIdle <- mapM readTVarIO fetchVars + zipWith (-) afterIdle bases `shouldBe` [0, 0] + readTVarIO deliveredVar `shouldReturn` 0 - -- Liveness: an append to the quiet category wakes both members; - -- exactly the owner of "quiet-1" delivers it. - appendEach store ["quiet-1"] "Quiet" - waitUntil 5_000_000 ((>= 1) <$> readTVarIO deliveredVar) - threadDelay 200_000 - readTVarIO deliveredVar `shouldReturn` 1 + -- Liveness: an append to the quiet category wakes both members; + -- exactly the owner of "quiet-1" delivers it. + appendEach store ["quiet-1"] "Quiet" + waitUntil 5_000_000 ((>= 1) <$> readTVarIO deliveredVar) + threadDelay 200_000 + readTVarIO deliveredVar `shouldReturn` 1 - it "an idle AllStreams consumer-group member wakes a bounded number of times, not a busy spin" $ do - let subName = SubscriptionName "grp-all-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 $all. Its fetches apply the partition - -- predicate, so it receives only its slice of the flood, but every - -- append advances the global position it gates on. - cfg = - (defaultSubscriptionConfig subName AllStreams deliver) - { consumerGroup = Just (validConsumerGroup 0 3) - } - bracket (subscribe store cfg) cancel $ \_handle -> do - waitForSubscriptionLive liveBarrier + it "an idle AllStreams consumer-group member wakes a bounded number of times, not a busy spin" $ do + let subName = SubscriptionName "grp-all-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 $all. Its fetches apply the partition + -- predicate, so it receives only its slice of the flood, but every + -- append advances the global position it gates on. + cfg = + (defaultSubscriptionConfig subName AllStreams deliver) + { consumerGroup = Just (validConsumerGroup 0 3) + } + bracket (subscribe store cfg) cancel $ \_handle -> do + waitForSubscriptionLive liveBarrier - 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 + 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 - delivered <- readTVarIO deliveredVar - -- The corrected gate wakes at most once per observed global position - -- and drains to empty, so fetches stay bounded by the flood size - -- (plus the drain's empty fetch per wake) — NOT the unbounded - -- busy-spin of the old cursor gate, which racks up thousands of - -- empty fetches in 500ms. - afterIdle `shouldSatisfy` (< 50) - delivered `shouldSatisfy` (<= floodCount) + afterIdle <- readTVarIO fetchVar + delivered <- readTVarIO deliveredVar + -- The corrected gate wakes at most once per observed global position + -- and drains to empty, so fetches stay bounded by the flood size + -- (plus the drain's empty fetch per wake) — NOT the unbounded + -- busy-spin of the old cursor gate, which racks up thousands of + -- empty fetches in 500ms. + afterIdle `shouldSatisfy` (< 50) + delivered `shouldSatisfy` (<= floodCount) diff --git a/test/Test/Causation.hs b/test/Test/Causation.hs --- a/test/Test/Causation.hs +++ b/test/Test/Causation.hs @@ -1,15 +1,14 @@ -{- | 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. --} +-- | 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 ((^.)) @@ -28,87 +27,87 @@ 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 + 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 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 + 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 "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]] + 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 + 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 + 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 @@ -117,43 +116,41 @@ 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'). --} +-- | 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@. + EventData + { eventId = fmap EventId mEid, + eventType = EventType typ, + payload = Aeson.Null, + metadata = Nothing, + causationId = mCause, + correlationId = mCorr + } -Expects exactly five UUIDs; calls 'error' on any other length so the -caller's signature stays simple. --} +-- | 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 () + 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] @@ -161,8 +158,8 @@ 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)) + 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 --- a/test/Test/Concurrency.hs +++ b/test/Test/Concurrency.hs @@ -1,13 +1,12 @@ -{- | 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'. --} +-- | 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 @@ -28,301 +27,301 @@ 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 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 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 "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 :: Int)) - (r10 ^. #streamVersion) `shouldBe` StreamVersion 10 - (r10 ^. #globalPosition) `shouldBe` GlobalPosition 10 - Right r100 <- runStoreIO store $ appendToStream stream AnyVersion (mkBatch "Batch100" (100 :: Int)) - (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 "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 :: Int)) + (r10 ^. #streamVersion) `shouldBe` StreamVersion 10 + (r10 ^. #globalPosition) `shouldBe` GlobalPosition 10 + Right r100 <- runStoreIO store $ appendToStream stream AnyVersion (mkBatch "Batch100" (100 :: Int)) + (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 "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 allBefore <- 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 allAfter <- runStoreIO store $ readAllForward (GlobalPosition 0) 100 - globalPositions allAfter `shouldBe` globalPositions allBefore - 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] + 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 allBefore <- 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 allAfter <- runStoreIO store $ readAllForward (GlobalPosition 0) 100 + globalPositions allAfter `shouldBe` globalPositions allBefore + 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) + -- 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 + -- 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] + -- 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] - -- EP-4 M3 — Best-effort regression for the single-stream append retry. - -- The race can pass vacuously on fast machines, but it must never surface - -- PostgreSQL's transient transaction SQLSTATEs (40001/40P01) to callers as - -- UnexpectedServerError. - -- - -- Note what is and is not asserted. The store retries once, and no bounded - -- retry can promise that a repeated conflict never reaches the caller -- - -- under contention this shape does deadlock, because a multi-stream append - -- whose later stream is fresh takes $all before that stream's row while a - -- single-stream append takes them in the opposite order (see IR-7). So a - -- surfaced conflict is allowed; what is not allowed is surfacing it as - -- UnexpectedServerError, which documents itself as "not generally - -- retryable -- investigate" and would send a caller to diagnose a - -- condition whose correct handling is to retry. - it "single-stream append retry does not leak transient SQLSTATEs" $ - withTestStore $ \store -> do - forM_ [1 .. 25 :: Int] $ \i -> do - let a = StreamName ("retry-a-" <> T.pack (show i)) - b = StreamName ("retry-b-" <> T.pack (show i)) - multi = - appendMultiStream - [ (a, NoStream, [makeEvent "A" (Aeson.object [])]) - , (b, AnyVersion, [makeEvent "B-multi" (Aeson.object [])]) - ] - single = - appendToStream b NoStream [makeEvent "B-single" (Aeson.object [])] - (multiResult, singleResult) <- - Async.concurrently - (runStoreIO store multi) - (runStoreIO store single) - assertNoTransientLeak ("multi round " <> show i) multiResult - assertNoTransientLeak ("single round " <> show i) singleResult + -- EP-4 M3 — Best-effort regression for the single-stream append retry. + -- The race can pass vacuously on fast machines, but it must never surface + -- PostgreSQL's transient transaction SQLSTATEs (40001/40P01) to callers as + -- UnexpectedServerError. + -- + -- Note what is and is not asserted. The store retries once, and no bounded + -- retry can promise that a repeated conflict never reaches the caller -- + -- under contention this shape does deadlock, because a multi-stream append + -- whose later stream is fresh takes $all before that stream's row while a + -- single-stream append takes them in the opposite order (see IR-7). So a + -- surfaced conflict is allowed; what is not allowed is surfacing it as + -- UnexpectedServerError, which documents itself as "not generally + -- retryable -- investigate" and would send a caller to diagnose a + -- condition whose correct handling is to retry. + it "single-stream append retry does not leak transient SQLSTATEs" $ + withTestStore $ \store -> do + forM_ [1 .. 25 :: Int] $ \i -> do + let a = StreamName ("retry-a-" <> T.pack (show i)) + b = StreamName ("retry-b-" <> T.pack (show i)) + multi = + appendMultiStream + [ (a, NoStream, [makeEvent "A" (Aeson.object [])]), + (b, AnyVersion, [makeEvent "B-multi" (Aeson.object [])]) + ] + single = + appendToStream b NoStream [makeEvent "B-single" (Aeson.object [])] + (multiResult, singleResult) <- + Async.concurrently + (runStoreIO store multi) + (runStoreIO store single) + assertNoTransientLeak ("multi round " <> show i) multiResult + assertNoTransientLeak ("single round " <> show i) singleResult assertRightAppend :: Either StoreError AppendResult -> IO () assertRightAppend = \case - Right _ -> pure () - Left err -> expectationFailure ("append should succeed, got: " <> show err) + 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) + Right _ -> pure () + Left err -> expectationFailure ("appendMultiStream should succeed, got: " <> show err) assertNoTransientLeak :: String -> Either StoreError a -> IO () assertNoTransientLeak label = \case - Left (UnexpectedServerError code message) - | code == "40P01" || code == "40001" -> - expectationFailure - ( label - <> ": transient SQLSTATE " - <> show code - <> " surfaced as UnexpectedServerError instead of " - <> "TransientTransactionFailure: " - <> show message - ) - _ -> - pure () + Left (UnexpectedServerError code message) + | code == "40P01" || code == "40001" -> + expectationFailure + ( label + <> ": transient SQLSTATE " + <> show code + <> " surfaced as UnexpectedServerError instead of " + <> "TransientTransactionFailure: " + <> show message + ) + _ -> + pure () streamVersions :: V.Vector RecordedEvent -> [Int64] streamVersions = - map - (\e -> case e ^. #streamVersion of StreamVersion n -> n) - . V.toList + 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 + map + (\e -> case e ^. #globalPosition of GlobalPosition n -> n) + . V.toList eventIds :: V.Vector RecordedEvent -> [EventId] eventIds = - map (^. #eventId) - . V.toList + map (^. #eventId) + . V.toList labelStream :: StreamName -> Text labelStream (StreamName name) = name diff --git a/test/Test/ConsumerGroup.hs b/test/Test/ConsumerGroup.hs --- a/test/Test/ConsumerGroup.hs +++ b/test/Test/ConsumerGroup.hs @@ -1,13 +1,12 @@ {-# 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. --} +-- | 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) @@ -42,296 +41,294 @@ -- | 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 - ) + ( 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 + 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 + | 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). --} +-- | 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) + 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 + Text -> Text -> Int32 -> Int32 -> EventHandler -> SubscriptionConfig memberConfig nm cat m n h = - (defaultSubscriptionConfig (SubscriptionName nm) (Category (CategoryName cat)) h) - { consumerGroup = Just (validConsumerGroup m n) - } + (defaultSubscriptionConfig (SubscriptionName nm) (Category (CategoryName cat)) h) + { consumerGroup = Just (validConsumerGroup m n) + } -- | A size-@n@ @$all@-group config for member @m@ with the given handler. memberConfigAll :: - Text -> Int32 -> Int32 -> EventHandler -> SubscriptionConfig + Text -> Int32 -> Int32 -> EventHandler -> SubscriptionConfig memberConfigAll nm m n h = - (defaultSubscriptionConfig (SubscriptionName nm) AllStreams h) - { consumerGroup = Just (validConsumerGroup m n) - } + (defaultSubscriptionConfig (SubscriptionName nm) AllStreams h) + { consumerGroup = Just (validConsumerGroup m 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. --} +-- | 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 + 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 + 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)) + 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 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 + 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 + 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)) + 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 + 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 <- + 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 + 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 :: Int - 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)) + it "$all group partitions the whole store across members" $ + withTestStore $ \store -> do + let cats = ["acct", "user", "order"] + perCat = 10 :: Int + 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 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 + 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 + 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 :: Int - streams = ["rz-" <> T.pack (show i) | i <- [1 .. nStreams]] - seed store streams 1 - waitForPublisher store (GlobalPosition (fromIntegral nStreams)) + it "resumes member 2 from its own (name, member) checkpoint" $ + withTestStore $ \store -> do + let nStreams = 60 :: Int + 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) + -- 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 + -- 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, 4 :: Int32, "category", Just "rz") - SQL.saveCheckpointMemberStmt + -- 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, 4 :: Int32, "category", Just "rz") + 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) + -- 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 "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 + 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 (validConsumerGroup 3 4) - , consumerGroupGuard = True - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , 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) + let cfg = + (defaultSubscriptionConfig (SubscriptionName "guard-sub") (Category (CategoryName "guardcat")) (\_ -> pure Continue)) + { consumerGroup = Just (validConsumerGroup 3 4), + consumerGroupGuard = True, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + 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)) + 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) + 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)) (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 64)) - pulled <- Stream.toList (Stream.take k stream) - cancelStream - sort (map (snd . pairOf) pulled) `shouldBe` slicePos + (stream, cancelStream) <- + subscriptionStream store (memberConfig "bridge-sub" "bridge" 0 2 (\_ -> pure Continue)) (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 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 --- a/test/Test/ConsumerGroupEffect.hs +++ b/test/Test/ConsumerGroupEffect.hs @@ -2,35 +2,34 @@ {-# 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@. --} +-- | 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) @@ -58,150 +57,148 @@ -- | 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 - ) + ( 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 + 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). --} +-- | 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) + 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 + 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. --} +-- | 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 (validConsumerGroup m 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 + 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 (validConsumerGroup m 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)) + 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 + -- 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 + -- 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 + -- (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) + 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 (validConsumerGroup 0 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 () + -- '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 (validConsumerGroup 0 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] + seen <- reverse <$> readIORef seenRef + seen `shouldBe` [1, 2, 3, 4, 5] diff --git a/test/Test/ConsumerGroupResize.hs b/test/Test/ConsumerGroupResize.hs --- a/test/Test/ConsumerGroupResize.hs +++ b/test/Test/ConsumerGroupResize.hs @@ -32,174 +32,174 @@ spec :: Spec spec = describe "consumer-group resize" $ do - it "rejects invalid sizes and member indices at construction" $ do - mkConsumerGroupSize 0 `shouldBe` Left (InvalidConsumerGroup 0 0) - mkConsumerGroupSize (-1) `shouldBe` Left (InvalidConsumerGroup 0 (-1)) - let size2 = groupSize 2 - mkConsumerGroup (-1) size2 `shouldBe` Left (InvalidConsumerGroup (-1) 2) - mkConsumerGroup 2 size2 `shouldBe` Left (InvalidConsumerGroup 2 2) - mkConsumerGroup 1 size2 `shouldBe` Right (validConsumerGroup 1 2) + it "rejects invalid sizes and member indices at construction" $ do + mkConsumerGroupSize 0 `shouldBe` Left (InvalidConsumerGroup 0 0) + mkConsumerGroupSize (-1) `shouldBe` Left (InvalidConsumerGroup 0 (-1)) + let size2 = groupSize 2 + mkConsumerGroup (-1) size2 `shouldBe` Left (InvalidConsumerGroup (-1) 2) + mkConsumerGroup 2 size2 `shouldBe` Left (InvalidConsumerGroup 2 2) + mkConsumerGroup 1 size2 `shouldBe` Right (validConsumerGroup 1 2) - it "refuses a configured size that disagrees with stored topology before creating a member" $ do - refusals <- newIORef [] - let observe = \case - KirokuEventSubscriptionGroupSizeMismatch refusal group -> modifyIORef' refusals ((refusal, group) :) - _ -> pure () - withTestStoreSettings (\settings -> settings{eventHandler = Just observe}) $ \store -> do - seedCheckpoint store "mismatch" 0 2 5 - called <- newIORef False - handle <- subscribe store $ config "mismatch" 2 3 $ \_ -> writeIORef called True >> pure Continue - expectMismatch handle "mismatch" 3 [2] - readIORef called `shouldReturn` False - rows store "mismatch" `shouldReturn` [(0, 2, 5)] - readIORef refusals `shouldReturn` [(ConsumerGroupSizeMismatch (SubscriptionName "mismatch") 3 (Vector.singleton 2), GroupMember 2 3)] + it "refuses a configured size that disagrees with stored topology before creating a member" $ do + refusals <- newIORef [] + let observe = \case + KirokuEventSubscriptionGroupSizeMismatch refusal group -> modifyIORef' refusals ((refusal, group) :) + _ -> pure () + withTestStoreSettings (\settings -> settings {eventHandler = Just observe}) $ \store -> do + seedCheckpoint store "mismatch" 0 2 5 + called <- newIORef False + handle <- subscribe store $ config "mismatch" 2 3 $ \_ -> writeIORef called True >> pure Continue + expectMismatch handle "mismatch" 3 [2] + readIORef called `shouldReturn` False + rows store "mismatch" `shouldReturn` [(0, 2, 5)] + readIORef refusals `shouldReturn` [(ConsumerGroupSizeMismatch (SubscriptionName "mismatch") 3 (Vector.singleton 2), GroupMember 2 3)] - it "also refuses an ordinary subscription over an existing larger group" $ - withTestStore $ \store -> do - seedCheckpoint store "ordinary-mismatch" 0 2 0 - handle <- subscribe store (defaultSubscriptionConfig (SubscriptionName "ordinary-mismatch") AllStreams (\_ -> pure Continue)) - expectMismatch handle "ordinary-mismatch" 1 [2] + it "also refuses an ordinary subscription over an existing larger group" $ + withTestStore $ \store -> do + seedCheckpoint store "ordinary-mismatch" 0 2 0 + handle <- subscribe store (defaultSubscriptionConfig (SubscriptionName "ordinary-mismatch") AllStreams (\_ -> pure Continue)) + expectMismatch handle "ordinary-mismatch" 1 [2] - it "refuses an underestimated derived topology until resized" $ - withTestStore $ \store -> do - -- The upgrade test proves a lone legacy member derives size 1. - seedCheckpoint store "underestimated" 0 1 8 - refused <- subscribe store (config "underestimated" 0 2 (\_ -> pure Continue)) - expectMismatch refused "underestimated" 2 [1] - void $ resize store "underestimated" 2 - accepted <- subscribe store (config "underestimated" 0 2 (\_ -> pure Continue)) - awaitLive accepted - cancel accepted - rows store "underestimated" `shouldReturn` [(0, 2, 8), (1, 2, 8)] + it "refuses an underestimated derived topology until resized" $ + withTestStore $ \store -> do + -- The upgrade test proves a lone legacy member derives size 1. + seedCheckpoint store "underestimated" 0 1 8 + refused <- subscribe store (config "underestimated" 0 2 (\_ -> pure Continue)) + expectMismatch refused "underestimated" 2 [1] + void $ resize store "underestimated" 2 + accepted <- subscribe store (config "underestimated" 0 2 (\_ -> pure Continue)) + awaitLive accepted + cancel accepted + rows store "underestimated" `shouldReturn` [(0, 2, 8), (1, 2, 8)] - it "refuses mixed stored sizes even when its own row agrees" $ - withTestStore $ \store -> do - seedCheckpoint store "mixed" 0 2 0 - seedCheckpoint store "mixed" 1 3 0 - handle <- subscribe store (config "mixed" 0 2 (\_ -> pure Continue)) - expectMismatch handle "mixed" 2 [2, 3] + it "refuses mixed stored sizes even when its own row agrees" $ + withTestStore $ \store -> do + seedCheckpoint store "mixed" 0 2 0 + seedCheckpoint store "mixed" 1 3 0 + handle <- subscribe store (config "mixed" 0 2 (\_ -> pure Continue)) + expectMismatch handle "mixed" 2 [2, 3] - it "serializes concurrent initializers with competing group sizes" $ - withTestStore $ \store -> do - [firstHandle, secondHandle] <- Async.mapConcurrently (\n -> subscribe store (config "concurrent" 0 n (\_ -> pure Continue))) [2, 3] - -- The winner reaches Live; the loser exits with a typed refusal. - result <- timeout 5_000_000 $ Async.race (wait firstHandle) (wait secondHandle) - case result of - Just (Left outcome) -> assertMismatch outcome - Just (Right outcome) -> assertMismatch outcome - Nothing -> expectationFailure "competing topology startup timed out" - mapM_ cancel [firstHandle, secondHandle] - stored <- rows store "concurrent" - length stored `shouldBe` 1 - stored `shouldSatisfy` \case [(0, n, 0)] -> n == 2 || n == 3; _ -> False + it "serializes concurrent initializers with competing group sizes" $ + withTestStore $ \store -> do + [firstHandle, secondHandle] <- Async.mapConcurrently (\n -> subscribe store (config "concurrent" 0 n (\_ -> pure Continue))) [2, 3] + -- The winner reaches Live; the loser exits with a typed refusal. + result <- timeout 5_000_000 $ Async.race (wait firstHandle) (wait secondHandle) + case result of + Just (Left outcome) -> assertMismatch outcome + Just (Right outcome) -> assertMismatch outcome + Nothing -> expectationFailure "competing topology startup timed out" + mapM_ cancel [firstHandle, secondHandle] + stored <- rows store "concurrent" + length stored `shouldBe` 1 + stored `shouldSatisfy` \case [(0, n, 0)] -> n == 2 || n == 3; _ -> False - it "persists configured topology on initialization, ordinary saves and dead-letter saves" $ - withTestStore $ \store -> do - void $ runStoreIO store $ appendToStream (StreamName "persist-1") NoStream [makeEvent "E" (Aeson.object [])] - -- A size-1 group exercises all rows deterministically. Size >1 is - -- checked below via explicit ordinary and dead-letter SQL paths. - handle <- subscribe store (config "saved" 0 1 (\_ -> pure Stop)) - expectClean handle - rows store "saved" `shouldReturn` [(0, 1, 1)] - live <- subscribe store ((config "initialized" 2 3 (\_ -> pure Continue)){missingCheckpointPolicy = FromCurrentHead}) - awaitLive live - cancel live - rows store "initialized" `shouldReturn` [(2, 3, 1)] - seedCheckpoint store "saved-size" 1 4 20 - seedCheckpoint store "saved-size" 1 4 10 - rows store "saved-size" `shouldReturn` [(1, 4, 20)] - Right events <- runStoreIO store (readAllForward (GlobalPosition 0) 10) - let event = Vector.head events - EventId eid = event ^. #eventId - params = SQL.DeadLetterParams "dead-letter-size" 1 "unbound" Nothing 4 1 eid (Aeson.object []) "test" 1 - runSession store (Session.statement params SQL.insertDeadLetterAndCheckpointStmt) - rows store "dead-letter-size" `shouldReturn` [(1, 4, 1)] - let StreamId sid = event ^. #originalStreamId - ownerStmt = - preparable - "SELECT (((hashtextextended($1::bigint::text, 0) % 4) + 4) % 4)::int4" - (E.param (E.nonNullable E.int8)) - (D.singleRow (D.column (D.nonNullable D.int4))) - owner <- runSession store (Session.statement sid ownerStmt) - saved <- subscribe store (config "worker-save-size" owner 4 (\_ -> pure Stop)) - expectClean saved - rows store "worker-save-size" `shouldReturn` [(owner, 4, 1)] - deadLettered <- subscribe store (config "worker-dead-letter-size" owner 4 (\_ -> pure (DeadLetter (DeadLetterPoison "explicit consumer decision")))) - awaitLive deadLettered - cancel deadLettered - rows store "worker-dead-letter-size" `shouldReturn` [(owner, 4, 1)] + it "persists configured topology on initialization, ordinary saves and dead-letter saves" $ + withTestStore $ \store -> do + void $ runStoreIO store $ appendToStream (StreamName "persist-1") NoStream [makeEvent "E" (Aeson.object [])] + -- A size-1 group exercises all rows deterministically. Size >1 is + -- checked below via explicit ordinary and dead-letter SQL paths. + handle <- subscribe store (config "saved" 0 1 (\_ -> pure Stop)) + expectClean handle + rows store "saved" `shouldReturn` [(0, 1, 1)] + live <- subscribe store ((config "initialized" 2 3 (\_ -> pure Continue)) {missingCheckpointPolicy = FromCurrentHead}) + awaitLive live + cancel live + rows store "initialized" `shouldReturn` [(2, 3, 1)] + seedCheckpoint store "saved-size" 1 4 20 + seedCheckpoint store "saved-size" 1 4 10 + rows store "saved-size" `shouldReturn` [(1, 4, 20)] + Right events <- runStoreIO store (readAllForward (GlobalPosition 0) 10) + let event = Vector.head events + EventId eid = event ^. #eventId + params = SQL.DeadLetterParams "dead-letter-size" 1 "unbound" Nothing 4 1 eid (Aeson.object []) "test" 1 + runSession store (Session.statement params SQL.insertDeadLetterAndCheckpointStmt) + rows store "dead-letter-size" `shouldReturn` [(1, 4, 1)] + let StreamId sid = event ^. #originalStreamId + ownerStmt = + preparable + "SELECT (((hashtextextended($1::bigint::text, 0) % 4) + 4) % 4)::int4" + (E.param (E.nonNullable E.int8)) + (D.singleRow (D.column (D.nonNullable D.int4))) + owner <- runSession store (Session.statement sid ownerStmt) + saved <- subscribe store (config "worker-save-size" owner 4 (\_ -> pure Stop)) + expectClean saved + rows store "worker-save-size" `shouldReturn` [(owner, 4, 1)] + deadLettered <- subscribe store (config "worker-dead-letter-size" owner 4 (\_ -> pure (DeadLetter (DeadLetterPoison "explicit consumer decision")))) + awaitLive deadLettered + cancel deadLettered + rows store "worker-dead-letter-size" `shouldReturn` [(owner, 4, 1)] - it "delivers every seeded event after equalizing size 2 to size 3" $ - withTestStore $ \store -> do - forM_ [1 .. 40 :: Int] $ \i -> do - result <- runStoreIO store $ appendToStream (StreamName ("resize-" <> Text.pack (show i))) NoStream [makeEvent "E" (Aeson.object [])] - result `shouldSatisfy` either (const False) (const True) - Right events <- runStoreIO store (readAllForward (GlobalPosition 0) 100) - let expected = Set.fromList [event ^. #eventId | event <- Vector.toList events] - -- Member 0 has seen nothing, member 1 has crossed the full log. - -- Remember its actual delivered set; a naive size change loses - -- streams that move from old member 0 to new member 1. - oldFast <- runSession store (Session.statement (0, 1, 2, 100) SQL.readAllForwardConsumerGroupStmt) - naive <- mapM (\(m, p) -> runSession store (Session.statement (p, m, 3, 100) SQL.readAllForwardConsumerGroupStmt)) [(0, 0), (1, 40), (2, 0)] - let alreadySeen = Set.fromList [e ^. #eventId | e <- Vector.toList oldFast] - naiveSeen = Set.fromList [e ^. #eventId | batch <- naive, e <- Vector.toList batch] - Set.union alreadySeen naiveSeen `shouldNotBe` expected - seedCheckpoint store "skewed" 0 2 0 - seedCheckpoint store "skewed" 1 2 40 - refused <- subscribe store (config "skewed" 1 3 (\_ -> pure Continue)) - expectMismatch refused "skewed" 3 [2] - report <- resize store "skewed" 3 - report `shouldBe` ConsumerGroupResizeReport (Vector.singleton 2) 2 (groupSize 3) (GlobalPosition 0) - delivered <- newTVarIO alreadySeen - handles <- mapM (\m -> subscribe store (config "skewed" m 3 (\e -> atomically (modifyTVar' delivered (Set.insert (e ^. #eventId))) >> pure Continue))) [0, 1, 2] - complete <- timeout 15_000_000 (atomically (readTVar delivered >>= check . (== expected))) - mapM_ cancel handles - complete `shouldBe` Just () - readTVarIO delivered `shouldReturn` expected + it "delivers every seeded event after equalizing size 2 to size 3" $ + withTestStore $ \store -> do + forM_ [1 .. 40 :: Int] $ \i -> do + result <- runStoreIO store $ appendToStream (StreamName ("resize-" <> Text.pack (show i))) NoStream [makeEvent "E" (Aeson.object [])] + result `shouldSatisfy` either (const False) (const True) + Right events <- runStoreIO store (readAllForward (GlobalPosition 0) 100) + let expected = Set.fromList [event ^. #eventId | event <- Vector.toList events] + -- Member 0 has seen nothing, member 1 has crossed the full log. + -- Remember its actual delivered set; a naive size change loses + -- streams that move from old member 0 to new member 1. + oldFast <- runSession store (Session.statement (0, 1, 2, 100) SQL.readAllForwardConsumerGroupStmt) + naive <- mapM (\(m, p) -> runSession store (Session.statement (p, m, 3, 100) SQL.readAllForwardConsumerGroupStmt)) [(0, 0), (1, 40), (2, 0)] + let alreadySeen = Set.fromList [e ^. #eventId | e <- Vector.toList oldFast] + naiveSeen = Set.fromList [e ^. #eventId | batch <- naive, e <- Vector.toList batch] + Set.union alreadySeen naiveSeen `shouldNotBe` expected + seedCheckpoint store "skewed" 0 2 0 + seedCheckpoint store "skewed" 1 2 40 + refused <- subscribe store (config "skewed" 1 3 (\_ -> pure Continue)) + expectMismatch refused "skewed" 3 [2] + report <- resize store "skewed" 3 + report `shouldBe` ConsumerGroupResizeReport (Vector.singleton 2) 2 (groupSize 3) (GlobalPosition 0) + delivered <- newTVarIO alreadySeen + handles <- mapM (\m -> subscribe store (config "skewed" m 3 (\e -> atomically (modifyTVar' delivered (Set.insert (e ^. #eventId))) >> pure Continue))) [0, 1, 2] + complete <- timeout 15_000_000 (atomically (readTVar delivered >>= check . (== expected))) + mapM_ cancel handles + complete `shouldBe` Just () + readTVarIO delivered `shouldReturn` expected - it "is idempotent when repeated at the same size and retains surviving member identities" $ - withTestStore $ \store -> do - seedCheckpoint store "repeat" 0 2 5 - seedCheckpoint store "repeat" 1 2 20 - oldIds <- memberIds store "repeat" - void $ resize store "repeat" 3 - originalRows <- rows store "repeat" - resizedIds <- memberIds store "repeat" - take 2 resizedIds `shouldBe` oldIds - second <- resize store "repeat" 3 - rows store "repeat" `shouldReturn` originalRows - memberIds store "repeat" `shouldReturn` resizedIds - originalRows `shouldBe` [(0, 3, 5), (1, 3, 5), (2, 3, 5)] - resumePosition second `shouldBe` GlobalPosition 5 - previousMemberCount second `shouldBe` 3 + it "is idempotent when repeated at the same size and retains surviving member identities" $ + withTestStore $ \store -> do + seedCheckpoint store "repeat" 0 2 5 + seedCheckpoint store "repeat" 1 2 20 + oldIds <- memberIds store "repeat" + void $ resize store "repeat" 3 + originalRows <- rows store "repeat" + resizedIds <- memberIds store "repeat" + take 2 resizedIds `shouldBe` oldIds + second <- resize store "repeat" 3 + rows store "repeat" `shouldReturn` originalRows + memberIds store "repeat" `shouldReturn` resizedIds + originalRows `shouldBe` [(0, 3, 5), (1, 3, 5), (2, 3, 5)] + resumePosition second `shouldBe` GlobalPosition 5 + previousMemberCount second `shouldBe` 3 - it "starts a missing group at zero and removes obsolete members on shrink" $ - withTestStore $ \store -> do - report <- resize store "missing" 3 - previousMemberCount report `shouldBe` 0 - resumePosition report `shouldBe` GlobalPosition 0 - rows store "missing" `shouldReturn` [(0, 3, 0), (1, 3, 0), (2, 3, 0)] - void $ resize store "missing" 1 - rows store "missing" `shouldReturn` [(0, 1, 0)] + it "starts a missing group at zero and removes obsolete members on shrink" $ + withTestStore $ \store -> do + report <- resize store "missing" 3 + previousMemberCount report `shouldBe` 0 + resumePosition report `shouldBe` GlobalPosition 0 + rows store "missing" `shouldReturn` [(0, 3, 0), (1, 3, 0), (2, 3, 0)] + void $ resize store "missing" 1 + rows store "missing" `shouldReturn` [(0, 1, 0)] - it "rolls back the complete resize with the caller transaction" $ - withTestStore $ \store -> do - seedCheckpoint store "rollback" 0 2 5 - seedCheckpoint store "rollback" 1 2 20 - void $ runSession store $ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do - report <- resizeConsumerGroupTx (SubscriptionName "rollback") (groupSize 3) - Tx.condemn - pure report - rows store "rollback" `shouldReturn` [(0, 2, 5), (1, 2, 20)] + it "rolls back the complete resize with the caller transaction" $ + withTestStore $ \store -> do + seedCheckpoint store "rollback" 0 2 5 + seedCheckpoint store "rollback" 1 2 20 + void $ runSession store $ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do + report <- resizeConsumerGroupTx (SubscriptionName "rollback") (groupSize 3) + Tx.condemn + pure report + rows store "rollback" `shouldReturn` [(0, 2, 5), (1, 2, 20)] groupSize :: Int32 -> ConsumerGroupSize groupSize = either (error . show) Prelude.id . mkConsumerGroupSize config :: Text -> Int32 -> Int32 -> EventHandler -> SubscriptionConfig config name m n handler = - (defaultSubscriptionConfig (SubscriptionName name) AllStreams handler) - { consumerGroup = Just (validConsumerGroup m n) - } + (defaultSubscriptionConfig (SubscriptionName name) AllStreams handler) + { consumerGroup = Just (validConsumerGroup m n) + } seedCheckpoint :: KirokuStore -> Text -> Int32 -> Int32 -> Int64 -> IO () seedCheckpoint store name m n p = runSession store (Session.statement (name, m, p, n, "unbound", Nothing) SQL.saveCheckpointMemberStmt) @@ -211,47 +211,47 @@ rows store name = Vector.toList <$> runSession store (Session.statement name stmt) where stmt = - preparable - "SELECT consumer_group_member, consumer_group_size, last_seen FROM subscriptions WHERE subscription_name = $1 ORDER BY consumer_group_member" - (E.param (E.nonNullable E.text)) - (D.rowVector ((,,) <$> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.int8))) + preparable + "SELECT consumer_group_member, consumer_group_size, last_seen FROM subscriptions WHERE subscription_name = $1 ORDER BY consumer_group_member" + (E.param (E.nonNullable E.text)) + (D.rowVector ((,,) <$> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.int8))) runSession :: KirokuStore -> Session.Session a -> IO a runSession store session = Pool.use (store ^. #pool) session >>= either (error . show) pure expectMismatch :: SubscriptionHandle -> Text -> Int32 -> [Int32] -> IO () expectMismatch handle name n observed = do - result <- waitWithTimeout 5_000_000 handle - case result of - Right (Left exception) -> fromException exception `shouldBe` Just (ConsumerGroupSizeMismatch (SubscriptionName name) n (Vector.fromList observed)) - other -> expectationFailure ("expected topology mismatch, got " <> show other) + result <- waitWithTimeout 5_000_000 handle + case result of + Right (Left exception) -> fromException exception `shouldBe` Just (ConsumerGroupSizeMismatch (SubscriptionName name) n (Vector.fromList observed)) + other -> expectationFailure ("expected topology mismatch, got " <> show other) assertMismatch :: Either SomeException () -> IO () assertMismatch = \case - Left exception -> (fromException exception :: Maybe ConsumerGroupSizeMismatch) `shouldSatisfy` maybe False (const True) - Right () -> expectationFailure "expected competing-size startup refusal" + Left exception -> (fromException exception :: Maybe ConsumerGroupSizeMismatch) `shouldSatisfy` maybe False (const True) + Right () -> expectationFailure "expected competing-size startup refusal" expectClean :: SubscriptionHandle -> IO () expectClean handle = - waitWithTimeout 5_000_000 handle >>= \case - Right (Right ()) -> pure () - other -> expectationFailure (show other) + waitWithTimeout 5_000_000 handle >>= \case + Right (Right ()) -> pure () + other -> expectationFailure (show other) awaitLive :: SubscriptionHandle -> IO () awaitLive handle = do - result <- timeout 5_000_000 loop - result `shouldBe` Just () + result <- timeout 5_000_000 loop + result `shouldBe` Just () where loop = - currentState handle >>= \case - Just state | stateName state == "live" -> pure () - _ -> threadDelay 1_000 >> loop + currentState handle >>= \case + Just state | stateName state == "live" -> pure () + _ -> threadDelay 1_000 >> loop memberIds :: KirokuStore -> Text -> IO [Int64] memberIds store name = - runSession store $ - Session.statement name $ - preparable - "SELECT subscription_id FROM subscriptions WHERE subscription_name = $1 ORDER BY consumer_group_member" - (E.param (E.nonNullable E.text)) - (D.rowList (D.column (D.nonNullable D.int8))) + runSession store $ + Session.statement name $ + preparable + "SELECT subscription_id FROM subscriptions WHERE subscription_name = $1 ORDER BY consumer_group_member" + (E.param (E.nonNullable E.text)) + (D.rowList (D.column (D.nonNullable D.int8))) diff --git a/test/Test/ConsumerGroupSql.hs b/test/Test/ConsumerGroupSql.hs --- a/test/Test/ConsumerGroupSql.hs +++ b/test/Test/ConsumerGroupSql.hs @@ -1,15 +1,14 @@ {-# 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. --} +-- | 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) @@ -41,26 +40,25 @@ -- | 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 + 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. --} +-- | 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 + 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] @@ -69,30 +67,29 @@ -- | 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 - ) + map + ( \e -> + ( case e ^. #originalStreamId of StreamId s -> s, + case e ^. #globalPosition of GlobalPosition p -> p ) - . V.toList + ) + . 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. --} +-- | 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))) + 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] @@ -100,11 +97,11 @@ spec :: Spec spec = do - describe "ConsumerGroupSql" $ do - categorySpec - checkpointSpec - allSpec - memberOfSpec + describe "ConsumerGroupSql" $ do + categorySpec + checkpointSpec + allSpec + memberOfSpec -- --------------------------------------------------------------------------- -- M1: category partitioning @@ -112,66 +109,66 @@ 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 + 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 + 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 "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 "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 "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 "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 + 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 @@ -179,34 +176,34 @@ checkpointSpec :: Spec checkpointSpec = around withTestStore $ do - describe "per-member checkpoints" $ do - let subName = "proj-acct" :: Text + 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, 2 :: Int32, "unbound", Nothing) SQL.saveCheckpointMemberStmt - runStmt store $ Session.statement (subName, 1 :: Int32, 13 :: Int64, 2 :: Int32, "unbound", Nothing) 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 "stores and reads independent checkpoints per member" $ \store -> do + runStmt store $ Session.statement (subName, 0 :: Int32, 7 :: Int64, 2 :: Int32, "unbound", Nothing) SQL.saveCheckpointMemberStmt + runStmt store $ Session.statement (subName, 1 :: Int32, 13 :: Int64, 2 :: Int32, "unbound", Nothing) 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, 2 :: Int32, "unbound", Nothing) SQL.saveCheckpointMemberStmt - runStmt store $ Session.statement (subName, 0 :: Int32, 5 :: Int64, 2 :: Int32, "unbound", Nothing) SQL.saveCheckpointMemberStmt - m0 <- runStmt store $ Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt - m0 `shouldBe` Just 20 + it "never moves a member checkpoint backward (GREATEST monotonicity)" $ \store -> do + runStmt store $ Session.statement (subName, 0 :: Int32, 20 :: Int64, 2 :: Int32, "unbound", Nothing) SQL.saveCheckpointMemberStmt + runStmt store $ Session.statement (subName, 0 :: Int32, 5 :: Int64, 2 :: Int32, "unbound", Nothing) 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 "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 + 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 @@ -214,58 +211,58 @@ 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 + 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 + 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 "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 "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 "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 + 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. @@ -273,15 +270,15 @@ 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 + 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/DeadLetterQueryPlans.hs b/test/Test/DeadLetterQueryPlans.hs --- a/test/Test/DeadLetterQueryPlans.hs +++ b/test/Test/DeadLetterQueryPlans.hs @@ -25,74 +25,80 @@ spec :: Spec spec = describe "dead-letter production query plans" $ around withTestStore $ it "bounds historical-member enumeration and first/later pages in generic/custom plans as history grows" $ \store -> do - execute store "INSERT INTO events(event_id,event_type,data,created_at) VALUES ('00000000-0000-0000-0000-000000000001','E','{}',now())" - forM_ ["1000", "20000"] $ \history -> do - execute store ("INSERT INTO dead_letters(subscription_name,consumer_group_member,global_position,event_id,reason,reason_summary,attempt_count) SELECT 'plans',m,n,'00000000-0000-0000-0000-000000000001','{}','fixture',1 FROM unnest(ARRAY[0,1,9]) m CROSS JOIN generate_series(1," <> history <> ") n ON CONFLICT DO NOTHING; ANALYZE dead_letters") - forM_ ["force_generic_plan", "force_custom_plan"] $ \mode -> do - memberFirst <- explain store mode "text,int4,int4" "'plans',9,6" SQL.listSubscriptionMemberDeadLettersFromStartStmt - memberLater <- explain store mode "text,int4,int8,int8,int4" "'plans',9,500,9223372036854775807,6" SQL.listSubscriptionMemberDeadLettersStmt - allFirst <- explain store mode "text,int4" "'plans',6" SQL.listSubscriptionDeadLettersFromStartStmt - allLater <- explain store mode "text,int8,int8,int4" "'plans',500,9223372036854775807,6" SQL.listSubscriptionDeadLettersStmt - forM_ [memberFirst, memberLater] $ \plan -> do - expect ("index" :: Text) plan ("ix_dead_letters_subscription_position" `elem` texts "Index Name" plan) - expect "member page work" plan (scanned plan <= 6) - expect "no member sort" plan ("Sort" `notElem` texts "Node Type" plan) - forM_ [allFirst, allLater] $ \plan -> do - -- Three loose member probes plus three bounded lateral scans. - expect "bounded member enumeration/page" plan (scanned plan <= 24) - expect "bounded merge input" plan (sum (sortInputs plan) <= 18) - -- The existing natural-key index has the same (name, member) - -- prefix and can serve the loose member probes too. - expect "existing ordered indexes only" plan (all (`elem` ["ix_dead_letters_subscription_position", "dead_letters_subscription_name_consumer_group_member_global_key"]) (texts "Index Name" plan)) - expect "ordered historical member advance" plan (any ("consumer_group_member >" `contains`) (texts "Index Cond" plan)) - expect "recency index for lateral pages" plan ("ix_dead_letters_subscription_position" `elem` texts "Index Name" plan) - expect "no historical sequential scan" plan ("Seq Scan" `notElem` texts "Node Type" plan) - forM_ [memberLater, allLater] $ \plan -> - expect "tuple cursor in index condition" plan (any (\condition -> "ROW(global_position, dead_letter_id)" `contains` condition) (texts "Index Cond" plan)) - forM_ [memberFirst, memberLater, allFirst, allLater] $ \plan -> - expect "bounded shared buffers" plan (buffers plan <= 128) - -- Preserve the actual production EXPLAIN evidence in the test log. - mapM_ (LBS.putStrLn . Aeson.encode) [memberFirst, memberLater, allFirst, allLater] + execute store "INSERT INTO events(event_id,event_type,data,created_at) VALUES ('00000000-0000-0000-0000-000000000001','E','{}',now())" + forM_ ["1000", "20000"] $ \history -> do + execute store ("INSERT INTO dead_letters(subscription_name,consumer_group_member,global_position,event_id,reason,reason_summary,attempt_count) SELECT 'plans',m,n,'00000000-0000-0000-0000-000000000001','{}','fixture',1 FROM unnest(ARRAY[0,1,9]) m CROSS JOIN generate_series(1," <> history <> ") n ON CONFLICT DO NOTHING; ANALYZE dead_letters") + forM_ ["force_generic_plan", "force_custom_plan"] $ \mode -> do + memberFirst <- explain store mode "text,int4,int4" "'plans',9,6" SQL.listSubscriptionMemberDeadLettersFromStartStmt + memberLater <- explain store mode "text,int4,int8,int8,int4" "'plans',9,500,9223372036854775807,6" SQL.listSubscriptionMemberDeadLettersStmt + allFirst <- explain store mode "text,int4" "'plans',6" SQL.listSubscriptionDeadLettersFromStartStmt + allLater <- explain store mode "text,int8,int8,int4" "'plans',500,9223372036854775807,6" SQL.listSubscriptionDeadLettersStmt + forM_ [memberFirst, memberLater] $ \plan -> do + expect ("index" :: Text) plan ("ix_dead_letters_subscription_position" `elem` texts "Index Name" plan) + expect "member page work" plan (scanned plan <= 6) + expect "no member sort" plan ("Sort" `notElem` texts "Node Type" plan) + forM_ [allFirst, allLater] $ \plan -> do + -- Three loose member probes plus three bounded lateral scans. + expect "bounded member enumeration/page" plan (scanned plan <= 24) + expect "bounded merge input" plan (sum (sortInputs plan) <= 18) + -- The existing natural-key index has the same (name, member) + -- prefix and can serve the loose member probes too. + expect "existing ordered indexes only" plan (all (`elem` ["ix_dead_letters_subscription_position", "dead_letters_subscription_name_consumer_group_member_global_key"]) (texts "Index Name" plan)) + expect "ordered historical member advance" plan (any ("consumer_group_member >" `contains`) (texts "Index Cond" plan)) + expect "recency index for lateral pages" plan ("ix_dead_letters_subscription_position" `elem` texts "Index Name" plan) + expect "no historical sequential scan" plan ("Seq Scan" `notElem` texts "Node Type" plan) + forM_ [memberLater, allLater] $ \plan -> + expect "tuple cursor in index condition" plan (any (\condition -> "ROW(global_position, dead_letter_id)" `contains` condition) (texts "Index Cond" plan)) + forM_ [memberFirst, memberLater, allFirst, allLater] $ \plan -> + expect "bounded shared buffers" plan (buffers plan <= 128) + -- Preserve the actual production EXPLAIN evidence in the test log. + mapM_ (LBS.putStrLn . Aeson.encode) [memberFirst, memberLater, allFirst, allLater] where contains = Data.Text.isInfixOf execute :: KirokuStore -> Text -> IO () execute store sql = Pool.use (store ^. #pool) (Session.script sql) >>= either (fail . show) pure + explain :: KirokuStore -> Text -> Text -> Text -> Statement p r -> IO Value explain store mode types args statement = do - Right bytes <- Pool.use (store ^. #pool) $ do - Session.script ("SET plan_cache_mode=" <> mode <> "; PREPARE mp13_deadletters(" <> types <> ") AS " <> Statement.toSql statement) - bytes <- Session.statement () (unpreparable ("EXPLAIN (ANALYZE,BUFFERS,TIMING OFF,FORMAT JSON) EXECUTE mp13_deadletters(" <> args <> ")") E.noParams (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right))))) - Session.script "DEALLOCATE mp13_deadletters; RESET plan_cache_mode" - pure bytes - either fail pure (Aeson.eitherDecodeStrict' bytes) + Right bytes <- Pool.use (store ^. #pool) $ do + Session.script ("SET plan_cache_mode=" <> mode <> "; PREPARE mp13_deadletters(" <> types <> ") AS " <> Statement.toSql statement) + bytes <- Session.statement () (unpreparable ("EXPLAIN (ANALYZE,BUFFERS,TIMING OFF,FORMAT JSON) EXECUTE mp13_deadletters(" <> args <> ")") E.noParams (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right))))) + Session.script "DEALLOCATE mp13_deadletters; RESET plan_cache_mode" + pure bytes + either fail pure (Aeson.eitherDecodeStrict' bytes) + expect :: Text -> Value -> Bool -> Expectation expect label plan ok = if ok then pure () else expectationFailure (show label <> ": " <> show plan) + texts :: Aeson.Key -> Value -> [Text] texts key (Object fields) = [s | Just (String s) <- [KM.lookup key fields]] <> concatMap (texts key) (KM.elems fields) texts key (Array values) = concatMap (texts key) values texts _ _ = [] + number :: Aeson.Key -> Aeson.Object -> Double number key fields = case KM.lookup key fields of Just (Number n) -> realToFrac n; _ -> 0 + scanned :: Value -> Double scanned (Object fields) = current + sum (map scanned (KM.elems fields)) where current = case KM.lookup "Relation Name" fields of - Just (String "dead_letters") -> (number "Actual Rows" fields + number "Rows Removed by Filter" fields + number "Rows Removed by Index Recheck" fields) * number "Actual Loops" fields - _ -> 0 + Just (String "dead_letters") -> (number "Actual Rows" fields + number "Rows Removed by Filter" fields + number "Rows Removed by Index Recheck" fields) * number "Actual Loops" fields + _ -> 0 scanned (Array values) = sum (map scanned (foldr (:) [] values)) scanned _ = 0 + sortInputs :: Value -> [Double] sortInputs (Object fields) = current <> concatMap sortInputs (KM.elems fields) where current = case (KM.lookup "Node Type" fields, KM.lookup "Plans" fields) of - (Just (String "Sort"), Just (Array children)) -> [number "Actual Rows" child * number "Actual Loops" child | Object child <- foldr (:) [] children] - _ -> [] + (Just (String "Sort"), Just (Array children)) -> [number "Actual Rows" child * number "Actual Loops" child | Object child <- foldr (:) [] children] + _ -> [] sortInputs (Array values) = concatMap sortInputs values sortInputs _ = [] buffers :: Value -> Double buffers (Array values) = case foldr (:) [] values of - Object entry : _ | Just (Object top) <- KM.lookup "Plan" entry -> number "Shared Hit Blocks" top + number "Shared Read Blocks" top - _ -> 1 / 0 + Object entry : _ | Just (Object top) <- KM.lookup "Plan" entry -> number "Shared Hit Blocks" top + number "Shared Read Blocks" top + _ -> 1 / 0 buffers _ = 1 / 0 diff --git a/test/Test/EventTypeFilter.hs b/test/Test/EventTypeFilter.hs --- a/test/Test/EventTypeFilter.hs +++ b/test/Test/EventTypeFilter.hs @@ -1,38 +1,37 @@ {-# 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. --} +-- | 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) @@ -57,17 +56,17 @@ 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 + 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) + 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 @@ -77,12 +76,12 @@ 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) + | 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 []) @@ -102,205 +101,205 @@ 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) + 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 + 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 + 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) + 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 + 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 + 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) + 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 = either (error . show) Prelude.id (mkBatchSize 2000) - } - handle <- subscribe store cfg - reached <- waitForCheckpoint store subT 1002 - cancel handle + 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 = either (error . show) Prelude.id (mkBatchSize 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 + 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) + 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 + 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 + 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) + -- 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 = either (error . show) Prelude.id (mkBatchSize 2000) - } - handle <- subscribe store cfg - reached <- waitForCheckpoint store subT 1002 - cancel handle + deliveredRef <- newIORef ([] :: [Int64]) + let handler' ev = do + modifyIORef' deliveredRef (<> [posOf ev]) + pure Continue + cfg = + (defaultSubscriptionConfig subName AllStreams handler') + { selector = Just keepOnly, + batchSize = either (error . show) Prelude.id (mkBatchSize 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 + 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) + 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 + 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 + 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 --- a/test/Test/FailureInjection.hs +++ b/test/Test/FailureInjection.hs @@ -1,24 +1,23 @@ -{- | 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. --} +-- | 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) @@ -27,90 +26,90 @@ import Data.Generics.Labels () import Data.IORef (modifyIORef', newIORef, readIORef) import Kiroku.Store -import Test.Helpers ( - makeEvent, +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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 + -- 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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/HandlerStall.hs b/test/Test/HandlerStall.hs --- a/test/Test/HandlerStall.hs +++ b/test/Test/HandlerStall.hs @@ -7,6 +7,7 @@ import Control.Lens ((&), (.~), (^.)) import Control.Monad (forM_) import Data.Aeson qualified as Aeson +import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.Maybe (isNothing) import Data.Time (NominalDiffTime) import Data.Vector qualified as V @@ -21,234 +22,245 @@ appendEvents :: KirokuStore -> IO () appendEvents store = do - Right _ <- - runStoreIO store $ - appendToStream - (StreamName "stall-events") - NoStream - [makeEvent "First" (Aeson.object []), makeEvent "Second" (Aeson.object [])] - pure () + Right _ <- + runStoreIO store $ + appendToStream + (StreamName "stall-events") + NoStream + [makeEvent "First" (Aeson.object []), makeEvent "Second" (Aeson.object [])] + pure () checkpoint :: KirokuStore -> IO GlobalPosition checkpoint store = do - Right (SubscriptionCheckpointInventory _ rows) <- runStoreIO store subscriptionCheckpointInventory - case [savedPosition | SubscriptionCheckpoint name _ savedPosition _ <- V.toList rows, name == SubscriptionName "stall-test"] of - [savedPosition] -> pure savedPosition - other -> fail ("unexpected checkpoints: " <> show other) + Right (SubscriptionCheckpointInventory _ rows) <- runStoreIO store subscriptionCheckpointInventory + case [savedPosition | SubscriptionCheckpoint name _ savedPosition _ <- V.toList rows, name == SubscriptionName "stall-test"] of + [savedPosition] -> pure savedPosition + other -> fail ("unexpected checkpoints: " <> show other) spec :: Spec spec = describe "handler stall" $ do - forM_ - [ (AllStreams, Nothing, False) - , (AllStreams, Nothing, True) - , (Category (CategoryName "stall"), Nothing, True) - , (AllStreams, Just (validConsumerGroup 0 1), True) - , (Category (CategoryName "stall"), Just (validConsumerGroup 0 1), False) - ] - $ \(target', group, live) -> - it ("warns without acknowledging or checkpointing a blocked handler for " <> show (target', group, live)) $ do - release <- newEmptyMVar - caughtUp <- newEmptyMVar - warning <- STM.newEmptyTMVarIO - count <- STM.newTVarIO (0 :: Int) - let subName = SubscriptionName "stall-test" - observe event = do - caughtUpEventHandler subName caughtUp Nothing event - case event of - KirokuEventSubscriptionHandlerStalled name pos eid elapsed groupContext | name == subName -> STM.atomically $ do - STM.modifyTVar' count (+ 1) - _ <- STM.tryPutTMVar warning (pos, eid, elapsed, groupContext) - pure () - _ -> pure () - tweak settings = settings & #eventHandler .~ Just observe - handler event = - if event ^. #globalPosition == GlobalPosition 1 - then takeMVar release >> pure Continue - else pure Stop - withTestStoreSettings tweak $ \store -> do - if live then pure () else appendEvents store >> waitForPublisher store (GlobalPosition 2) - handle <- - subscribe - store - ( (defaultSubscriptionConfig subName target' handler) - { consumerGroup = group - , handlerStallWarnAfter = Just 0.05 - } - ) - if live then waitForSubscriptionLive caughtUp >> appendEvents store else pure () - (pos, eid, elapsed, groupContext) <- within (STM.atomically (STM.readTMVar warning)) - pos `shouldBe` GlobalPosition 1 - Right events <- runStoreIO store (readAllForward (GlobalPosition 0) 1) - eid `shouldBe` (V.head events ^. #eventId) - elapsed `shouldSatisfy` (>= 0.05) - groupContext `shouldBe` maybe NonGroup (\_ -> GroupMember 0 1) group - checkpoint store `shouldReturn` GlobalPosition 0 - putMVar release () - within (wait handle) >>= (`shouldSatisfy` either (const False) (const True)) - checkpoint store `shouldReturn` GlobalPosition 2 - stoppedCount <- STM.readTVarIO count - threadDelay 120_000 - STM.readTVarIO count `shouldReturn` stoppedCount - currentState handle >>= (`shouldSatisfy` isNothing) - - it "warns periodically while pending and joins the watchdog on cancellation" $ do - blocked <- newEmptyMVar - warnings <- STM.newTQueueIO - let observe event = case event of - KirokuEventSubscriptionHandlerStalled _ pos _ elapsed _ -> do - now <- getMonotonicTimeNSec - STM.atomically (STM.writeTQueue warnings (pos, elapsed, now)) - _ -> pure () - withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do - appendEvents store - waitForPublisher store (GlobalPosition 2) - handle <- - subscribe - store - ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> takeMVar blocked >> pure Stop)) - { handlerStallWarnAfter = Just 0.05 - } - ) - (_, firstElapsed, firstAt) <- within (STM.atomically (STM.readTQueue warnings)) - (_, secondElapsed, secondAt) <- within (STM.atomically (STM.readTQueue warnings)) - secondElapsed `shouldSatisfy` (> firstElapsed) - secondAt - firstAt `shouldSatisfy` (>= 45_000_000) - checkpoint store `shouldReturn` GlobalPosition 0 - within (cancel handle) - _ <- STM.atomically (STM.flushTQueue warnings) - threadDelay 120_000 - STM.atomically (STM.isEmptyTQueue warnings) `shouldReturn` True - currentState handle >>= (`shouldSatisfy` isNothing) - - it "warns for the current invocation after replacing a quick handler" $ do + forM_ + [ (AllStreams, Nothing, False), + (AllStreams, Nothing, True), + (Category (CategoryName "stall"), Nothing, True), + (AllStreams, Just (validConsumerGroup 0 1), True), + (Category (CategoryName "stall"), Just (validConsumerGroup 0 1), False) + ] + $ \(target', group, live) -> + it ("warns without acknowledging or checkpointing a blocked handler for " <> show (target', group, live)) $ do release <- newEmptyMVar + caughtUp <- newEmptyMVar warning <- STM.newEmptyTMVarIO - let observe event = case event of - KirokuEventSubscriptionHandlerStalled _ pos _ elapsed _ -> STM.atomically $ do - _ <- STM.tryPutTMVar warning (pos, elapsed) - pure () + count <- STM.newTVarIO (0 :: Int) + let subName = SubscriptionName "stall-test" + observe event = do + caughtUpEventHandler subName caughtUp Nothing event + case event of + KirokuEventSubscriptionHandlerStalled name pos eid elapsed groupContext | name == subName -> STM.atomically $ do + STM.modifyTVar' count (+ 1) + _ <- STM.tryPutTMVar warning (pos, eid, elapsed, groupContext) + pure () _ -> pure () + tweak settings = settings & #eventHandler .~ Just observe handler event = - if event ^. #globalPosition == GlobalPosition 1 - then pure Continue - else takeMVar release >> pure Stop - withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do - appendEvents store - waitForPublisher store (GlobalPosition 2) - handle <- - subscribe - store - ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams handler) - { handlerStallWarnAfter = Just 0.05 - } - ) - (pos, elapsed) <- within (STM.atomically (STM.readTMVar warning)) - pos `shouldBe` GlobalPosition 2 - elapsed `shouldSatisfy` (>= 0.05) - -- Normal progress is persisted at the batch boundary. - checkpoint store `shouldReturn` GlobalPosition 0 - putMVar release () - _ <- within (wait handle) + if event ^. #globalPosition == GlobalPosition 1 + then takeMVar release >> pure Continue + else pure Stop + withTestStoreSettings tweak $ \store -> do + if live then pure () else appendEvents store >> waitForPublisher store (GlobalPosition 2) + handle <- + subscribe + store + ( (defaultSubscriptionConfig subName target' handler) + { consumerGroup = group, + handlerStallWarnAfter = Just 0.05 + } + ) + if live then waitForSubscriptionLive caughtUp >> appendEvents store else pure () + (pos, eid, elapsed, groupContext) <- within (STM.atomically (STM.readTMVar warning)) + pos `shouldBe` GlobalPosition 1 + Right events <- runStoreIO store (readAllForward (GlobalPosition 0) 1) + eid `shouldBe` (V.head events ^. #eventId) + elapsed `shouldSatisfy` (>= 0.05) + groupContext `shouldBe` maybe NonGroup (\_ -> GroupMember 0 1) group + checkpoint store `shouldReturn` GlobalPosition 0 + putMVar release () + within (wait handle) >>= (`shouldSatisfy` either (const False) (const True)) + checkpoint store `shouldReturn` GlobalPosition 2 + stoppedCount <- STM.readTVarIO count + threadDelay 120_000 + STM.readTVarIO count `shouldReturn` stoppedCount + currentState handle >>= (`shouldSatisfy` isNothing) + + it "warns periodically while pending and joins the watchdog on cancellation" $ do + blocked <- newEmptyMVar + warnings <- STM.newTQueueIO + let observe event = case event of + KirokuEventSubscriptionHandlerStalled _ pos _ elapsed _ -> do + now <- getMonotonicTimeNSec + STM.atomically (STM.writeTQueue warnings (pos, elapsed, now)) + _ -> pure () + withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do + appendEvents store + waitForPublisher store (GlobalPosition 2) + handle <- + subscribe + store + ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> takeMVar blocked >> pure Stop)) + { handlerStallWarnAfter = Just 0.05 + } + ) + (_, firstElapsed, firstAt) <- within (STM.atomically (STM.readTQueue warnings)) + (_, secondElapsed, secondAt) <- within (STM.atomically (STM.readTQueue warnings)) + secondElapsed `shouldSatisfy` (> firstElapsed) + secondAt - firstAt `shouldSatisfy` (>= 45_000_000) + checkpoint store `shouldReturn` GlobalPosition 0 + within (cancel handle) + _ <- STM.atomically (STM.flushTQueue warnings) + threadDelay 120_000 + STM.atomically (STM.isEmptyTQueue warnings) `shouldReturn` True + currentState handle >>= (`shouldSatisfy` isNothing) + + it "warns for the current invocation after replacing a quick handler" $ do + release <- newEmptyMVar + warning <- STM.newEmptyTMVarIO + let observe event = case event of + KirokuEventSubscriptionHandlerStalled _ pos _ elapsed _ -> STM.atomically $ do + _ <- STM.tryPutTMVar warning (pos, elapsed) pure () + _ -> pure () + handler event = + if event ^. #globalPosition == GlobalPosition 1 + then pure Continue + else takeMVar release >> pure Stop + withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do + appendEvents store + waitForPublisher store (GlobalPosition 2) + handle <- + subscribe + store + ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams handler) + { handlerStallWarnAfter = Just 0.05 + } + ) + (pos, elapsed) <- within (STM.atomically (STM.readTMVar warning)) + pos `shouldBe` GlobalPosition 2 + elapsed `shouldSatisfy` (>= 0.05) + -- Normal progress is persisted at the batch boundary. + checkpoint store `shouldReturn` GlobalPosition 0 + putMVar release () + _ <- within (wait handle) + pure () - it "contains a throwing diagnostic callback and still completes the handler" $ do - release <- newEmptyMVar - observed <- STM.newEmptyTMVarIO - let observe KirokuEventSubscriptionHandlerStalled{} = do - STM.atomically $ do - _ <- STM.tryPutTMVar observed () - pure () - ioError (userError "diagnostic callback failed") - observe _ = pure () - withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do - appendEvents store - waitForPublisher store (GlobalPosition 2) - handle <- - subscribe - store - ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> takeMVar release >> pure Stop)) - { handlerStallWarnAfter = Just 0.05 - } - ) - within (STM.atomically (STM.readTMVar observed)) - putMVar release () - within (wait handle) >>= (`shouldSatisfy` either (const False) (const True)) - checkpoint store `shouldReturn` GlobalPosition 1 + it "contains a throwing diagnostic callback and still completes the handler" $ do + release <- newEmptyMVar + observed <- STM.newEmptyTMVarIO + let observe KirokuEventSubscriptionHandlerStalled {} = do + STM.atomically $ do + _ <- STM.tryPutTMVar observed () + pure () + ioError (userError "diagnostic callback failed") + observe _ = pure () + withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do + appendEvents store + waitForPublisher store (GlobalPosition 2) + handle <- + subscribe + store + ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> takeMVar release >> pure Stop)) + { handlerStallWarnAfter = Just 0.05 + } + ) + within (STM.atomically (STM.readTMVar observed)) + putMVar release () + within (wait handle) >>= (`shouldSatisfy` either (const False) (const True)) + checkpoint store `shouldReturn` GlobalPosition 1 - it "clears tracking and joins the watchdog when a handler throws" $ do - release <- newEmptyMVar - count <- STM.newTVarIO (0 :: Int) - let observe KirokuEventSubscriptionHandlerStalled{} = STM.atomically (STM.modifyTVar' count (+ 1)) - observe _ = pure () - withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do - appendEvents store - waitForPublisher store (GlobalPosition 2) - handle <- - subscribe - store - ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> takeMVar release >> ioError (userError "handler failed"))) - { handlerStallWarnAfter = Just 0.05 - } - ) - within (STM.atomically (STM.readTVar count >>= STM.check . (> 0))) - putMVar release () - within (wait handle) >>= (`shouldSatisfy` either (const True) (const False)) - stoppedCount <- STM.readTVarIO count - threadDelay 120_000 - STM.readTVarIO count `shouldReturn` stoppedCount - checkpoint store `shouldReturn` GlobalPosition 0 + it "clears tracking and joins the watchdog when a handler throws" $ do + release <- newEmptyMVar + count <- STM.newTVarIO (0 :: Int) + let observe KirokuEventSubscriptionHandlerStalled {} = STM.atomically (STM.modifyTVar' count (+ 1)) + observe _ = pure () + withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do + appendEvents store + waitForPublisher store (GlobalPosition 2) + handle <- + subscribe + store + ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> takeMVar release >> ioError (userError "handler failed"))) + { handlerStallWarnAfter = Just 0.05 + } + ) + within (STM.atomically (STM.readTVar count >>= STM.check . (> 0))) + putMVar release () + within (wait handle) >>= (`shouldSatisfy` either (const True) (const False)) + stoppedCount <- STM.readTVarIO count + threadDelay 120_000 + STM.readTVarIO count `shouldReturn` stoppedCount + checkpoint store `shouldReturn` GlobalPosition 0 - it "emits nothing when the handler completes before the threshold" $ do - count <- STM.newTVarIO (0 :: Int) - let observe KirokuEventSubscriptionHandlerStalled{} = STM.atomically (STM.modifyTVar' count (+ 1)) - observe _ = pure () - withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do - appendEvents store - waitForPublisher store (GlobalPosition 2) - handle <- - subscribe - store - ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> pure Stop)) - { handlerStallWarnAfter = Just 0.1 - } - ) - within (wait handle) >>= (`shouldSatisfy` either (const False) (const True)) - threadDelay 150_000 - STM.readTVarIO count `shouldReturn` 0 + it "emits nothing when the handler completes before the threshold" $ do + count <- STM.newTVarIO (0 :: Int) + let observe KirokuEventSubscriptionHandlerStalled {} = STM.atomically (STM.modifyTVar' count (+ 1)) + observe _ = pure () + withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do + appendEvents store + waitForPublisher store (GlobalPosition 2) + handle <- + subscribe + store + ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> pure Stop)) + { handlerStallWarnAfter = Just 0.1 + } + ) + within (wait handle) >>= (`shouldSatisfy` either (const False) (const True)) + threadDelay 150_000 + STM.readTVarIO count `shouldReturn` 0 - it "keeps warnings disabled by default even when a handler is blocked" $ do - entered <- newEmptyMVar - release <- newEmptyMVar - count <- STM.newTVarIO (0 :: Int) - let observe KirokuEventSubscriptionHandlerStalled{} = STM.atomically (STM.modifyTVar' count (+ 1)) - observe _ = pure () - withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do - appendEvents store - waitForPublisher store (GlobalPosition 2) - let config = defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> putMVar entered () >> takeMVar release >> pure Stop) - handlerStallWarnAfter config `shouldBe` Nothing - handle <- subscribe store config - within (takeMVar entered) - threadDelay 150_000 - STM.readTVarIO count `shouldReturn` 0 - putMVar release () - _ <- within (wait handle) - pure () + it "keeps warnings disabled by default even when a handler is blocked" $ do + entered <- newEmptyMVar + release <- newEmptyMVar + count <- STM.newTVarIO (0 :: Int) + let observe KirokuEventSubscriptionHandlerStalled {} = STM.atomically (STM.modifyTVar' count (+ 1)) + observe _ = pure () + withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do + appendEvents store + waitForPublisher store (GlobalPosition 2) + let config = defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> putMVar entered () >> takeMVar release >> pure Stop) + handlerStallWarnAfter config `shouldBe` Nothing + handle <- subscribe store config + within (takeMVar entered) + threadDelay 150_000 + STM.readTVarIO count `shouldReturn` 0 + putMVar release () + _ <- within (wait handle) + pure () - forM_ [0, -1 :: NominalDiffTime] $ \threshold -> - it ("refuses a nonpositive warning interval before checkpoint initialization: " <> show threshold) $ - withTestStoreSettings Prelude.id $ \store -> do - handle <- - subscribe - store - ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> pure Stop)) - { handlerStallWarnAfter = Just threshold - } - ) - within (wait handle) >>= \case - Left err -> do - (fromException err :: Maybe InvalidHandlerStallWarnAfter) `shouldBe` Just (InvalidHandlerStallWarnAfter threshold) - (fromException err :: Maybe SomeSubscriptionStartupFailure) `shouldSatisfy` (not . isNothing) - Right () -> expectationFailure "invalid interval was accepted" - Right (SubscriptionCheckpointInventory _ rows) <- runStoreIO store subscriptionCheckpointInventory - V.null rows `shouldBe` True + forM_ [0, -1 :: NominalDiffTime] $ \threshold -> + it ("refuses a nonpositive warning interval with exactly one crashed stop before checkpoint initialization: " <> show threshold) $ do + events <- newIORef [] + let observe event = atomicModifyIORef' events (\seen -> (event : seen, ())) + withTestStoreSettings (\s -> s & #eventHandler .~ Just observe) $ \store -> do + handle <- + subscribe + store + ( (defaultSubscriptionConfig (SubscriptionName "stall-test") AllStreams (\_ -> pure Stop)) + { handlerStallWarnAfter = Just threshold + } + ) + within (wait handle) >>= \case + Left err -> do + (fromException err :: Maybe InvalidHandlerStallWarnAfter) `shouldBe` Just (InvalidHandlerStallWarnAfter threshold) + (fromException err :: Maybe SomeSubscriptionStartupFailure) `shouldSatisfy` (not . isNothing) + Right () -> expectationFailure "invalid interval was accepted" + Right (SubscriptionCheckpointInventory _ rows) <- runStoreIO store subscriptionCheckpointInventory + V.null rows `shouldBe` True + seen <- readIORef events + case [(n, p, e, g) | KirokuEventSubscriptionStopped n p (StopWorkerCrashed e) g <- seen] of + [(n, p, e, g)] -> do + n `shouldBe` SubscriptionName "stall-test" + p `shouldBe` GlobalPosition 0 + g `shouldBe` NonGroup + fromException e `shouldBe` Just (InvalidHandlerStallWarnAfter threshold) + other -> expectationFailure ("expected exactly one crashed stop, got " <> show other) + length [() | KirokuEventSubscriptionStopped {} <- seen] `shouldBe` 1 diff --git a/test/Test/Helpers.hs b/test/Test/Helpers.hs --- a/test/Test/Helpers.hs +++ b/test/Test/Helpers.hs @@ -1,21 +1,20 @@ -{- | 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 +-- | 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, @@ -48,7 +47,8 @@ waitForPublisher, waitForSubscriptionLive, caughtUpEventHandler, -) where + ) +where import Control.Concurrent (threadDelay) import Control.Concurrent.Async qualified as Async @@ -74,61 +74,57 @@ 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. --} +-- | 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. --} +-- | 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 + 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 - } + 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. --} +-- | 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) + 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). --} +-- | 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 + 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 a dead-letter row for a recorded event without running a subscription. insertDeadLetterForEvent :: KirokuStore -> Text -> RecordedEvent -> IO () @@ -136,220 +132,212 @@ insertDeadLetterWith :: KirokuStore -> Text -> Int32 -> Aeson.Value -> Text -> Int32 -> RecordedEvent -> IO () insertDeadLetterWith store subscriptionName selectedMember reason summary attempts event = do - let EventId eid = event ^. #eventId - GlobalPosition globalPosition = event ^. #globalPosition - params = - SQL.DeadLetterParams - { SQL.dlSubscriptionName = subscriptionName - , SQL.dlMember = selectedMember - , SQL.dlTargetKind = "unbound" - , SQL.dlTargetCategory = Nothing - , SQL.dlGroupSize = max 1 (selectedMember + 1) - , SQL.dlGlobalPosition = globalPosition - , SQL.dlEventId = eid - , SQL.dlReason = reason - , SQL.dlReasonSummary = summary - , SQL.dlAttemptCount = attempts - } - result <- Pool.use (store ^. #pool) (Session.statement params SQL.insertDeadLetterAndCheckpointStmt) - case result of - Left err -> error ("insertDeadLetterForEvent failed: " <> show err) - Right () -> pure () + let EventId eid = event ^. #eventId + GlobalPosition globalPosition = event ^. #globalPosition + params = + SQL.DeadLetterParams + { SQL.dlSubscriptionName = subscriptionName, + SQL.dlMember = selectedMember, + SQL.dlTargetKind = "unbound", + SQL.dlTargetCategory = Nothing, + SQL.dlGroupSize = max 1 (selectedMember + 1), + SQL.dlGlobalPosition = globalPosition, + SQL.dlEventId = eid, + SQL.dlReason = reason, + SQL.dlReasonSummary = summary, + SQL.dlAttemptCount = attempts + } + result <- Pool.use (store ^. #pool) (Session.statement params SQL.insertDeadLetterAndCheckpointStmt) + case result of + Left err -> error ("insertDeadLetterForEvent failed: " <> show err) + Right () -> pure () -- | Count dead-letter rows referencing any of the supplied events. countDeadLettersForEvents :: KirokuStore -> [EventId] -> IO Int64 countDeadLettersForEvents store eventIds = do - let uuids = fmap (\(EventId eid) -> eid) eventIds - stmt :: Statement [UUID] Int64 - stmt = - preparable - "SELECT COUNT(*) FROM dead_letters WHERE event_id = ANY($1::uuid[])" - (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid)))) - (D.singleRow (D.column (D.nonNullable D.int8))) - result <- Pool.use (store ^. #pool) (Session.statement uuids stmt) - case result of - Left err -> error ("countDeadLettersForEvents failed: " <> show err) - Right n -> pure n + let uuids = fmap (\(EventId eid) -> eid) eventIds + stmt :: Statement [UUID] Int64 + stmt = + preparable + "SELECT COUNT(*) FROM dead_letters WHERE event_id = ANY($1::uuid[])" + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid)))) + (D.singleRow (D.column (D.nonNullable D.int8))) + result <- Pool.use (store ^. #pool) (Session.statement uuids stmt) + case result of + Left err -> error ("countDeadLettersForEvents 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. --} +-- | 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 + 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@. --} +-- | 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 + 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 + 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. --} +-- | 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 + 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 + 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) + | 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) + | 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 () + 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). --} +-- | 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 + 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. --} +-- | 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) + 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. --} +-- | 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. --} +-- | 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 () + 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 + case evt of + KirokuEventSubscriptionCaughtUp n _ _ + | n == name -> () <$ tryPutMVar barrier () + _ -> pure () + case passthrough of + Nothing -> pure () + Just f -> f evt -{- | Build known-valid membership for test fixtures; invalid cases test the -smart constructors directly rather than passing a malformed worker config. --} +-- | Build known-valid membership for test fixtures; invalid cases test the +-- smart constructors directly rather than passing a malformed worker config. validConsumerGroup :: Int32 -> Int32 -> ConsumerGroup validConsumerGroup m n = either (error . show) Prelude.id (mkConsumerGroupSize n >>= mkConsumerGroup m) diff --git a/test/Test/HistoryRetention.hs b/test/Test/HistoryRetention.hs --- a/test/Test/HistoryRetention.hs +++ b/test/Test/HistoryRetention.hs @@ -27,242 +27,242 @@ spec :: Spec spec = describe "history retention" $ do - it "validates UTF-8 byte lengths, duration bounds, and inventory bounds" $ do - mkHistoryRetentionLeaseOwner "" `shouldBe` Left HistoryRetentionLeaseOwnerEmpty - mkHistoryRetentionLeaseOwner (Text.replicate 256 "é") `shouldSatisfy` either (const False) (const True) - mkHistoryRetentionLeaseOwner (Text.replicate 257 "é") - `shouldBe` Left (HistoryRetentionLeaseOwnerTooLong 514) - mkHistoryRetentionLeaseReason "" `shouldBe` Left HistoryRetentionLeaseReasonEmpty - mkHistoryRetentionLeaseReason (Text.replicate 2049 "x") - `shouldBe` Left (HistoryRetentionLeaseReasonTooLong 2049) - mkHistoryRetentionLeaseDuration (secondsToDiffTime 0) `shouldSatisfy` isLeft - mkHistoryRetentionLeaseDuration (secondsToDiffTime 1) `shouldSatisfy` either (const False) (const True) - mkHistoryRetentionLeaseDuration (secondsToDiffTime 3600) `shouldSatisfy` either (const False) (const True) - mkHistoryRetentionLeaseDuration (secondsToDiffTime 3601) `shouldSatisfy` isLeft - mkHistoryRetentionInventoryLimit 0 `shouldBe` Left (HistoryRetentionInventoryLimitOutOfRange 0) - mkHistoryRetentionInventoryLimit 1000 `shouldSatisfy` either (const False) (const True) - mkHistoryRetentionInventoryLimit 1001 `shouldBe` Left (HistoryRetentionInventoryLimitOutOfRange 1001) + it "validates UTF-8 byte lengths, duration bounds, and inventory bounds" $ do + mkHistoryRetentionLeaseOwner "" `shouldBe` Left HistoryRetentionLeaseOwnerEmpty + mkHistoryRetentionLeaseOwner (Text.replicate 256 "é") `shouldSatisfy` either (const False) (const True) + mkHistoryRetentionLeaseOwner (Text.replicate 257 "é") + `shouldBe` Left (HistoryRetentionLeaseOwnerTooLong 514) + mkHistoryRetentionLeaseReason "" `shouldBe` Left HistoryRetentionLeaseReasonEmpty + mkHistoryRetentionLeaseReason (Text.replicate 2049 "x") + `shouldBe` Left (HistoryRetentionLeaseReasonTooLong 2049) + mkHistoryRetentionLeaseDuration (secondsToDiffTime 0) `shouldSatisfy` isLeft + mkHistoryRetentionLeaseDuration (secondsToDiffTime 1) `shouldSatisfy` either (const False) (const True) + mkHistoryRetentionLeaseDuration (secondsToDiffTime 3600) `shouldSatisfy` either (const False) (const True) + mkHistoryRetentionLeaseDuration (secondsToDiffTime 3601) `shouldSatisfy` isLeft + mkHistoryRetentionInventoryLimit 0 `shouldBe` Left (HistoryRetentionInventoryLimitOutOfRange 0) + mkHistoryRetentionInventoryLimit 1000 `shouldSatisfy` either (const False) (const True) + mkHistoryRetentionInventoryLimit 1001 `shouldBe` Left (HistoryRetentionInventoryLimitOutOfRange 1001) - it "captures the authoritative frontier and database-derived expiry" $ - withTestStore $ \store -> do - Right appended <- - runStoreIO store $ - appendToStream - (StreamName "history-retention-frontier") - NoStream - [ makeEvent "One" (Aeson.object []) - , makeEvent "Two" (Aeson.object []) - , makeEvent "Three" (Aeson.object []) - ] - lease <- runTx store (acquireHistoryRetentionLeaseTx (request "rebuild" "frontier" 60)) - lease ^. #protectedThrough `shouldBe` appended ^. #globalPosition - realToFrac (diffUTCTime (lease ^. #expiresAt) (lease ^. #createdAt)) - `shouldBe` secondsToDiffTime 60 - lease ^. #state `shouldBe` HistoryRetentionLeaseActive - rows <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 10)) - rows `shouldBe` Vector.singleton lease + it "captures the authoritative frontier and database-derived expiry" $ + withTestStore $ \store -> do + Right appended <- + runStoreIO store $ + appendToStream + (StreamName "history-retention-frontier") + NoStream + [ makeEvent "One" (Aeson.object []), + makeEvent "Two" (Aeson.object []), + makeEvent "Three" (Aeson.object []) + ] + lease <- runTx store (acquireHistoryRetentionLeaseTx (request "rebuild" "frontier" 60)) + lease ^. #protectedThrough `shouldBe` appended ^. #globalPosition + realToFrac (diffUTCTime (lease ^. #expiresAt) (lease ^. #createdAt)) + `shouldBe` secondsToDiffTime 60 + lease ^. #state `shouldBe` HistoryRetentionLeaseActive + rows <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 10)) + rows `shouldBe` Vector.singleton lease - it "rolls back acquisition when the surrounding transaction is condemned" $ - withTestStore $ \store -> do - _ <- runTx store $ do - lease <- acquireHistoryRetentionLeaseTx (request "rollback" "condemned" 60) - Tx.condemn - pure lease - rows <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 10)) - rows `shouldBe` Vector.empty + it "rolls back acquisition when the surrounding transaction is condemned" $ + withTestStore $ \store -> do + _ <- runTx store $ do + lease <- acquireHistoryRetentionLeaseTx (request "rollback" "condemned" 60) + Tx.condemn + pure lease + rows <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 10)) + rows `shouldBe` Vector.empty - it "renews only the matching active owner and never shortens expiry" $ - withTestStore $ \store -> do - lease <- runTx store (acquireHistoryRetentionLeaseTx (request "owner-a" "renew" 30)) - let handle = leaseHandle lease - wrongHandle = HistoryRetentionLeaseHandle (lease ^. #leaseId) (validatedOwner "owner-b") - mismatch <- runTx store (renewHistoryRetentionLeaseTx wrongHandle (validatedDuration 60)) - mismatch `shouldBe` Left HistoryRetentionRenewalOwnerMismatch - renewed <- runTx store (renewHistoryRetentionLeaseTx handle (validatedDuration 60)) - case renewed of - Left err -> expectationFailure ("renewal failed: " <> show err) - Right value -> do - value ^. #expiresAt `shouldSatisfy` (> lease ^. #expiresAt) - value ^. #renewedAt `shouldSatisfy` (>= lease ^. #renewedAt) + it "renews only the matching active owner and never shortens expiry" $ + withTestStore $ \store -> do + lease <- runTx store (acquireHistoryRetentionLeaseTx (request "owner-a" "renew" 30)) + let handle = leaseHandle lease + wrongHandle = HistoryRetentionLeaseHandle (lease ^. #leaseId) (validatedOwner "owner-b") + mismatch <- runTx store (renewHistoryRetentionLeaseTx wrongHandle (validatedDuration 60)) + mismatch `shouldBe` Left HistoryRetentionRenewalOwnerMismatch + renewed <- runTx store (renewHistoryRetentionLeaseTx handle (validatedDuration 60)) + case renewed of + Left err -> expectationFailure ("renewal failed: " <> show err) + Right value -> do + value ^. #expiresAt `shouldSatisfy` (> lease ^. #expiresAt) + value ^. #renewedAt `shouldSatisfy` (>= lease ^. #renewedAt) - it "derives expiry without a worker and refuses resurrection" $ - withTestStore $ \store -> do - lease <- runTx store (acquireHistoryRetentionLeaseTx (request "crashed" "expiry" 1)) - threadDelay 1_100_000 - rows <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 10)) - fmap (^. #state) (Vector.toList rows) `shouldBe` [HistoryRetentionLeaseExpired] - renewed <- runTx store (renewHistoryRetentionLeaseTx (leaseHandle lease) (validatedDuration 60)) - renewed `shouldBe` Left HistoryRetentionRenewalExpired - released <- runTx store (releaseHistoryRetentionLeaseTx (leaseHandle lease)) - case released of - HistoryRetentionReleaseExpired expiredLease -> - expiredLease ^. #state `shouldBe` HistoryRetentionLeaseExpired - other -> expectationFailure ("expected expired release result, got " <> show other) + it "derives expiry without a worker and refuses resurrection" $ + withTestStore $ \store -> do + lease <- runTx store (acquireHistoryRetentionLeaseTx (request "crashed" "expiry" 1)) + threadDelay 1_100_000 + rows <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 10)) + fmap (^. #state) (Vector.toList rows) `shouldBe` [HistoryRetentionLeaseExpired] + renewed <- runTx store (renewHistoryRetentionLeaseTx (leaseHandle lease) (validatedDuration 60)) + renewed `shouldBe` Left HistoryRetentionRenewalExpired + released <- runTx store (releaseHistoryRetentionLeaseTx (leaseHandle lease)) + case released of + HistoryRetentionReleaseExpired expiredLease -> + expiredLease ^. #state `shouldBe` HistoryRetentionLeaseExpired + other -> expectationFailure ("expected expired release result, got " <> show other) - it "releases idempotently and leaves another simultaneous lease active" $ - withTestStore $ \store -> do - first <- runTx store (acquireHistoryRetentionLeaseTx (request "first" "release" 60)) - second <- runTx store (acquireHistoryRetentionLeaseTx (request "second" "release" 60)) - released <- runTx store (releaseHistoryRetentionLeaseTx (leaseHandle first)) - released `shouldSatisfy` \case HistoryRetentionReleased{} -> True; _ -> False - repeated <- runTx store (releaseHistoryRetentionLeaseTx (leaseHandle first)) - repeated `shouldSatisfy` \case HistoryRetentionAlreadyReleased{} -> True; _ -> False - rows <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 10)) - fmap (^. #state) (Vector.toList rows) - `shouldBe` [HistoryRetentionLeaseReleased, HistoryRetentionLeaseActive] - Vector.last rows ^. #leaseId `shouldBe` second ^. #leaseId + it "releases idempotently and leaves another simultaneous lease active" $ + withTestStore $ \store -> do + first <- runTx store (acquireHistoryRetentionLeaseTx (request "first" "release" 60)) + second <- runTx store (acquireHistoryRetentionLeaseTx (request "second" "release" 60)) + released <- runTx store (releaseHistoryRetentionLeaseTx (leaseHandle first)) + released `shouldSatisfy` \case HistoryRetentionReleased {} -> True; _ -> False + repeated <- runTx store (releaseHistoryRetentionLeaseTx (leaseHandle first)) + repeated `shouldSatisfy` \case HistoryRetentionAlreadyReleased {} -> True; _ -> False + rows <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 10)) + fmap (^. #state) (Vector.toList rows) + `shouldBe` [HistoryRetentionLeaseReleased, HistoryRetentionLeaseActive] + Vector.last rows ^. #leaseId `shouldBe` second ^. #leaseId - it "bounds inventory and prunes only terminal rows older than the cutoff" $ - withTestStore $ \store -> do - first <- runTx store (acquireHistoryRetentionLeaseTx (request "first" "prune" 60)) - _ <- runTx store (acquireHistoryRetentionLeaseTx (request "second" "keep" 60)) - _ <- runTx store (releaseHistoryRetentionLeaseTx (leaseHandle first)) - bounded <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 1)) - Vector.length bounded `shouldBe` 1 - cutoff <- addUTCTime 1 <$> getCurrentTime - pruned <- runTx store (pruneHistoryRetentionLeasesTx cutoff) - pruned `shouldBe` HistoryRetentionPruneResult 0 1 - remaining <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 10)) - fmap (^. #state) (Vector.toList remaining) `shouldBe` [HistoryRetentionLeaseActive] + it "bounds inventory and prunes only terminal rows older than the cutoff" $ + withTestStore $ \store -> do + first <- runTx store (acquireHistoryRetentionLeaseTx (request "first" "prune" 60)) + _ <- runTx store (acquireHistoryRetentionLeaseTx (request "second" "keep" 60)) + _ <- runTx store (releaseHistoryRetentionLeaseTx (leaseHandle first)) + bounded <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 1)) + Vector.length bounded `shouldBe` 1 + cutoff <- addUTCTime 1 <$> getCurrentTime + pruned <- runTx store (pruneHistoryRetentionLeasesTx cutoff) + pruned `shouldBe` HistoryRetentionPruneResult 0 1 + remaining <- runTx store (historyRetentionLeaseInventoryTx (inventoryQuery 10)) + fmap (^. #state) (Vector.toList remaining) `shouldBe` [HistoryRetentionLeaseActive] - it "emits committed effect transitions once and no false repeated-release event" $ do - observed <- newIORef ([] :: [KirokuEvent]) - withTestStoreSettings - (& #eventHandler .~ Just (\event -> modifyIORef' observed (event :))) - $ \store -> do - Right lease <- runStoreIO store $ acquireHistoryRetentionLease (request "events" "not-a-label" 60) - Right (Right _) <- - runStoreIO store $ - renewHistoryRetentionLease (leaseHandle lease) (validatedDuration 120) - Right HistoryRetentionReleased{} <- - runStoreIO store $ - releaseHistoryRetentionLease (leaseHandle lease) - Right HistoryRetentionAlreadyReleased{} <- - runStoreIO store $ - releaseHistoryRetentionLease (leaseHandle lease) - cutoff <- addUTCTime 1 <$> getCurrentTime - Right (HistoryRetentionPruneResult 0 1) <- - runStoreIO store $ - pruneHistoryRetentionLeases cutoff - pure () - events <- readIORef observed - length [() | KirokuEventHistoryRetentionLeaseAcquired{} <- events] `shouldBe` 1 - length [() | KirokuEventHistoryRetentionLeaseRenewed{} <- events] `shouldBe` 1 - length [() | KirokuEventHistoryRetentionLeaseReleased{} <- events] `shouldBe` 1 - length [() | KirokuEventHistoryRetentionLeasesPruned{} <- events] `shouldBe` 1 + it "emits committed effect transitions once and no false repeated-release event" $ do + observed <- newIORef ([] :: [KirokuEvent]) + withTestStoreSettings + (& #eventHandler .~ Just (\event -> modifyIORef' observed (event :))) + $ \store -> do + Right lease <- runStoreIO store $ acquireHistoryRetentionLease (request "events" "not-a-label" 60) + Right (Right _) <- + runStoreIO store $ + renewHistoryRetentionLease (leaseHandle lease) (validatedDuration 120) + Right HistoryRetentionReleased {} <- + runStoreIO store $ + releaseHistoryRetentionLease (leaseHandle lease) + Right HistoryRetentionAlreadyReleased {} <- + runStoreIO store $ + releaseHistoryRetentionLease (leaseHandle lease) + cutoff <- addUTCTime 1 <$> getCurrentTime + Right (HistoryRetentionPruneResult 0 1) <- + runStoreIO store $ + pruneHistoryRetentionLeases cutoff + pure () + events <- readIORef observed + length [() | KirokuEventHistoryRetentionLeaseAcquired {} <- events] `shouldBe` 1 + length [() | KirokuEventHistoryRetentionLeaseRenewed {} <- events] `shouldBe` 1 + length [() | KirokuEventHistoryRetentionLeaseReleased {} <- events] `shouldBe` 1 + length [() | KirokuEventHistoryRetentionLeasesPruned {} <- events] `shouldBe` 1 - it "returns and emits a typed hard-delete conflict without changing history while any lease is active" $ do - observed <- newIORef ([] :: [KirokuEvent]) - withTestStoreSettings - (& #eventHandler .~ Just (\event -> modifyIORef' observed (event :))) - $ \store -> do - let stream = StreamName "history-retention-hard-delete" - Right _ <- runStoreIO store $ appendToStream stream NoStream [makeEvent "Protected" (Aeson.object [])] - countBefore <- countEvents store - Right first <- runStoreIO store $ acquireHistoryRetentionLease (request "first" "protect" 60) - Right second <- runStoreIO store $ acquireHistoryRetentionLease (request "second" "protect" 60) - blocked <- runStoreIO store $ hardDeleteStream stream - case blocked of - Left (HistoryRetentionActive actual HistoryRetentionConflict{activeLeaseCount}) -> do - actual `shouldBe` stream - activeLeaseCount `shouldBe` 2 - other -> expectationFailure ("expected typed retention conflict, got " <> show other) - countEvents store `shouldReturn` countBefore - Right (Just _) <- runStoreIO store $ getStream stream - Right HistoryRetentionReleased{} <- runStoreIO store $ releaseHistoryRetentionLease (leaseHandle first) - stillBlocked <- runStoreIO store $ hardDeleteStream stream - stillBlocked `shouldSatisfy` \case Left HistoryRetentionActive{} -> True; _ -> False - Right HistoryRetentionReleased{} <- runStoreIO store $ releaseHistoryRetentionLease (leaseHandle second) - deleted <- runStoreIO store (hardDeleteStream stream) - deleted `shouldSatisfy` \case Right (Just _) -> True; _ -> False - events <- readIORef observed - let conflictCounts = - [ activeLeaseCount - | KirokuEventHardDeleteHistoryRetentionConflict _ HistoryRetentionConflict{activeLeaseCount} <- reverse events - ] - conflictCounts `shouldBe` [2, 1] + it "returns and emits a typed hard-delete conflict without changing history while any lease is active" $ do + observed <- newIORef ([] :: [KirokuEvent]) + withTestStoreSettings + (& #eventHandler .~ Just (\event -> modifyIORef' observed (event :))) + $ \store -> do + let stream = StreamName "history-retention-hard-delete" + Right _ <- runStoreIO store $ appendToStream stream NoStream [makeEvent "Protected" (Aeson.object [])] + countBefore <- countEvents store + Right first <- runStoreIO store $ acquireHistoryRetentionLease (request "first" "protect" 60) + Right second <- runStoreIO store $ acquireHistoryRetentionLease (request "second" "protect" 60) + blocked <- runStoreIO store $ hardDeleteStream stream + case blocked of + Left (HistoryRetentionActive actual HistoryRetentionConflict {activeLeaseCount}) -> do + actual `shouldBe` stream + activeLeaseCount `shouldBe` 2 + other -> expectationFailure ("expected typed retention conflict, got " <> show other) + countEvents store `shouldReturn` countBefore + Right (Just _) <- runStoreIO store $ getStream stream + Right HistoryRetentionReleased {} <- runStoreIO store $ releaseHistoryRetentionLease (leaseHandle first) + stillBlocked <- runStoreIO store $ hardDeleteStream stream + stillBlocked `shouldSatisfy` \case Left HistoryRetentionActive {} -> True; _ -> False + Right HistoryRetentionReleased {} <- runStoreIO store $ releaseHistoryRetentionLease (leaseHandle second) + deleted <- runStoreIO store (hardDeleteStream stream) + deleted `shouldSatisfy` \case Right (Just _) -> True; _ -> False + events <- readIORef observed + let conflictCounts = + [ activeLeaseCount + | KirokuEventHardDeleteHistoryRetentionConflict _ HistoryRetentionConflict {activeLeaseCount} <- reverse events + ] + conflictCounts `shouldBe` [2, 1] - describe "history retention raw SQL" $ do - it "serializes lease-first acquisition ahead of raw deletion" $ - withTestStore $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "raw-race-lease-first") NoStream [makeEvent "Raw" (Aeson.object [])] - countBefore <- countStreamEvents store - acquisition <- Async.async $ runStoreIO store $ runTransaction $ do - lease <- acquireHistoryRetentionLeaseTx (request "raw-race" "lease-first" 60) - _ <- Tx.statement () holdCoordinatorStmt - pure lease - waitForCoordinatorPhase store 100 - deletion <- Async.async (runRawDestruction store rawDeleteStreamEventsStmt) - threadDelay 50_000 - Async.poll deletion >>= \case - Nothing -> pure () - Just _ -> expectationFailure "raw deletion completed while lease acquisition held the coordinator" - acquired <- waitWithin "lease-first acquisition" acquisition - acquired `shouldSatisfy` \case Right HistoryRetentionLease{} -> True; _ -> False - rejected <- waitWithin "lease-first raw deletion" deletion - rejected `shouldSatisfy` hasSqlState "KR001" - countStreamEvents store `shouldReturn` countBefore + describe "history retention raw SQL" $ do + it "serializes lease-first acquisition ahead of raw deletion" $ + withTestStore $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "raw-race-lease-first") NoStream [makeEvent "Raw" (Aeson.object [])] + countBefore <- countStreamEvents store + acquisition <- Async.async $ runStoreIO store $ runTransaction $ do + lease <- acquireHistoryRetentionLeaseTx (request "raw-race" "lease-first" 60) + _ <- Tx.statement () holdCoordinatorStmt + pure lease + waitForCoordinatorPhase store 100 + deletion <- Async.async (runRawDestruction store rawDeleteStreamEventsStmt) + threadDelay 50_000 + Async.poll deletion >>= \case + Nothing -> pure () + Just _ -> expectationFailure "raw deletion completed while lease acquisition held the coordinator" + acquired <- waitWithin "lease-first acquisition" acquisition + acquired `shouldSatisfy` \case Right HistoryRetentionLease {} -> True; _ -> False + rejected <- waitWithin "lease-first raw deletion" deletion + rejected `shouldSatisfy` hasSqlState "KR001" + countStreamEvents store `shouldReturn` countBefore - it "serializes delete-first maintenance ahead of post-delete acquisition" $ - withTestStore $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "raw-race-delete-first") NoStream [makeEvent "Raw" (Aeson.object [])] - deletion <- Async.async (runRawDestructionHeld store rawDeleteStreamEventsStmt) - waitForCoordinatorPhase store 100 - acquisition <- Async.async $ runStoreIO store $ acquireHistoryRetentionLease (request "raw-race" "delete-first" 60) - threadDelay 50_000 - Async.poll acquisition >>= \case - Nothing -> pure () - Just _ -> expectationFailure "lease acquisition completed while raw deletion held the coordinator" - waitWithin "delete-first raw deletion" deletion `shouldReturn` Right () - acquired <- waitWithin "delete-first acquisition" acquisition - acquired `shouldSatisfy` \case Right HistoryRetentionLease{} -> True; _ -> False - countStreamEvents store `shouldReturn` 0 + it "serializes delete-first maintenance ahead of post-delete acquisition" $ + withTestStore $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "raw-race-delete-first") NoStream [makeEvent "Raw" (Aeson.object [])] + deletion <- Async.async (runRawDestructionHeld store rawDeleteStreamEventsStmt) + waitForCoordinatorPhase store 100 + acquisition <- Async.async $ runStoreIO store $ acquireHistoryRetentionLease (request "raw-race" "delete-first" 60) + threadDelay 50_000 + Async.poll acquisition >>= \case + Nothing -> pure () + Just _ -> expectationFailure "lease acquisition completed while raw deletion held the coordinator" + waitWithin "delete-first raw deletion" deletion `shouldReturn` Right () + acquired <- waitWithin "delete-first acquisition" acquisition + acquired `shouldSatisfy` \case Right HistoryRetentionLease {} -> True; _ -> False + countStreamEvents store `shouldReturn` 0 - it "rejects GUC-enabled DELETE with KR001 and permits it after release" $ - withTestStore $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "raw-delete") NoStream (replicate 2 (makeEvent "Raw" (Aeson.object []))) - countBefore <- countStreamEvents store - Right lease <- runStoreIO store $ acquireHistoryRetentionLease (request "raw" "delete" 60) - rejected <- runRawDestruction store rawDeleteStreamEventsStmt - rejected `shouldSatisfy` hasSqlState "KR001" - countStreamEvents store `shouldReturn` countBefore - Right HistoryRetentionReleased{} <- runStoreIO store $ releaseHistoryRetentionLease (leaseHandle lease) - runRawDestruction store rawDeleteStreamEventsStmt `shouldReturn` Right () - countStreamEvents store `shouldReturn` 0 + it "rejects GUC-enabled DELETE with KR001 and permits it after release" $ + withTestStore $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "raw-delete") NoStream (replicate 2 (makeEvent "Raw" (Aeson.object []))) + countBefore <- countStreamEvents store + Right lease <- runStoreIO store $ acquireHistoryRetentionLease (request "raw" "delete" 60) + rejected <- runRawDestruction store rawDeleteStreamEventsStmt + rejected `shouldSatisfy` hasSqlState "KR001" + countStreamEvents store `shouldReturn` countBefore + Right HistoryRetentionReleased {} <- runStoreIO store $ releaseHistoryRetentionLease (leaseHandle lease) + runRawDestruction store rawDeleteStreamEventsStmt `shouldReturn` Right () + countStreamEvents store `shouldReturn` 0 - it "rejects GUC-enabled TRUNCATE with KR001 and permits it after release" $ - withTestStore $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "raw-truncate") NoStream [makeEvent "Raw" (Aeson.object [])] - countBefore <- countEvents store - Right lease <- runStoreIO store $ acquireHistoryRetentionLease (request "raw" "truncate" 60) - rejected <- runRawDestruction store rawTruncateDataStmt - rejected `shouldSatisfy` hasSqlState "KR001" - countEvents store `shouldReturn` countBefore - Right HistoryRetentionReleased{} <- runStoreIO store $ releaseHistoryRetentionLease (leaseHandle lease) - runRawDestruction store rawTruncateDataStmt `shouldReturn` Right () - countEvents store `shouldReturn` 0 + it "rejects GUC-enabled TRUNCATE with KR001 and permits it after release" $ + withTestStore $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "raw-truncate") NoStream [makeEvent "Raw" (Aeson.object [])] + countBefore <- countEvents store + Right lease <- runStoreIO store $ acquireHistoryRetentionLease (request "raw" "truncate" 60) + rejected <- runRawDestruction store rawTruncateDataStmt + rejected `shouldSatisfy` hasSqlState "KR001" + countEvents store `shouldReturn` countBefore + Right HistoryRetentionReleased {} <- runStoreIO store $ releaseHistoryRetentionLease (leaseHandle lease) + runRawDestruction store rawTruncateDataStmt `shouldReturn` Right () + countEvents store `shouldReturn` 0 - it "permits GUC-enabled maintenance after passive expiry" $ - withTestStore $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "raw-expiry") NoStream [makeEvent "Raw" (Aeson.object [])] - Right _ <- runStoreIO store $ acquireHistoryRetentionLease (request "raw" "expiry" 1) - threadDelay 1_100_000 - runRawDestruction store rawDeleteStreamEventsStmt `shouldReturn` Right () + it "permits GUC-enabled maintenance after passive expiry" $ + withTestStore $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "raw-expiry") NoStream [makeEvent "Raw" (Aeson.object [])] + Right _ <- runStoreIO store $ acquireHistoryRetentionLease (request "raw" "expiry" 1) + threadDelay 1_100_000 + runRawDestruction store rawDeleteStreamEventsStmt `shouldReturn` Right () runTx :: KirokuStore -> Tx.Transaction value -> IO value runTx store transaction = do - result <- runStoreIO store (runTransaction transaction) - case result of - Left err -> expectationFailure ("history retention transaction failed: " <> show err) >> error "unreachable" - Right value -> pure value + result <- runStoreIO store (runTransaction transaction) + case result of + Left err -> expectationFailure ("history retention transaction failed: " <> show err) >> error "unreachable" + Right value -> pure value request :: Text.Text -> Text.Text -> Integer -> HistoryRetentionLeaseRequest request ownerText reasonText seconds = - HistoryRetentionLeaseRequest - { owner = validatedOwner ownerText - , reason = either (error . show) (\value -> value) (mkHistoryRetentionLeaseReason reasonText) - , duration = validatedDuration seconds - } + HistoryRetentionLeaseRequest + { owner = validatedOwner ownerText, + reason = either (error . show) (\value -> value) (mkHistoryRetentionLeaseReason reasonText), + duration = validatedDuration seconds + } validatedOwner :: Text.Text -> HistoryRetentionLeaseOwner validatedOwner = either (error . show) (\value -> value) . mkHistoryRetentionLeaseOwner @@ -278,99 +278,99 @@ runRawDestruction :: KirokuStore -> Statement () () -> IO (Either Pool.UsageError ()) runRawDestruction store statement = - Pool.use (store ^. #pool) $ - TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do - Tx.sql "SET LOCAL kiroku.enable_hard_deletes = 'on'" - Tx.statement () statement + Pool.use (store ^. #pool) $ + TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do + Tx.sql "SET LOCAL kiroku.enable_hard_deletes = 'on'" + Tx.statement () statement runRawDestructionHeld :: KirokuStore -> Statement () () -> IO (Either Pool.UsageError ()) runRawDestructionHeld store statement = - Pool.use (store ^. #pool) $ - TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do - Tx.sql "SET LOCAL kiroku.enable_hard_deletes = 'on'" - Tx.statement () statement - _ <- Tx.statement () holdCoordinatorStmt - pure () + Pool.use (store ^. #pool) $ + TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do + Tx.sql "SET LOCAL kiroku.enable_hard_deletes = 'on'" + Tx.statement () statement + _ <- Tx.statement () holdCoordinatorStmt + pure () waitForCoordinatorPhase :: KirokuStore -> Int -> IO () waitForCoordinatorPhase _ 0 = expectationFailure "coordinator holder never reached its held phase" waitForCoordinatorPhase store attempts = do - result <- Pool.use (store ^. #pool) (Session.statement () coordinatorActiveStmt) - case result of - Right True -> pure () - Right False -> threadDelay 10_000 >> waitForCoordinatorPhase store (attempts - 1) - Left err -> expectationFailure ("could not observe coordinator phase: " <> show err) + result <- Pool.use (store ^. #pool) (Session.statement () coordinatorActiveStmt) + case result of + Right True -> pure () + Right False -> threadDelay 10_000 >> waitForCoordinatorPhase store (attempts - 1) + Left err -> expectationFailure ("could not observe coordinator phase: " <> show err) waitWithin :: String -> Async.Async value -> IO value waitWithin label action = do - result <- Async.race (threadDelay 2_000_000) (Async.wait action) - case result of - Left () -> do - Async.cancel action - expectationFailure (label <> " timed out") - error "unreachable" - Right value -> pure value + result <- Async.race (threadDelay 2_000_000) (Async.wait action) + case result of + Left () -> do + Async.cancel action + expectationFailure (label <> " timed out") + error "unreachable" + Right value -> pure value hasSqlState :: Text.Text -> Either Pool.UsageError value -> Bool hasSqlState expected = \case - Left - ( Pool.SessionUsageError - ( Errors.StatementSessionError - _ - _ - _ - _ - _ - (Errors.ServerStatementError (Errors.ServerError actual _ _ _ _)) - ) - ) -> actual == expected - _ -> False + Left + ( Pool.SessionUsageError + ( Errors.StatementSessionError + _ + _ + _ + _ + _ + (Errors.ServerStatementError (Errors.ServerError actual _ _ _ _)) + ) + ) -> actual == expected + _ -> False countStreamEvents :: KirokuStore -> IO Int64 countStreamEvents store = do - result <- Pool.use (store ^. #pool) (TxSessions.transaction TxSessions.ReadCommitted TxSessions.Read (Tx.statement () countStreamEventsStmt)) - case result of - Left err -> expectationFailure ("could not count stream junctions: " <> show err) >> error "unreachable" - Right value -> pure value + result <- Pool.use (store ^. #pool) (TxSessions.transaction TxSessions.ReadCommitted TxSessions.Read (Tx.statement () countStreamEventsStmt)) + case result of + Left err -> expectationFailure ("could not count stream junctions: " <> show err) >> error "unreachable" + Right value -> pure value countStreamEventsStmt :: Statement () Int64 countStreamEventsStmt = - unpreparable - "SELECT count(*) FROM stream_events" - E.noParams - (D.singleRow (D.column (D.nonNullable D.int8))) + unpreparable + "SELECT count(*) FROM stream_events" + E.noParams + (D.singleRow (D.column (D.nonNullable D.int8))) rawDeleteStreamEventsStmt :: Statement () () rawDeleteStreamEventsStmt = - unpreparable - "DELETE FROM stream_events" - E.noParams - D.noResult + unpreparable + "DELETE FROM stream_events" + E.noParams + D.noResult rawTruncateDataStmt :: Statement () () rawTruncateDataStmt = - unpreparable - "TRUNCATE dead_letters, stream_events, events" - E.noParams - D.noResult + unpreparable + "TRUNCATE dead_letters, stream_events, events" + E.noParams + D.noResult holdCoordinatorStmt :: Statement () Bool holdCoordinatorStmt = - preparable - "SELECT pg_sleep(0.4) IS NULL /* history-retention-coordinator-race */" - E.noParams - (D.singleRow (D.column (D.nonNullable D.bool))) + preparable + "SELECT pg_sleep(0.4) IS NULL /* history-retention-coordinator-race */" + E.noParams + (D.singleRow (D.column (D.nonNullable D.bool))) coordinatorActiveStmt :: Statement () Bool coordinatorActiveStmt = - preparable - """ - SELECT EXISTS ( - SELECT 1 - FROM pg_stat_activity - WHERE state = 'active' - AND query = 'SELECT pg_sleep(0.4) IS NULL /* history-retention-coordinator-race */' - ) - """ - E.noParams - (D.singleRow (D.column (D.nonNullable D.bool))) + preparable + """ + SELECT EXISTS ( + SELECT 1 + FROM pg_stat_activity + WHERE state = 'active' + AND query = 'SELECT pg_sleep(0.4) IS NULL /* history-retention-coordinator-race */' + ) + """ + E.noParams + (D.singleRow (D.column (D.nonNullable D.bool))) diff --git a/test/Test/HistoryRetentionMock.hs b/test/Test/HistoryRetentionMock.hs --- a/test/Test/HistoryRetentionMock.hs +++ b/test/Test/HistoryRetentionMock.hs @@ -16,71 +16,71 @@ spec :: Spec spec = describe "history retention mock" $ do - it "dispatches every closed lease operation exactly once" $ do - calls <- newIORef ([] :: [Text]) - actual <- runEff $ runMock calls $ do - acquired <- acquireHistoryRetentionLease sampleRequest - renewed <- renewHistoryRetentionLease sampleHandle sampleDuration - released <- releaseHistoryRetentionLease sampleHandle - inventory <- historyRetentionLeaseInventory sampleQuery - pruned <- pruneHistoryRetentionLeases sampleTime - pure (acquired, renewed, released, inventory, pruned) - actual - `shouldBe` ( sampleLease - , Right sampleLease - , HistoryRetentionReleased sampleLease - , Vector.singleton sampleLease - , HistoryRetentionPruneResult 2 3 - ) - readIORef calls - `shouldReturn` ["acquire", "renew", "release", "inventory", "prune"] + it "dispatches every closed lease operation exactly once" $ do + calls <- newIORef ([] :: [Text]) + actual <- runEff $ runMock calls $ do + acquired <- acquireHistoryRetentionLease sampleRequest + renewed <- renewHistoryRetentionLease sampleHandle sampleDuration + released <- releaseHistoryRetentionLease sampleHandle + inventory <- historyRetentionLeaseInventory sampleQuery + pruned <- pruneHistoryRetentionLeases sampleTime + pure (acquired, renewed, released, inventory, pruned) + actual + `shouldBe` ( sampleLease, + Right sampleLease, + HistoryRetentionReleased sampleLease, + Vector.singleton sampleLease, + HistoryRetentionPruneResult 2 3 + ) + readIORef calls + `shouldReturn` ["acquire", "renew", "release", "inventory", "prune"] runMock :: (IOE :> es) => IORef [Text] -> Eff (Store : es) a -> Eff es a runMock calls = interpret_ $ \case - AcquireHistoryRetentionLease request -> do - liftIO $ request `shouldBe` sampleRequest - record calls "acquire" - pure sampleLease - RenewHistoryRetentionLease handle duration -> do - liftIO $ (handle, duration) `shouldBe` (sampleHandle, sampleDuration) - record calls "renew" - pure (Right sampleLease) - ReleaseHistoryRetentionLease handle -> do - liftIO $ handle `shouldBe` sampleHandle - record calls "release" - pure (HistoryRetentionReleased sampleLease) - GetHistoryRetentionLeaseInventory query -> do - liftIO $ query `shouldBe` sampleQuery - record calls "inventory" - pure (Vector.singleton sampleLease) - PruneHistoryRetentionLeases cutoff -> do - liftIO $ cutoff `shouldBe` sampleTime - record calls "prune" - pure (HistoryRetentionPruneResult 2 3) - _ -> error "unexpected Store operation in history retention mock" + AcquireHistoryRetentionLease request -> do + liftIO $ request `shouldBe` sampleRequest + record calls "acquire" + pure sampleLease + RenewHistoryRetentionLease handle duration -> do + liftIO $ (handle, duration) `shouldBe` (sampleHandle, sampleDuration) + record calls "renew" + pure (Right sampleLease) + ReleaseHistoryRetentionLease handle -> do + liftIO $ handle `shouldBe` sampleHandle + record calls "release" + pure (HistoryRetentionReleased sampleLease) + GetHistoryRetentionLeaseInventory query -> do + liftIO $ query `shouldBe` sampleQuery + record calls "inventory" + pure (Vector.singleton sampleLease) + PruneHistoryRetentionLeases cutoff -> do + liftIO $ cutoff `shouldBe` sampleTime + record calls "prune" + pure (HistoryRetentionPruneResult 2 3) + _ -> error "unexpected Store operation in history retention mock" record :: (IOE :> es) => IORef [Text] -> Text -> Eff es () record calls name = liftIO $ modifyIORef' calls (<> [name]) sampleRequest :: HistoryRetentionLeaseRequest sampleRequest = - HistoryRetentionLeaseRequest sampleOwner sampleReason sampleDuration + HistoryRetentionLeaseRequest sampleOwner sampleReason sampleDuration sampleHandle :: HistoryRetentionLeaseHandle sampleHandle = HistoryRetentionLeaseHandle sampleId sampleOwner sampleLease :: HistoryRetentionLease sampleLease = - HistoryRetentionLease - sampleId - sampleOwner - sampleReason - (GlobalPosition 17) - sampleTime - sampleTime - sampleExpiry - Nothing - HistoryRetentionLeaseActive + HistoryRetentionLease + sampleId + sampleOwner + sampleReason + (GlobalPosition 17) + sampleTime + sampleTime + sampleExpiry + Nothing + HistoryRetentionLeaseActive sampleId :: HistoryRetentionLeaseId sampleId = HistoryRetentionLeaseId UUID.nil @@ -96,8 +96,8 @@ sampleQuery :: HistoryRetentionInventoryQuery sampleQuery = - HistoryRetentionInventoryQuery $ - either (error . show) (\value -> value) (mkHistoryRetentionInventoryLimit 10) + HistoryRetentionInventoryQuery $ + either (error . show) (\value -> value) (mkHistoryRetentionInventoryLimit 10) sampleTime :: UTCTime sampleTime = UTCTime (fromGregorian 2026 8 13) 0 diff --git a/test/Test/InterpreterHooks.hs b/test/Test/InterpreterHooks.hs --- a/test/Test/InterpreterHooks.hs +++ b/test/Test/InterpreterHooks.hs @@ -1,17 +1,16 @@ -{- | 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. --} +-- | 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) @@ -27,9 +26,9 @@ spec :: Spec spec = describe "InterpreterHooks" $ do - describe "enrichEvent" appendHookFiresSpec - describe "decodeHook" readHookFiresSpec - describe "no hooks" noHookNoEffectSpec + describe "enrichEvent" appendHookFiresSpec + describe "decodeHook" readHookFiresSpec + describe "no hooks" noHookNoEffectSpec -- --------------------------------------------------------------------------- -- enrichEvent @@ -37,50 +36,50 @@ 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 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)]) + 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 @@ -88,82 +87,82 @@ readHookFiresSpec :: Spec readHookFiresSpec = do - it "retains the no-hook batch without evaluating its events" $ do - batch <- decodeEvents defaultStoreSettings (V.replicate 100 (error "no-hook decoding traversed the vector")) - case batch of - UnchangedBatch events -> V.length events `shouldBe` 100 - TransformedBatch _ -> expectationFailure "default decoding allocated per-event outcomes" + it "retains the no-hook batch without evaluating its events" $ do + batch <- decodeEvents defaultStoreSettings (V.replicate 100 (error "no-hook decoding traversed the vector")) + case batch of + UnchangedBatch events -> V.length events `shouldBe` 100 + TransformedBatch _ -> expectationFailure "default decoding allocated per-event outcomes" - it "applies decodeHook to readAllForward results" $ do - let marker = Aeson.object [("decoded", Aeson.String "yes")] - inject re = pure $ Right (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 readAllForward results" $ do + let marker = Aeson.object [("decoded", Aeson.String "yes")] + inject re = pure $ Right (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 - caughtUp <- newEmptyMVar - let marker = Aeson.object [("sub", Aeson.String "tagged")] - inject re = pure $ Right (re & #metadata .~ Just marker) - subName = SubscriptionName "hook-sub-1" - tweak cs = - cs - & #storeSettings - .~ defaultStoreSettings{decodeHook = Just inject} - & #eventHandler .~ Just (caughtUpEventHandler subName caughtUp Nothing) - 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) + it "applies decodeHook to subscription handlers across catch-up and live phases" $ do + caughtUp <- newEmptyMVar + let marker = Aeson.object [("sub", Aeson.String "tagged")] + inject re = pure $ Right (re & #metadata .~ Just marker) + subName = SubscriptionName "hook-sub-1" + tweak cs = + cs + & #storeSettings + .~ defaultStoreSettings {decodeHook = Just inject} + & #eventHandler .~ Just (caughtUpEventHandler subName caughtUp Nothing) + 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 - waitForSubscriptionLive caughtUp - -- 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] + 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 + waitForSubscriptionLive caughtUp + -- 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 @@ -171,17 +170,17 @@ 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 + 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/NamespaceQueryPlans.hs b/test/Test/NamespaceQueryPlans.hs new file mode 100644 --- /dev/null +++ b/test/Test/NamespaceQueryPlans.hs @@ -0,0 +1,98 @@ +module Test.NamespaceQueryPlans (spec) where + +import Control.Lens ((^.)) +import Control.Monad (forM_, unless) +import Data.Aeson (Value (..)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as T +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 qualified as Statement +import Kiroku.Store +import Kiroku.Store.SQL qualified as SQL +import System.Environment (lookupEnv) +import Test.Helpers (withTestStore) +import Test.Hspec + +spec :: Spec +spec = describe "namespace production query bounds" $ + forM_ [1000, 20000 :: Int] $ \total -> + it ("bounds generic/custom scans and payload probes on " <> show total <> " rows") $ + withTestStore $ \store -> do + run store (Session.script (fixture total)) + forM_ ["force_custom_plan", "force_generic_plan"] $ \mode -> + forM_ [32, 1024 :: Int] $ \width -> + forM_ ["pm", "pm:sparse", "absent"] $ \namespace -> + forM_ [0, total - 100] $ \cursor -> + forM_ [False, True] $ \grouped -> do + let query = if grouped then Statement.toSql SQL.readNamespaceGroupWindowStmt else Statement.toSql SQL.readNamespaceWindowStmt + types = if grouped then "int8,int8,text,int4,int4,int4" else "int8,int8,text,int4" + args = T.intercalate "," [t cursor, t total, "'" <> namespace <> "'", t width] <> if grouped then ",0,3" else "" + bytes <- run store $ do + Session.script ("SET plan_cache_mode=" <> mode <> "; PREPARE namespace_probe(" <> types <> ") AS " <> query) + bytes <- Session.statement () (Statement.unpreparable ("EXPLAIN (ANALYZE,BUFFERS,TIMING OFF,FORMAT JSON) EXECUTE namespace_probe(" <> args <> ")") E.noParams (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right))))) + Session.script "DEALLOCATE namespace_probe; RESET plan_cache_mode" + pure bytes + plan <- either fail pure (Aeson.eitherDecodeStrict' bytes) + evidence <- lookupEnv "EP54_PLAN_EVIDENCE" + forM_ evidence $ \path -> + LBS.appendFile + path + ( Aeson.encode + ( Aeson.object + [ "rows" Aeson..= total, + "mode" Aeson..= mode, + "width" Aeson..= width, + "namespace" Aeson..= namespace, + "cursor" Aeson..= cursor, + "grouped" Aeson..= grouped, + "explain" Aeson..= plan + ] + ) + <> "\n" + ) + let scans = nodes plan + relation name = filter (\obj -> KM.lookup "Relation Name" obj == Just (String name)) scans + countRows name = sum [num "Actual Loops" obj * (num "Actual Rows" obj + num "Rows Removed by Filter" obj) | obj <- relation name] + payloads = sum [num "Actual Loops" obj * num "Actual Rows" obj | obj <- relation "events"] + caseLabel = T.unpack (mode <> "/" <> namespace <> "/W=" <> t width <> "/cursor=" <> t cursor <> "/group=" <> T.pack (show grouped)) + let verify condition = unless condition (expectationFailure (caseLabel <> "\n" <> show [(KM.lookup "Relation Name" obj, KM.lookup "Node Type" obj, KM.lookup "Index Name" obj, num "Actual Rows" obj, num "Actual Loops" obj, num "Rows Removed by Filter" obj) | obj <- scans, KM.member "Relation Name" obj])) + verify (null (relation "streams")) + verify (countRows "stream_events" <= fromIntegral width) + verify ([index | obj <- relation "stream_events", Just (String index) <- [KM.lookup "Index Name" obj]] == ["ux_stream_events_stream_version"]) + verify (payloads <= fromIntegral (min width (total - cursor))) + if namespace == "absent" then verify (payloads == 0 && all (\obj -> num "Actual Loops" obj == 0) (relation "events")) else pure () + forM_ (relation "events") $ \obj -> + verify (num "Actual Loops" obj == 0 || KM.lookup "Node Type" obj == Just (String "Index Scan")) + +fixture :: Int -> Text +fixture count = + T.unlines + [ "WITH source AS (INSERT INTO streams(stream_name,stream_version) SELECT (CASE WHEN n % 100 = 0 THEN 'pm:sparse-' ELSE 'pm:dense-' END) || n,1 FROM generate_series(1," <> t count <> ") n RETURNING stream_id),", + "f AS MATERIALIZED (SELECT stream_id, row_number() OVER (ORDER BY stream_id) AS pos, uuidv7() AS id FROM source),", + "e AS (INSERT INTO events(event_id,event_type,data) SELECT id,'Fixture','{}' FROM f RETURNING event_id),", + "se AS (INSERT INTO stream_events(event_id,stream_id,stream_version,original_stream_id,original_stream_version) SELECT id,stream_id,1,stream_id,1 FROM f JOIN e ON event_id=id RETURNING event_id)", + "INSERT INTO stream_events(event_id,stream_id,stream_version,original_stream_id,original_stream_version,category) SELECT id,0,pos,stream_id,1, CASE WHEN pos % 100 = 0 THEN 'pm:sparse' ELSE 'pm:dense' END FROM f JOIN se ON event_id=id;", + "UPDATE streams SET stream_version=" <> t count <> " WHERE stream_id=0; ANALYZE streams; ANALYZE stream_events; ANALYZE events;" + ] + +nodes :: Value -> [Aeson.Object] +nodes (Object fields) = fields : concatMap nodes (KM.elems fields) +nodes (Array values) = concatMap nodes (V.toList values) +nodes _ = [] + +num :: Aeson.Key -> Aeson.Object -> Double +num key obj = case KM.lookup key obj of Just (Number n) -> realToFrac n; _ -> 0 + +t :: (Show a) => a -> Text +t = T.pack . show + +run :: KirokuStore -> Session.Session a -> IO a +run store action = Pool.use (store ^. #pool) action >>= either (fail . show) pure diff --git a/test/Test/NotifyGuard.hs b/test/Test/NotifyGuard.hs --- a/test/Test/NotifyGuard.hs +++ b/test/Test/NotifyGuard.hs @@ -21,101 +21,101 @@ spec :: Spec spec = - describe "NOTIFY trigger guard" $ - around withNotifyStore $ do - it "emits one unchanged append payload and no lifecycle or $all payloads" $ \(store, listenerConn) -> do - payloads <- newTVarIO [] + describe "NOTIFY trigger guard" $ + around withNotifyStore $ do + it "emits one unchanged append payload and no lifecycle or $all payloads" $ \(store, listenerConn) -> do + payloads <- newTVarIO [] - Notifications.listen listenerConn (Notifications.toPgIdentifier "kiroku.events") - Async.withAsync - (Notifications.waitForNotifications (\_ payload -> atomically (modifyTVar' payloads (<> [payload]))) listenerConn) - $ \_listener -> do - let firstStream = StreamName "notify-guard-1" - secondStream = StreamName "notify-guard-2" + Notifications.listen listenerConn (Notifications.toPgIdentifier "kiroku.events") + Async.withAsync + (Notifications.waitForNotifications (\_ payload -> atomically (modifyTVar' payloads (<> [payload]))) listenerConn) + $ \_listener -> do + let firstStream = StreamName "notify-guard-1" + secondStream = StreamName "notify-guard-2" - Right first <- - runStoreIO store $ - appendToStream firstStream NoStream [makeEvent "NotifyGuardFirst" (Aeson.object [])] - waitForPayload payloads (expectedPayload firstStream first) + Right first <- + runStoreIO store $ + appendToStream firstStream NoStream [makeEvent "NotifyGuardFirst" (Aeson.object [])] + waitForPayload payloads (expectedPayload firstStream first) - Right _ <- runStoreIO store $ softDeleteStream firstStream - Right _ <- runStoreIO store $ undeleteStream firstStream + Right _ <- runStoreIO store $ softDeleteStream firstStream + Right _ <- runStoreIO store $ undeleteStream firstStream - Right second <- - runStoreIO store $ - appendToStream secondStream NoStream [makeEvent "NotifyGuardSecond" (Aeson.object [])] - waitForPayload payloads (expectedPayload secondStream second) + Right second <- + runStoreIO store $ + appendToStream secondStream NoStream [makeEvent "NotifyGuardSecond" (Aeson.object [])] + waitForPayload payloads (expectedPayload secondStream second) - actual <- atomically (readTVar payloads) - actual - `shouldBe` [ expectedPayload firstStream first - , expectedPayload secondStream second - ] - map payloadFieldCount actual `shouldBe` [3, 3] - actual `shouldSatisfy` all (not . BS.isPrefixOf "$all,") + actual <- atomically (readTVar payloads) + actual + `shouldBe` [ expectedPayload firstStream first, + expectedPayload secondStream second + ] + map payloadFieldCount actual `shouldBe` [3, 3] + actual `shouldSatisfy` all (not . BS.isPrefixOf "$all,") - it "emits the unchanged payload for a 512-byte stream name" $ \(store, listenerConn) -> do - payloads <- newTVarIO [] + it "emits the unchanged payload for a 512-byte stream name" $ \(store, listenerConn) -> do + payloads <- newTVarIO [] - Notifications.listen listenerConn (Notifications.toPgIdentifier "kiroku.events") - Async.withAsync - (Notifications.waitForNotifications (\_ payload -> atomically (modifyTVar' payloads (<> [payload]))) listenerConn) - $ \_listener -> do - let stream = StreamName (T.replicate 512 "n") + Notifications.listen listenerConn (Notifications.toPgIdentifier "kiroku.events") + Async.withAsync + (Notifications.waitForNotifications (\_ payload -> atomically (modifyTVar' payloads (<> [payload]))) listenerConn) + $ \_listener -> do + let stream = StreamName (T.replicate 512 "n") - Right result <- - runStoreIO store $ - appendToStream stream NoStream [makeEvent "NotifyGuardMaxName" (Aeson.object [])] - let expected = expectedPayload stream result - waitForPayload payloads expected + Right result <- + runStoreIO store $ + appendToStream stream NoStream [makeEvent "NotifyGuardMaxName" (Aeson.object [])] + let expected = expectedPayload stream result + waitForPayload payloads expected - actual <- atomically (readTVar payloads) - actual `shouldBe` [expected] - payloadFieldCount expected `shouldBe` 3 + actual <- atomically (readTVar payloads) + actual `shouldBe` [expected] + payloadFieldCount expected `shouldBe` 3 withNotifyStore :: ((KirokuStore, Connection.Connection) -> IO ()) -> IO () withNotifyStore action = - withMigratedTestDatabase $ \connStr -> - withStore (defaultConnectionSettings connStr) $ \store -> - withConnection connStr $ \listenerConn -> - action (store, listenerConn) + withMigratedTestDatabase $ \connStr -> + withStore (defaultConnectionSettings connStr) $ \store -> + withConnection connStr $ \listenerConn -> + action (store, listenerConn) withConnection :: T.Text -> (Connection.Connection -> IO a) -> IO a withConnection connStr = - bracket acquire Connection.release + bracket acquire Connection.release where acquire = do - result <- Connection.acquire (Conn.connectionString connStr) - case result of - Left err -> throwIO (userError ("failed to acquire LISTEN connection: " <> show err)) - Right conn -> pure conn + result <- Connection.acquire (Conn.connectionString connStr) + case result of + Left err -> throwIO (userError ("failed to acquire LISTEN connection: " <> show err)) + Right conn -> pure conn expectedPayload :: StreamName -> AppendResult -> ByteString expectedPayload (StreamName name) result = - let StreamId sid = result ^. #streamId - StreamVersion version = result ^. #streamVersion - in T.encodeUtf8 $ - T.intercalate - "," - [ name - , T.pack (show sid) - , T.pack (show version) - ] + let StreamId sid = result ^. #streamId + StreamVersion version = result ^. #streamVersion + in T.encodeUtf8 $ + T.intercalate + "," + [ name, + T.pack (show sid), + T.pack (show version) + ] payloadFieldCount :: ByteString -> Int payloadFieldCount = length . BS.split 44 waitForPayload :: TVar [ByteString] -> ByteString -> IO () waitForPayload payloads expected = do - result <- - Async.race - (threadDelay 5_000_000) - ( atomically $ do - seen <- readTVar payloads - check (expected `elem` seen) - ) - case result of - Left () -> do - seen <- atomically (readTVar payloads) - expectationFailure ("timed out waiting for notification " <> show expected <> "; saw " <> show seen) - Right () -> pure () + result <- + Async.race + (threadDelay 5_000_000) + ( atomically $ do + seen <- readTVar payloads + check (expected `elem` seen) + ) + case result of + Left () -> do + seen <- atomically (readTVar payloads) + expectationFailure ("timed out waiting for notification " <> show expected <> "; saw " <> show seen) + Right () -> pure () diff --git a/test/Test/PerformanceStructure.hs b/test/Test/PerformanceStructure.hs --- a/test/Test/PerformanceStructure.hs +++ b/test/Test/PerformanceStructure.hs @@ -33,618 +33,616 @@ spec :: Spec spec = do - noOpAppendSpec - queryPlanSpec - DeadLetterQueryPlans.spec - categoryReadCostSpec - streamHeadQuerySpec - -noOpAppendSpec :: Spec -noOpAppendSpec = - describe "no-op paths use no pooled connection" $ do - it "rejects invalid dead-letter page sizes before pool checkout" $ do - checkouts <- newIORef (0 :: Int) - withObservedStore checkouts $ \_ -> do - before <- readIORef checkouts - forM_ [0, -1, 1001] $ \n -> mkSubscriptionDeadLetterLimit n `shouldBe` Left (SubscriptionDeadLetterLimitOutOfRange n) - after <- readIORef checkouts - after - before `shouldBe` 0 - - it "rejects invalid batch and buffer sizes before pool checkout" $ do - checkouts <- newIORef (0 :: Int) - withObservedStore checkouts $ \_ -> do - before <- readIORef checkouts - mkBatchSize 0 `shouldBe` Left (InvalidBatchSize 0) - mkBatchSize (-1) `shouldBe` Left (InvalidBatchSize (-1)) - Buffer.mkStreamBufferSize 0 `shouldBe` Left (Buffer.InvalidStreamBufferSize 0) - after <- readIORef checkouts - after - before `shouldBe` 0 - - it "rejects invalid consumer-group values before pool checkout" $ do - checkouts <- newIORef (0 :: Int) - withObservedStore checkouts $ \_ -> do - before <- readIORef checkouts - mkConsumerGroupSize 0 `shouldBe` Left (InvalidConsumerGroup 0 0) - let Right n = mkConsumerGroupSize 2 - mkConsumerGroup 2 n `shouldBe` Left (InvalidConsumerGroup 2 2) - after <- readIORef checkouts - after - before `shouldBe` 0 - - it "refuses mismatched topology in exactly one initialization checkout with no handler" $ do - workerThread <- newIORef Nothing - checkouts <- newIORef (0 :: Int) - delivered <- newIORef False - let observe (ConnectionObservation _ InUseConnectionStatus) = do - thread <- myThreadId - selected <- readIORef workerThread - if selected == Just thread then modifyIORef' checkouts (+ 1) else pure () - observe _ = pure () - withTestStoreSettings (\settings -> settings{observationHandler = Just observe}) $ \store -> do - seeded <- Pool.use (store ^. #pool) (Session.statement ("topology-checkout", 0, 0, 2, "unbound", Nothing) SQL.saveCheckpointMemberStmt) - seeded `shouldBe` Right () - withLoadCheckpointHookForTest - ( \_ -> do - thread <- myThreadId - writeIORef workerThread (Just thread) - pure Nothing - ) - $ do - let cfg = - (defaultSubscriptionConfig (SubscriptionName "topology-checkout") AllStreams (\_ -> writeIORef delivered True >> pure Continue)) - { consumerGroup = Just (validConsumerGroup 0 3) - } - handle <- subscribe store cfg - waitWithTimeout 5_000_000 handle >>= \case - Right (Left exception) -> - (fromException exception :: Maybe ConsumerGroupSizeMismatch) `shouldSatisfy` maybe False (const True) - other -> expectationFailure ("expected mismatch, got " <> show other) - readIORef checkouts `shouldReturn` 1 - readIORef delivered `shouldReturn` False - - it "refuses mismatched target in exactly one initialization checkout with no handler" $ do - workerThread <- newIORef Nothing - checkouts <- newIORef (0 :: Int) - delivered <- newIORef False - let observe (ConnectionObservation _ InUseConnectionStatus) = do - thread <- myThreadId - selected <- readIORef workerThread - if selected == Just thread then modifyIORef' checkouts (+ 1) else pure () - observe _ = pure () - withTestStoreSettings (\settings -> settings{observationHandler = Just observe}) $ \store -> do - seeded <- Pool.use (store ^. #pool) (Session.statement ("target-checkout", 0, 0, 1, "all", Nothing) SQL.saveCheckpointMemberStmt) - seeded `shouldBe` Right () - withLoadCheckpointHookForTest - ( \_ -> do - thread <- myThreadId - writeIORef workerThread (Just thread) - pure Nothing - ) - $ do - let cfg = - (defaultSubscriptionConfig (SubscriptionName "target-checkout") (Category (CategoryName "other")) (\_ -> writeIORef delivered True >> pure Continue)) - - handle <- subscribe store cfg - waitWithTimeout 5_000_000 handle >>= \case - Right (Left exception) -> - (fromException exception :: Maybe SubscriptionTargetMismatch) `shouldSatisfy` maybe False (const True) - other -> expectationFailure ("expected mismatch, got " <> show other) - readIORef checkouts `shouldReturn` 1 - readIORef delivered `shouldReturn` False - - it "keeps ordinary checkpoint saves as one unconditional monotonic upsert" $ do - forM_ [Statement.toSql SQL.saveCheckpointMemberStmt, Statement.toSql SQL.saveAllCheckpointMemberStmt, Statement.toSql SQL.saveCategoryCheckpointMemberStmt] $ \statement -> do - let sql = T.toLower statement - T.count "insert into" sql `shouldBe` 1 - sql `shouldSatisfy` T.isInfixOf "greatest(subscriptions.last_seen, excluded.last_seen)" - sql `shouldNotSatisfy` T.isInfixOf "where" - sql `shouldNotSatisfy` T.isInfixOf "returning" - - it "rejects an empty appendToStream batch before pool checkout" $ do - checkouts <- newIORef (0 :: Int) - withObservedStore checkouts $ \store -> do - checkoutsBefore <- readIORef checkouts - result <- runStoreIO store $ appendToStream (StreamName "performance-empty-append") AnyVersion [] - checkoutsAfter <- readIORef checkouts - result `shouldBe` Left (EmptyAppendBatch (StreamName "performance-empty-append")) - checkoutsAfter - checkoutsBefore `shouldBe` 0 - - it "returns an empty appendMultiStream result before pool checkout" $ do - checkouts <- newIORef (0 :: Int) - withObservedStore checkouts $ \store -> do - checkoutsBefore <- readIORef checkouts - result <- runStoreIO store $ appendMultiStream [] - checkoutsAfter <- readIORef checkouts - result `shouldBe` Right [] - checkoutsAfter - checkoutsBefore `shouldBe` 0 - - it "rejects invalid retention requests before pool checkout" $ do - checkouts <- newIORef (0 :: Int) - withObservedStore checkouts $ \_store -> do - checkoutsBefore <- readIORef checkouts - mkHistoryRetentionLeaseOwner "" `shouldSatisfy` either (const True) (const False) - mkHistoryRetentionLeaseReason "" `shouldSatisfy` either (const True) (const False) - mkHistoryRetentionInventoryLimit 0 `shouldSatisfy` either (const True) (const False) - checkoutsAfter <- readIORef checkouts - checkoutsAfter - checkoutsBefore `shouldBe` 0 - - it "keeps every ordinary statement free of retention coordination" $ do - let ordinarySql = - [ Statement.toSql SQL.appendExpectedVersion - , Statement.toSql SQL.appendStreamExists - , Statement.toSql SQL.appendNoStream - , Statement.toSql SQL.appendAnyVersion - , Statement.toSql SQL.readStreamForwardStmt - , Statement.toSql SQL.readAllForwardStmt - , Statement.toSql SQL.softDeleteStreamStmt - , Statement.toSql SQL.undeleteStreamStmt - , Statement.toSql SQL.setStreamTruncateBeforeStmt - ] - forM_ ordinarySql $ \sql -> - T.toLower sql `shouldNotSatisfy` T.isInfixOf "history_retention" - -queryPlanSpec :: Spec -queryPlanSpec = - describe "production query plans" $ - aroundAll withQueryPlanStore $ do - it "visible global head lookup uses ux_stream_events_stream_version without Sort" $ \store -> do - plan <- - explainProductionStatement - store - SQL.visibleGlobalHeadPositionStmt - [] - expectIndex "ux_stream_events_stream_version" plan - expectNoNodeType "Sort" plan - - it "dead-letter reads use ix_dead_letters_subscription_position without Sort" $ \store -> do - plan <- - explainProductionStatement - store - SQL.readDeadLettersStmt - [ ("$2", "0::int4") - , ("$1", "'performance-read'::text") - ] - expectIndex "ix_dead_letters_subscription_position" plan - expectNoNodeType "Sort" plan - - it "orphan dead-letter cleanup uses ix_dead_letters_event_id" $ \store -> do - plan <- - explainProductionStatement - store - SQL.deleteDeadLettersForOrphanedEventsStmt - [("$1", "ARRAY['00000000-0000-0000-0000-000000000001'::uuid]::uuid[]")] - expectIndex "ix_dead_letters_event_id" plan - - it "active retention lookup uses ix_history_retention_leases_unreleased_expiry" $ \store -> do - plan <- explainProductionStatement store activeLeaseLookupStmt [] - expectIndex "ix_history_retention_leases_unreleased_expiry" plan - - it "installs no retention trigger for INSERT or UPDATE" $ \store -> do - result <- Pool.use (store ^. #pool) (Session.statement () retentionTriggerShapeStmt) - case result of - Left err -> expectationFailure ("could not inspect retention triggers: " <> show err) - Right shape -> shape `shouldBe` (6, 0) - -{- | BUG-2. A category read's cost must follow the rows it returns, not the -number of streams in the category. The store holds the category-scaling -fixture: @performance@ with 200 streams, @idle@ with 20,000 one-event streams, -and @noise@, head at 'categoryScalingHead'. --} -categoryReadCostSpec :: Spec -categoryReadCostSpec = - describe "category read cost" $ - aroundAll withCategoryScalingStore $ do - it "category high-cursor reads use ix_stream_events_all_by_category without Sort" $ \store -> do - plan <- - explainProductionStatement - store - SQL.readCategoryForwardStmt - [ ("$3", "100::int4") - , ("$2", "'performance'::text") - , ("$1", "15000::bigint") - ] - expectIndex "ix_stream_events_all_by_category" plan - expectNoNodeType "Sort" plan - - it "consumer-group category reads use ix_stream_events_all_by_category without Sort" $ \store -> do - plan <- - explainProductionStatement - store - SQL.readCategoryForwardConsumerGroupStmt - [ ("$5", "100::int4") - , ("$4", "2::int4") - , ("$3", "1::int4") - , ("$2", "'performance'::text") - , ("$1", "15000::bigint") - ] - expectIndex "ix_stream_events_all_by_category" plan - expectNoNodeType "Sort" plan - - it "category caught-up poll on 20000 idle streams reads at most 32 buffers" $ \store -> do - let cursor = T.pack (show categoryScalingHead) <> "::bigint" - plainAt = - [ ("$3", "100::int4") - , ("$2", "'idle'::text") - , ("$1", cursor) - ] - groupAt member = - [ ("$5", "100::int4") - , ("$4", "2::int4") - , ("$3", T.pack (show member) <> "::int4") - , ("$2", "'idle'::text") - , ("$1", cursor) - ] - groupMembers = [0, 1 :: Int] - - plainIdle <- explainAnalyzeBuffers store SQL.readCategoryForwardStmt plainAt - expectBufferBudget "plain caught-up poll" plainIdle - snd plainIdle `shouldBe` 0 - groupIdle <- mapM (explainAnalyzeBuffers store SQL.readCategoryForwardConsumerGroupStmt . groupAt) groupMembers - mapM_ (expectBufferBudget "group caught-up poll") groupIdle - map snd groupIdle `shouldBe` [0, 0] - - appended <- runStoreIO store $ appendToStream (StreamName "idle-1") AnyVersion [makeEvent "IdleWake" Null] - appended `shouldSatisfy` either (const False) (const True) - - plainOne <- explainAnalyzeBuffers store SQL.readCategoryForwardStmt plainAt - expectBufferBudget "plain poll after one append" plainOne - snd plainOne `shouldBe` 1 - groupOne <- mapM (explainAnalyzeBuffers store SQL.readCategoryForwardConsumerGroupStmt . groupAt) groupMembers - mapM_ (expectBufferBudget "group poll after one append") groupOne - -- Exactly one member owns idle-1. - sum (map snd groupOne) `shouldBe` 1 - -withCategoryScalingStore :: (KirokuStore -> IO ()) -> IO () -withCategoryScalingStore action = - withTestStore $ \store -> do - result <- Pool.use (store ^. #pool) (Session.script categoryScalingFixtureSql) - case result of - Left err -> expectationFailure ("failed to seed category-scaling fixture: " <> show err) - Right () -> action store - --- | The G1 budget: a category poll that returns at most one row. -expectBufferBudget :: String -> (Int64, Int64) -> Expectation -expectBufferBudget label (buffers, _) = - unless (buffers <= 32) $ - expectationFailure $ - label - <> ": expected at most 32 shared buffers, but the plan read " - <> show buffers - -{- | Execute a production statement under @EXPLAIN (ANALYZE, BUFFERS)@ and -return the top plan node's shared buffers (hit plus read) and actual rows. -Planning buffers are excluded; they are not paid by a prepared statement. --} -explainAnalyzeBuffers :: - KirokuStore -> - Statement params result -> - [(Text, Text)] -> - IO (Int64, Int64) -explainAnalyzeBuffers store productionStatement replacements = do - plan <- - explainWith - "EXPLAIN (ANALYZE, BUFFERS, COSTS OFF, TIMING OFF, FORMAT JSON)\n" - store - productionStatement - replacements - case plan of - Array entries - | Just (Object entry) <- headMay entries - , Just (Object top) <- KeyMap.lookup "Plan" entry -> - pure - ( numberField "Shared Hit Blocks" top + numberField "Shared Read Blocks" top - , numberField "Actual Rows" top - ) - _ -> expectationFailure ("unexpected EXPLAIN shape: " <> show plan) >> fail "unreachable" - where - headMay values = case foldr (:) [] values of - value : _ -> Just value - [] -> Nothing - numberField key object = case KeyMap.lookup key object of - Just value | Aeson.Success (number :: Double) <- Aeson.fromJSON value -> round number - _ -> 0 - -withObservedStore :: IORef Int -> (KirokuStore -> IO ()) -> IO () -withObservedStore checkouts = - withTestStoreSettings $ \settings -> - settings - { observationHandler = - Just $ \case - ConnectionObservation _ InUseConnectionStatus -> modifyIORef' checkouts (+ 1) - _ -> pure () - } - -withQueryPlanStore :: (KirokuStore -> IO ()) -> IO () -withQueryPlanStore action = - withTestStore $ \store -> do - result <- Pool.use (store ^. #pool) (Session.script queryPlanFixture) - case result of - Left err -> expectationFailure ("failed to seed performance query-plan fixture: " <> show err) - Right () -> action store - -queryPlanFixture :: Text -queryPlanFixture = - """ - BEGIN; - - WITH new_streams AS ( - INSERT INTO streams (stream_name, stream_version) - SELECT 'performance-' || n::text, 100 - FROM generate_series(1, 200) AS n - RETURNING stream_id - ), fixture_events AS MATERIALIZED ( - SELECT uuidv7() AS event_id, - s.stream_id, - per_stream_position::bigint AS stream_version, - row_number() OVER (ORDER BY per_stream_position, s.stream_id)::bigint AS global_position - FROM new_streams AS s - CROSS JOIN generate_series(1, 100) AS per_stream_position - ), inserted_events AS ( - INSERT INTO events (event_id, event_type, data) - SELECT event_id, 'PerformanceFixture', '{}'::jsonb - FROM fixture_events - RETURNING event_id - ), source_links AS ( - INSERT INTO stream_events - (event_id, stream_id, stream_version, original_stream_id, original_stream_version) - SELECT fixture.event_id, - fixture.stream_id, - fixture.stream_version, - fixture.stream_id, - fixture.stream_version - FROM fixture_events AS fixture - JOIN inserted_events USING (event_id) - RETURNING event_id - ), all_links AS ( - INSERT INTO stream_events - (event_id, stream_id, stream_version, original_stream_id, original_stream_version, category) - SELECT fixture.event_id, - 0, - fixture.global_position, - fixture.stream_id, - fixture.stream_version, - 'performance' - FROM fixture_events AS fixture - JOIN inserted_events USING (event_id) - RETURNING event_id - ), advanced_all AS ( - UPDATE streams - SET stream_version = (SELECT max(global_position) FROM fixture_events) - WHERE stream_id = 0 - RETURNING stream_id - ), inserted_dead_letters AS ( - INSERT INTO dead_letters - (subscription_name, consumer_group_member, global_position, event_id, - reason, reason_summary, attempt_count) - SELECT CASE - WHEN fixture.global_position % 10 = 0 THEN 'performance-read' - ELSE 'performance-other-' || (fixture.global_position % 9)::text - END, - 0, - fixture.global_position, - fixture.event_id, - '{}'::jsonb, - 'performance fixture', - 1 - FROM fixture_events AS fixture - JOIN inserted_events USING (event_id) - RETURNING dead_letter_id - ) - SELECT (SELECT count(*) FROM source_links), - (SELECT count(*) FROM all_links), - (SELECT count(*) FROM advanced_all), - (SELECT count(*) FROM inserted_dead_letters); - - COMMIT; - ANALYZE streams; - ANALYZE events; - ANALYZE stream_events; - ANALYZE dead_letters; - INSERT INTO history_retention_leases - (owner, reason, protected_through, created_at, renewed_at, expires_at, released_at) - SELECT 'performance-owner', - 'performance-reason', - 0, - clock_timestamp() - interval '1 day', - clock_timestamp() - interval '1 day', - clock_timestamp() + interval '1 hour', - CASE WHEN n <= 9900 THEN clock_timestamp() ELSE NULL END - FROM generate_series(1, 10000) AS n; - ANALYZE history_retention_leases; - """ - -explainProductionStatement :: - KirokuStore -> - Statement params result -> - [(Text, Text)] -> - IO Value -explainProductionStatement = explainWith "EXPLAIN (FORMAT JSON, COSTS OFF)\n" - -explainWith :: - Text -> - KirokuStore -> - Statement params result -> - [(Text, Text)] -> - IO Value -explainWith explainPrefix store productionStatement replacements = do - let productionSql = Statement.toSql productionStatement - explainedSql = - explainPrefix - <> foldl' (\sql (placeholder, literal) -> T.replace placeholder literal sql) productionSql replacements - explainStatement :: Statement () ByteString - explainStatement = - unpreparable - explainedSql - E.noParams - (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right)))) - result <- Pool.use (store ^. #pool) (Session.statement () explainStatement) - bytes <- case result of - Left err -> expectationFailure ("EXPLAIN failed: " <> show err) >> fail "unreachable" - Right value -> pure value - case Aeson.eitherDecodeStrict' bytes of - Left err -> expectationFailure ("could not decode EXPLAIN JSON: " <> err) >> fail "unreachable" - Right value -> pure value - -data PlanFacts = PlanFacts - { nodeTypes :: [Text] - , indexNames :: [Text] - } - deriving stock (Show) - -instance Semigroup PlanFacts where - PlanFacts nodeTypesA indexNamesA <> PlanFacts nodeTypesB indexNamesB = - PlanFacts (nodeTypesA <> nodeTypesB) (indexNamesA <> indexNamesB) - -instance Monoid PlanFacts where - mempty = PlanFacts [] [] - -collectPlanFacts :: Value -> PlanFacts -collectPlanFacts (Object object) = - PlanFacts - { nodeTypes = maybe [] pure (textField "Node Type" object) - , indexNames = maybe [] pure (textField "Index Name" object) - } - <> foldMap collectPlanFacts (KeyMap.elems object) -collectPlanFacts (Array values) = foldMap collectPlanFacts values -collectPlanFacts _ = mempty - -textField :: Aeson.Key -> Aeson.Object -> Maybe Text -textField key object = case KeyMap.lookup key object of - Just (String value) -> Just value - _ -> Nothing - -expectIndex :: Text -> Value -> Expectation -expectIndex expected plan = do - let facts = collectPlanFacts plan - unless (expected `elem` indexNames facts) $ - expectationFailure $ - "expected plan to use index " - <> T.unpack expected - <> ", but collected " - <> show facts - <> " from:\n" - <> show plan - -expectNoNodeType :: Text -> Value -> Expectation -expectNoNodeType forbidden plan = do - let facts = collectPlanFacts plan - unless (forbidden `notElem` nodeTypes facts) $ - expectationFailure $ - "expected plan not to contain node type " - <> T.unpack forbidden - <> ", but collected " - <> show facts - <> " from:\n" - <> show plan - -activeLeaseLookupStmt :: Statement () () -activeLeaseLookupStmt = - Statement.preparable - """ - SELECT count(*), min(expires_at) - FROM history_retention_leases - WHERE released_at IS NULL - AND expires_at > clock_timestamp() - HAVING count(*) > 0 - """ - E.noParams - D.noResult - -retentionTriggerShapeStmt :: Statement () (Int64, Int64) -retentionTriggerShapeStmt = - Statement.preparable - """ - SELECT count(*), - count(*) FILTER (WHERE (trigger.tgtype & 4) <> 0 OR (trigger.tgtype & 16) <> 0) - FROM pg_catalog.pg_trigger AS trigger - JOIN pg_catalog.pg_class AS relation ON relation.oid = trigger.tgrelid - JOIN pg_catalog.pg_namespace AS namespace ON namespace.oid = relation.relnamespace - WHERE namespace.nspname = 'kiroku' - AND relation.relname IN ('events', 'stream_events', 'streams') - AND trigger.tgname IN ('protect_replay_history_delete', 'protect_replay_history_truncate') - AND NOT trigger.tgisinternal - """ - E.noParams - ( D.singleRow - ( (,) - <$> D.column (D.nonNullable D.int8) - <*> D.column (D.nonNullable D.int8) - ) - ) - -streamHeadQuerySpec :: Spec -streamHeadQuerySpec = describe "stream head query work" $ - aroundAll withStreamHeadStore $ - forM_ ["bench-1", "long-1", "empty-1", "missing-1"] $ \name -> - it ("bounds literal and warmed prepared probes for " <> T.unpack name) $ \store -> do - let literal = "'" <> name <> "'" - prefix = "EXPLAIN (ANALYZE, BUFFERS, TIMING OFF, FORMAT JSON) " - direct <- explainWith prefix store SQL.getStreamWithHeadStmt [("$1", literal)] - prepared <- explainStreamHeadPrepared store literal - forM_ [("literal", direct), ("prepared", prepared)] $ \(kind, plan) -> do - -- Emit complete JSON into retained test logs, including buffers and loops. - putStrLn ("STREAM_HEAD_PLAN " <> T.unpack name <> " " <> kind <> " " <> show (Aeson.encode plan)) - expectIndex "ix_stream_events_all_by_origin" plan - expectNoNodeType "Sort" plan - let nodes = planObjects plan - probes = filter ((== Just "stream_events") . textField "Relation Name") nodes - limits = filter ((== Just "Limit") . textField "Node Type") nodes - length probes `shouldBe` 1 - length limits `shouldBe` 1 - forM_ probes $ \probe -> do - textField "Node Type" probe `shouldSatisfy` (`elem` [Just "Index Scan", Just "Index Only Scan"]) - textField "Scan Direction" probe `shouldBe` Just "Backward" - planNumber "Actual Rows" probe `shouldSatisfy` (<= 1) - if name == "missing-1" then planNumber "Actual Loops" probe `shouldBe` 0 else pure () - forM_ limits $ \limit -> do - expectIndex "ix_stream_events_all_by_origin" (Object limit) - planNumber "Actual Rows" limit `shouldSatisfy` (<= 1) - map (textField "Relation Name") nodes `shouldNotContain` [Just "events"] - case plan of - Array entries - | Object entry : _ <- foldr (:) [] entries - , Just (Object top) <- KeyMap.lookup "Plan" entry -> do - planNumber "Shared Hit Blocks" top + planNumber "Shared Read Blocks" top `shouldSatisfy` (<= 32) - planNumber "Actual Rows" top `shouldBe` (if name == "missing-1" then 0 else 1) - _ -> expectationFailure (show plan) - actual <- runStoreIO store (getStreamWithHead (StreamName name)) - case name of - "missing-1" -> actual `shouldBe` Right Nothing - "empty-1" -> case actual of - Right (Just (_, headPosition)) -> headPosition `shouldBe` Nothing - _ -> expectationFailure (show actual) - _ -> case actual of - Right (Just (_, Just _)) -> pure () - _ -> expectationFailure (show actual) - -withStreamHeadStore :: (KirokuStore -> IO ()) -> IO () -withStreamHeadStore action = withTestStore $ \store -> do - forM_ [streamHeadFixtureSql, "VACUUM (ANALYZE) stream_events"] $ \command -> - Pool.use (store ^. #pool) (Session.script command) >>= either (fail . show) pure - action store - -explainStreamHeadPrepared :: KirokuStore -> Text -> IO Value -explainStreamHeadPrepared store literal = do - result <- Pool.use (store ^. #pool) $ do - Session.script ("PREPARE ep97_head(text) AS " <> Statement.toSql SQL.getStreamWithHeadStmt) - -- Default auto policy, past PostgreSQL's first five custom executions. - Session.script (T.replicate 6 ("EXECUTE ep97_head(" <> literal <> ");")) - bytes <- - Session.statement () $ - unpreparable - ("EXPLAIN (ANALYZE, BUFFERS, TIMING OFF, FORMAT JSON) EXECUTE ep97_head(" <> literal <> ")") - E.noParams - (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right)))) - Session.script "DEALLOCATE ep97_head" - pure bytes - bytes <- either (fail . show) pure result - either fail pure (Aeson.eitherDecodeStrict' bytes) - -planObjects :: Value -> [Aeson.Object] -planObjects (Object fields) = fields : concatMap planObjects (KeyMap.elems fields) -planObjects (Array values) = concatMap planObjects (foldr (:) [] values) -planObjects _ = [] - -planNumber :: Aeson.Key -> Aeson.Object -> Double -planNumber key fields = case KeyMap.lookup key fields of - Just (Number n) -> realToFrac n - _ -> 0 + noOpAppendSpec + queryPlanSpec + DeadLetterQueryPlans.spec + categoryReadCostSpec + streamHeadQuerySpec + +noOpAppendSpec :: Spec +noOpAppendSpec = + describe "no-op paths use no pooled connection" $ do + it "rejects invalid dead-letter page sizes before pool checkout" $ do + checkouts <- newIORef (0 :: Int) + withObservedStore checkouts $ \_ -> do + before <- readIORef checkouts + forM_ [0, -1, 1001] $ \n -> mkSubscriptionDeadLetterLimit n `shouldBe` Left (SubscriptionDeadLetterLimitOutOfRange n) + after <- readIORef checkouts + after - before `shouldBe` 0 + + it "rejects invalid batch and buffer sizes before pool checkout" $ do + checkouts <- newIORef (0 :: Int) + withObservedStore checkouts $ \_ -> do + before <- readIORef checkouts + mkBatchSize 0 `shouldBe` Left (InvalidBatchSize 0) + mkBatchSize (-1) `shouldBe` Left (InvalidBatchSize (-1)) + Buffer.mkStreamBufferSize 0 `shouldBe` Left (Buffer.InvalidStreamBufferSize 0) + after <- readIORef checkouts + after - before `shouldBe` 0 + + it "rejects invalid consumer-group values before pool checkout" $ do + checkouts <- newIORef (0 :: Int) + withObservedStore checkouts $ \_ -> do + before <- readIORef checkouts + mkConsumerGroupSize 0 `shouldBe` Left (InvalidConsumerGroup 0 0) + let Right n = mkConsumerGroupSize 2 + mkConsumerGroup 2 n `shouldBe` Left (InvalidConsumerGroup 2 2) + after <- readIORef checkouts + after - before `shouldBe` 0 + + it "refuses mismatched topology in exactly one initialization checkout with no handler" $ do + workerThread <- newIORef Nothing + checkouts <- newIORef (0 :: Int) + delivered <- newIORef False + let observe (ConnectionObservation _ InUseConnectionStatus) = do + thread <- myThreadId + selected <- readIORef workerThread + if selected == Just thread then modifyIORef' checkouts (+ 1) else pure () + observe _ = pure () + withTestStoreSettings (\settings -> settings {observationHandler = Just observe}) $ \store -> do + seeded <- Pool.use (store ^. #pool) (Session.statement ("topology-checkout", 0, 0, 2, "unbound", Nothing) SQL.saveCheckpointMemberStmt) + seeded `shouldBe` Right () + withLoadCheckpointHookForTest + ( \_ -> do + thread <- myThreadId + writeIORef workerThread (Just thread) + pure Nothing + ) + $ do + let cfg = + (defaultSubscriptionConfig (SubscriptionName "topology-checkout") AllStreams (\_ -> writeIORef delivered True >> pure Continue)) + { consumerGroup = Just (validConsumerGroup 0 3) + } + handle <- subscribe store cfg + waitWithTimeout 5_000_000 handle >>= \case + Right (Left exception) -> + (fromException exception :: Maybe ConsumerGroupSizeMismatch) `shouldSatisfy` maybe False (const True) + other -> expectationFailure ("expected mismatch, got " <> show other) + readIORef checkouts `shouldReturn` 1 + readIORef delivered `shouldReturn` False + + it "refuses mismatched target in exactly one initialization checkout with no handler" $ do + workerThread <- newIORef Nothing + checkouts <- newIORef (0 :: Int) + delivered <- newIORef False + let observe (ConnectionObservation _ InUseConnectionStatus) = do + thread <- myThreadId + selected <- readIORef workerThread + if selected == Just thread then modifyIORef' checkouts (+ 1) else pure () + observe _ = pure () + withTestStoreSettings (\settings -> settings {observationHandler = Just observe}) $ \store -> do + seeded <- Pool.use (store ^. #pool) (Session.statement ("target-checkout", 0, 0, 1, "all", Nothing) SQL.saveCheckpointMemberStmt) + seeded `shouldBe` Right () + withLoadCheckpointHookForTest + ( \_ -> do + thread <- myThreadId + writeIORef workerThread (Just thread) + pure Nothing + ) + $ do + let cfg = + (defaultSubscriptionConfig (SubscriptionName "target-checkout") (Category (CategoryName "other")) (\_ -> writeIORef delivered True >> pure Continue)) + + handle <- subscribe store cfg + waitWithTimeout 5_000_000 handle >>= \case + Right (Left exception) -> + (fromException exception :: Maybe SubscriptionTargetMismatch) `shouldSatisfy` maybe False (const True) + other -> expectationFailure ("expected mismatch, got " <> show other) + readIORef checkouts `shouldReturn` 1 + readIORef delivered `shouldReturn` False + + it "keeps ordinary checkpoint saves as one unconditional monotonic upsert" $ do + forM_ [Statement.toSql SQL.saveCheckpointMemberStmt, Statement.toSql SQL.saveAllCheckpointMemberStmt, Statement.toSql SQL.saveCategoryCheckpointMemberStmt] $ \statement -> do + let sql = T.toLower statement + T.count "insert into" sql `shouldBe` 1 + sql `shouldSatisfy` T.isInfixOf "greatest(subscriptions.last_seen, excluded.last_seen)" + sql `shouldNotSatisfy` T.isInfixOf "where" + sql `shouldNotSatisfy` T.isInfixOf "returning" + + it "rejects an empty appendToStream batch before pool checkout" $ do + checkouts <- newIORef (0 :: Int) + withObservedStore checkouts $ \store -> do + checkoutsBefore <- readIORef checkouts + result <- runStoreIO store $ appendToStream (StreamName "performance-empty-append") AnyVersion [] + checkoutsAfter <- readIORef checkouts + result `shouldBe` Left (EmptyAppendBatch (StreamName "performance-empty-append")) + checkoutsAfter - checkoutsBefore `shouldBe` 0 + + it "returns an empty appendMultiStream result before pool checkout" $ do + checkouts <- newIORef (0 :: Int) + withObservedStore checkouts $ \store -> do + checkoutsBefore <- readIORef checkouts + result <- runStoreIO store $ appendMultiStream [] + checkoutsAfter <- readIORef checkouts + result `shouldBe` Right [] + checkoutsAfter - checkoutsBefore `shouldBe` 0 + + it "rejects invalid retention requests before pool checkout" $ do + checkouts <- newIORef (0 :: Int) + withObservedStore checkouts $ \_store -> do + checkoutsBefore <- readIORef checkouts + mkHistoryRetentionLeaseOwner "" `shouldSatisfy` either (const True) (const False) + mkHistoryRetentionLeaseReason "" `shouldSatisfy` either (const True) (const False) + mkHistoryRetentionInventoryLimit 0 `shouldSatisfy` either (const True) (const False) + checkoutsAfter <- readIORef checkouts + checkoutsAfter - checkoutsBefore `shouldBe` 0 + + it "keeps every ordinary statement free of retention coordination" $ do + let ordinarySql = + [ Statement.toSql SQL.appendExpectedVersion, + Statement.toSql SQL.appendStreamExists, + Statement.toSql SQL.appendNoStream, + Statement.toSql SQL.appendAnyVersion, + Statement.toSql SQL.readStreamForwardStmt, + Statement.toSql SQL.readAllForwardStmt, + Statement.toSql SQL.softDeleteStreamStmt, + Statement.toSql SQL.undeleteStreamStmt, + Statement.toSql SQL.setStreamTruncateBeforeStmt + ] + forM_ ordinarySql $ \sql -> + T.toLower sql `shouldNotSatisfy` T.isInfixOf "history_retention" + +queryPlanSpec :: Spec +queryPlanSpec = + describe "production query plans" $ + aroundAll withQueryPlanStore $ do + it "visible global head lookup uses ux_stream_events_stream_version without Sort" $ \store -> do + plan <- + explainProductionStatement + store + SQL.visibleGlobalHeadPositionStmt + [] + expectIndex "ux_stream_events_stream_version" plan + expectNoNodeType "Sort" plan + + it "dead-letter reads use ix_dead_letters_subscription_position without Sort" $ \store -> do + plan <- + explainProductionStatement + store + SQL.readDeadLettersStmt + [ ("$2", "0::int4"), + ("$1", "'performance-read'::text") + ] + expectIndex "ix_dead_letters_subscription_position" plan + expectNoNodeType "Sort" plan + + it "orphan dead-letter cleanup uses ix_dead_letters_event_id" $ \store -> do + plan <- + explainProductionStatement + store + SQL.deleteDeadLettersForOrphanedEventsStmt + [("$1", "ARRAY['00000000-0000-0000-0000-000000000001'::uuid]::uuid[]")] + expectIndex "ix_dead_letters_event_id" plan + + it "active retention lookup uses ix_history_retention_leases_unreleased_expiry" $ \store -> do + plan <- explainProductionStatement store activeLeaseLookupStmt [] + expectIndex "ix_history_retention_leases_unreleased_expiry" plan + + it "installs no retention trigger for INSERT or UPDATE" $ \store -> do + result <- Pool.use (store ^. #pool) (Session.statement () retentionTriggerShapeStmt) + case result of + Left err -> expectationFailure ("could not inspect retention triggers: " <> show err) + Right shape -> shape `shouldBe` (6, 0) + +-- | BUG-2. A category read's cost must follow the rows it returns, not the +-- number of streams in the category. The store holds the category-scaling +-- fixture: @performance@ with 200 streams, @idle@ with 20,000 one-event streams, +-- and @noise@, head at 'categoryScalingHead'. +categoryReadCostSpec :: Spec +categoryReadCostSpec = + describe "category read cost" $ + aroundAll withCategoryScalingStore $ do + it "category high-cursor reads use ix_stream_events_all_by_category without Sort" $ \store -> do + plan <- + explainProductionStatement + store + SQL.readCategoryForwardStmt + [ ("$3", "100::int4"), + ("$2", "'performance'::text"), + ("$1", "15000::bigint") + ] + expectIndex "ix_stream_events_all_by_category" plan + expectNoNodeType "Sort" plan + + it "consumer-group category reads use ix_stream_events_all_by_category without Sort" $ \store -> do + plan <- + explainProductionStatement + store + SQL.readCategoryForwardConsumerGroupStmt + [ ("$5", "100::int4"), + ("$4", "2::int4"), + ("$3", "1::int4"), + ("$2", "'performance'::text"), + ("$1", "15000::bigint") + ] + expectIndex "ix_stream_events_all_by_category" plan + expectNoNodeType "Sort" plan + + it "category caught-up poll on 20000 idle streams reads at most 32 buffers" $ \store -> do + let cursor = T.pack (show categoryScalingHead) <> "::bigint" + plainAt = + [ ("$3", "100::int4"), + ("$2", "'idle'::text"), + ("$1", cursor) + ] + groupAt member = + [ ("$5", "100::int4"), + ("$4", "2::int4"), + ("$3", T.pack (show member) <> "::int4"), + ("$2", "'idle'::text"), + ("$1", cursor) + ] + groupMembers = [0, 1 :: Int] + + plainIdle <- explainAnalyzeBuffers store SQL.readCategoryForwardStmt plainAt + expectBufferBudget "plain caught-up poll" plainIdle + snd plainIdle `shouldBe` 0 + groupIdle <- mapM (explainAnalyzeBuffers store SQL.readCategoryForwardConsumerGroupStmt . groupAt) groupMembers + mapM_ (expectBufferBudget "group caught-up poll") groupIdle + map snd groupIdle `shouldBe` [0, 0] + + appended <- runStoreIO store $ appendToStream (StreamName "idle-1") AnyVersion [makeEvent "IdleWake" Null] + appended `shouldSatisfy` either (const False) (const True) + + plainOne <- explainAnalyzeBuffers store SQL.readCategoryForwardStmt plainAt + expectBufferBudget "plain poll after one append" plainOne + snd plainOne `shouldBe` 1 + groupOne <- mapM (explainAnalyzeBuffers store SQL.readCategoryForwardConsumerGroupStmt . groupAt) groupMembers + mapM_ (expectBufferBudget "group poll after one append") groupOne + -- Exactly one member owns idle-1. + sum (map snd groupOne) `shouldBe` 1 + +withCategoryScalingStore :: (KirokuStore -> IO ()) -> IO () +withCategoryScalingStore action = + withTestStore $ \store -> do + result <- Pool.use (store ^. #pool) (Session.script categoryScalingFixtureSql) + case result of + Left err -> expectationFailure ("failed to seed category-scaling fixture: " <> show err) + Right () -> action store + +-- | The G1 budget: a category poll that returns at most one row. +expectBufferBudget :: String -> (Int64, Int64) -> Expectation +expectBufferBudget label (buffers, _) = + unless (buffers <= 32) $ + expectationFailure $ + label + <> ": expected at most 32 shared buffers, but the plan read " + <> show buffers + +-- | Execute a production statement under @EXPLAIN (ANALYZE, BUFFERS)@ and +-- return the top plan node's shared buffers (hit plus read) and actual rows. +-- Planning buffers are excluded; they are not paid by a prepared statement. +explainAnalyzeBuffers :: + KirokuStore -> + Statement params result -> + [(Text, Text)] -> + IO (Int64, Int64) +explainAnalyzeBuffers store productionStatement replacements = do + plan <- + explainWith + "EXPLAIN (ANALYZE, BUFFERS, COSTS OFF, TIMING OFF, FORMAT JSON)\n" + store + productionStatement + replacements + case plan of + Array entries + | Just (Object entry) <- headMay entries, + Just (Object top) <- KeyMap.lookup "Plan" entry -> + pure + ( numberField "Shared Hit Blocks" top + numberField "Shared Read Blocks" top, + numberField "Actual Rows" top + ) + _ -> expectationFailure ("unexpected EXPLAIN shape: " <> show plan) >> fail "unreachable" + where + headMay values = case foldr (:) [] values of + value : _ -> Just value + [] -> Nothing + numberField key object = case KeyMap.lookup key object of + Just value | Aeson.Success (number :: Double) <- Aeson.fromJSON value -> round number + _ -> 0 + +withObservedStore :: IORef Int -> (KirokuStore -> IO ()) -> IO () +withObservedStore checkouts = + withTestStoreSettings $ \settings -> + settings + { observationHandler = + Just $ \case + ConnectionObservation _ InUseConnectionStatus -> modifyIORef' checkouts (+ 1) + _ -> pure () + } + +withQueryPlanStore :: (KirokuStore -> IO ()) -> IO () +withQueryPlanStore action = + withTestStore $ \store -> do + result <- Pool.use (store ^. #pool) (Session.script queryPlanFixture) + case result of + Left err -> expectationFailure ("failed to seed performance query-plan fixture: " <> show err) + Right () -> action store + +queryPlanFixture :: Text +queryPlanFixture = + """ + BEGIN; + + WITH new_streams AS ( + INSERT INTO streams (stream_name, stream_version) + SELECT 'performance-' || n::text, 100 + FROM generate_series(1, 200) AS n + RETURNING stream_id + ), fixture_events AS MATERIALIZED ( + SELECT uuidv7() AS event_id, + s.stream_id, + per_stream_position::bigint AS stream_version, + row_number() OVER (ORDER BY per_stream_position, s.stream_id)::bigint AS global_position + FROM new_streams AS s + CROSS JOIN generate_series(1, 100) AS per_stream_position + ), inserted_events AS ( + INSERT INTO events (event_id, event_type, data) + SELECT event_id, 'PerformanceFixture', '{}'::jsonb + FROM fixture_events + RETURNING event_id + ), source_links AS ( + INSERT INTO stream_events + (event_id, stream_id, stream_version, original_stream_id, original_stream_version) + SELECT fixture.event_id, + fixture.stream_id, + fixture.stream_version, + fixture.stream_id, + fixture.stream_version + FROM fixture_events AS fixture + JOIN inserted_events USING (event_id) + RETURNING event_id + ), all_links AS ( + INSERT INTO stream_events + (event_id, stream_id, stream_version, original_stream_id, original_stream_version, category) + SELECT fixture.event_id, + 0, + fixture.global_position, + fixture.stream_id, + fixture.stream_version, + 'performance' + FROM fixture_events AS fixture + JOIN inserted_events USING (event_id) + RETURNING event_id + ), advanced_all AS ( + UPDATE streams + SET stream_version = (SELECT max(global_position) FROM fixture_events) + WHERE stream_id = 0 + RETURNING stream_id + ), inserted_dead_letters AS ( + INSERT INTO dead_letters + (subscription_name, consumer_group_member, global_position, event_id, + reason, reason_summary, attempt_count) + SELECT CASE + WHEN fixture.global_position % 10 = 0 THEN 'performance-read' + ELSE 'performance-other-' || (fixture.global_position % 9)::text + END, + 0, + fixture.global_position, + fixture.event_id, + '{}'::jsonb, + 'performance fixture', + 1 + FROM fixture_events AS fixture + JOIN inserted_events USING (event_id) + RETURNING dead_letter_id + ) + SELECT (SELECT count(*) FROM source_links), + (SELECT count(*) FROM all_links), + (SELECT count(*) FROM advanced_all), + (SELECT count(*) FROM inserted_dead_letters); + + COMMIT; + ANALYZE streams; + ANALYZE events; + ANALYZE stream_events; + ANALYZE dead_letters; + INSERT INTO history_retention_leases + (owner, reason, protected_through, created_at, renewed_at, expires_at, released_at) + SELECT 'performance-owner', + 'performance-reason', + 0, + clock_timestamp() - interval '1 day', + clock_timestamp() - interval '1 day', + clock_timestamp() + interval '1 hour', + CASE WHEN n <= 9900 THEN clock_timestamp() ELSE NULL END + FROM generate_series(1, 10000) AS n; + ANALYZE history_retention_leases; + """ + +explainProductionStatement :: + KirokuStore -> + Statement params result -> + [(Text, Text)] -> + IO Value +explainProductionStatement = explainWith "EXPLAIN (FORMAT JSON, COSTS OFF)\n" + +explainWith :: + Text -> + KirokuStore -> + Statement params result -> + [(Text, Text)] -> + IO Value +explainWith explainPrefix store productionStatement replacements = do + let productionSql = Statement.toSql productionStatement + explainedSql = + explainPrefix + <> foldl' (\sql (placeholder, literal) -> T.replace placeholder literal sql) productionSql replacements + explainStatement :: Statement () ByteString + explainStatement = + unpreparable + explainedSql + E.noParams + (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right)))) + result <- Pool.use (store ^. #pool) (Session.statement () explainStatement) + bytes <- case result of + Left err -> expectationFailure ("EXPLAIN failed: " <> show err) >> fail "unreachable" + Right value -> pure value + case Aeson.eitherDecodeStrict' bytes of + Left err -> expectationFailure ("could not decode EXPLAIN JSON: " <> err) >> fail "unreachable" + Right value -> pure value + +data PlanFacts = PlanFacts + { nodeTypes :: [Text], + indexNames :: [Text] + } + deriving stock (Show) + +instance Semigroup PlanFacts where + PlanFacts nodeTypesA indexNamesA <> PlanFacts nodeTypesB indexNamesB = + PlanFacts (nodeTypesA <> nodeTypesB) (indexNamesA <> indexNamesB) + +instance Monoid PlanFacts where + mempty = PlanFacts [] [] + +collectPlanFacts :: Value -> PlanFacts +collectPlanFacts (Object object) = + PlanFacts + { nodeTypes = maybe [] pure (textField "Node Type" object), + indexNames = maybe [] pure (textField "Index Name" object) + } + <> foldMap collectPlanFacts (KeyMap.elems object) +collectPlanFacts (Array values) = foldMap collectPlanFacts values +collectPlanFacts _ = mempty + +textField :: Aeson.Key -> Aeson.Object -> Maybe Text +textField key object = case KeyMap.lookup key object of + Just (String value) -> Just value + _ -> Nothing + +expectIndex :: Text -> Value -> Expectation +expectIndex expected plan = do + let facts = collectPlanFacts plan + unless (expected `elem` indexNames facts) $ + expectationFailure $ + "expected plan to use index " + <> T.unpack expected + <> ", but collected " + <> show facts + <> " from:\n" + <> show plan + +expectNoNodeType :: Text -> Value -> Expectation +expectNoNodeType forbidden plan = do + let facts = collectPlanFacts plan + unless (forbidden `notElem` nodeTypes facts) $ + expectationFailure $ + "expected plan not to contain node type " + <> T.unpack forbidden + <> ", but collected " + <> show facts + <> " from:\n" + <> show plan + +activeLeaseLookupStmt :: Statement () () +activeLeaseLookupStmt = + Statement.preparable + """ + SELECT count(*), min(expires_at) + FROM history_retention_leases + WHERE released_at IS NULL + AND expires_at > clock_timestamp() + HAVING count(*) > 0 + """ + E.noParams + D.noResult + +retentionTriggerShapeStmt :: Statement () (Int64, Int64) +retentionTriggerShapeStmt = + Statement.preparable + """ + SELECT count(*), + count(*) FILTER (WHERE (trigger.tgtype & 4) <> 0 OR (trigger.tgtype & 16) <> 0) + FROM pg_catalog.pg_trigger AS trigger + JOIN pg_catalog.pg_class AS relation ON relation.oid = trigger.tgrelid + JOIN pg_catalog.pg_namespace AS namespace ON namespace.oid = relation.relnamespace + WHERE namespace.nspname = 'kiroku' + AND relation.relname IN ('events', 'stream_events', 'streams') + AND trigger.tgname IN ('protect_replay_history_delete', 'protect_replay_history_truncate') + AND NOT trigger.tgisinternal + """ + E.noParams + ( D.singleRow + ( (,) + <$> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.int8) + ) + ) + +streamHeadQuerySpec :: Spec +streamHeadQuerySpec = describe "stream head query work" $ + aroundAll withStreamHeadStore $ + forM_ ["bench-1", "long-1", "empty-1", "missing-1"] $ \name -> + it ("bounds literal and warmed prepared probes for " <> T.unpack name) $ \store -> do + let literal = "'" <> name <> "'" + prefix = "EXPLAIN (ANALYZE, BUFFERS, TIMING OFF, FORMAT JSON) " + direct <- explainWith prefix store SQL.getStreamWithHeadStmt [("$1", literal)] + prepared <- explainStreamHeadPrepared store literal + forM_ [("literal", direct), ("prepared", prepared)] $ \(kind, plan) -> do + -- Emit complete JSON into retained test logs, including buffers and loops. + putStrLn ("STREAM_HEAD_PLAN " <> T.unpack name <> " " <> kind <> " " <> show (Aeson.encode plan)) + expectIndex "ix_stream_events_all_by_origin" plan + expectNoNodeType "Sort" plan + let nodes = planObjects plan + probes = filter ((== Just "stream_events") . textField "Relation Name") nodes + limits = filter ((== Just "Limit") . textField "Node Type") nodes + length probes `shouldBe` 1 + length limits `shouldBe` 1 + forM_ probes $ \probe -> do + textField "Node Type" probe `shouldSatisfy` (`elem` [Just "Index Scan", Just "Index Only Scan"]) + textField "Scan Direction" probe `shouldBe` Just "Backward" + planNumber "Actual Rows" probe `shouldSatisfy` (<= 1) + if name == "missing-1" then planNumber "Actual Loops" probe `shouldBe` 0 else pure () + forM_ limits $ \limit -> do + expectIndex "ix_stream_events_all_by_origin" (Object limit) + planNumber "Actual Rows" limit `shouldSatisfy` (<= 1) + map (textField "Relation Name") nodes `shouldNotContain` [Just "events"] + case plan of + Array entries + | Object entry : _ <- foldr (:) [] entries, + Just (Object top) <- KeyMap.lookup "Plan" entry -> do + planNumber "Shared Hit Blocks" top + planNumber "Shared Read Blocks" top `shouldSatisfy` (<= 32) + planNumber "Actual Rows" top `shouldBe` (if name == "missing-1" then 0 else 1) + _ -> expectationFailure (show plan) + actual <- runStoreIO store (getStreamWithHead (StreamName name)) + case name of + "missing-1" -> actual `shouldBe` Right Nothing + "empty-1" -> case actual of + Right (Just (_, headPosition)) -> headPosition `shouldBe` Nothing + _ -> expectationFailure (show actual) + _ -> case actual of + Right (Just (_, Just _)) -> pure () + _ -> expectationFailure (show actual) + +withStreamHeadStore :: (KirokuStore -> IO ()) -> IO () +withStreamHeadStore action = withTestStore $ \store -> do + forM_ [streamHeadFixtureSql, "VACUUM (ANALYZE) stream_events"] $ \command -> + Pool.use (store ^. #pool) (Session.script command) >>= either (fail . show) pure + action store + +explainStreamHeadPrepared :: KirokuStore -> Text -> IO Value +explainStreamHeadPrepared store literal = do + result <- Pool.use (store ^. #pool) $ do + Session.script ("PREPARE ep97_head(text) AS " <> Statement.toSql SQL.getStreamWithHeadStmt) + -- Default auto policy, past PostgreSQL's first five custom executions. + Session.script (T.replicate 6 ("EXECUTE ep97_head(" <> literal <> ");")) + bytes <- + Session.statement () $ + unpreparable + ("EXPLAIN (ANALYZE, BUFFERS, TIMING OFF, FORMAT JSON) EXECUTE ep97_head(" <> literal <> ")") + E.noParams + (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right)))) + Session.script "DEALLOCATE ep97_head" + pure bytes + bytes <- either (fail . show) pure result + either fail pure (Aeson.eitherDecodeStrict' bytes) + +planObjects :: Value -> [Aeson.Object] +planObjects (Object fields) = fields : concatMap planObjects (KeyMap.elems fields) +planObjects (Array values) = concatMap planObjects (foldr (:) [] values) +planObjects _ = [] + +planNumber :: Aeson.Key -> Aeson.Object -> Double +planNumber key fields = case KeyMap.lookup key fields of + Just (Number n) -> realToFrac n + _ -> 0 diff --git a/test/Test/Properties.hs b/test/Test/Properties.hs --- a/test/Test/Properties.hs +++ b/test/Test/Properties.hs @@ -1,21 +1,20 @@ -{- | 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. --} +-- | 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 ((^.)) @@ -39,188 +38,184 @@ -- | Operations the property generators can produce. data Op - = OpAppend !StreamName ![Text] - | OpAppendMulti ![(StreamName, [Text])] - | OpSoftDelete !StreamName - | OpUndelete !StreamName - | OpHardDelete !StreamName - deriving stock (Show) + = 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))) + -- 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]) + 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) - ] + 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). --} +-- | 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 + 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) + 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. --} +-- | 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)) + 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. --} +-- | 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 + 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 + -- 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 + -- 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 + 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) + 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) + 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" + 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/PublisherCallbackResilience.hs b/test/Test/PublisherCallbackResilience.hs --- a/test/Test/PublisherCallbackResilience.hs +++ b/test/Test/PublisherCallbackResilience.hs @@ -33,484 +33,550 @@ import Test.Hspec data CallbackBoom = CallbackBoom - deriving stock (Show) - deriving anyclass (Exception) + deriving stock (Show) + deriving anyclass (Exception) timeoutMicros :: Int timeoutMicros = 10_000_000 within :: String -> IO a -> IO a within label action = do - result <- Async.race (threadDelay timeoutMicros) action - case result of - Left () -> fail ("timed out waiting for " <> label) - Right a -> pure a + result <- Async.race (threadDelay timeoutMicros) action + case result of + Left () -> fail ("timed out waiting for " <> label) + Right a -> pure a failureOf :: RecordedEvent -> DecodeFailure failureOf event = DecodeFailure (event ^. #eventId) "cannot decrypt" poisonHook :: RecordedEvent -> IO (Either DecodeFailure RecordedEvent) poisonHook event = - pure $ - if event ^. #eventType == EventType "Boom" then Left (failureOf event) else Right event + pure $ + if event ^. #eventType == EventType "Boom" then Left (failureOf event) else Right event appendTypes :: KirokuStore -> Text -> [Text] -> IO () appendTypes store stream types = do - Right _ <- runStoreIO store $ appendToStream (StreamName stream) NoStream (map (\typ -> makeEvent typ (Aeson.object [])) types) - pure () + Right _ <- runStoreIO store $ appendToStream (StreamName stream) NoStream (map (\typ -> makeEvent typ (Aeson.object [])) types) + pure () expectCleanStop :: SubscriptionHandle -> IO () expectCleanStop handle = - within "clean subscription stop" (wait handle) >>= \case - Right () -> pure () - Left err -> expectationFailure ("expected clean stop, got " <> show err) + within "clean subscription stop" (wait handle) >>= \case + Right () -> pure () + Left err -> expectationFailure ("expected clean stop, got " <> show err) expectDecodeStop :: SubscriptionHandle -> IO DecodeFailure expectDecodeStop handle = - within "typed decode stop" (wait handle) >>= \case - Left err | Just (SubscriptionUndecodable failure) <- fromException err -> pure failure - other -> fail ("expected SubscriptionUndecodable, got " <> show other) + within "typed decode stop" (wait handle) >>= \case + Left err | Just (SubscriptionUndecodable failure) <- fromException err -> pure failure + other -> fail ("expected SubscriptionUndecodable, got " <> show other) readCheckpoint :: KirokuStore -> Text -> IO (Maybe Int64) readCheckpoint store name' = do - Right value <- Pool.use (store ^. #pool) (Session.statement (name', 0) SQL.getCheckpointMemberStmt) - pure value + Right value <- Pool.use (store ^. #pool) (Session.statement (name', 0) SQL.getCheckpointMemberStmt) + pure value readDeadLetters :: KirokuStore -> Text -> IO [SQL.DeadLetterRecord] readDeadLetters store name' = do - Right values <- Pool.use (store ^. #pool) (Session.statement (name', 0) SQL.readDeadLettersStmt) - pure (V.toList values) + Right values <- Pool.use (store ^. #pool) (Session.statement (name', 0) SQL.readDeadLettersStmt) + pure (V.toList values) awaitCheckpoint :: KirokuStore -> Text -> Int64 -> IO () awaitCheckpoint store name' expected = within "durable checkpoint" loop where loop = do - value <- readCheckpoint store name' - if value == Just expected then pure () else threadDelay 1_000 >> loop + value <- readCheckpoint store name' + if value == Just expected then pure () else threadDelay 1_000 >> loop spec :: Spec spec = describe "publisher callback resilience" $ do - it "stops only the default subscriber while a sibling dead-letters and continues live" $ do - defaultLive <- newEmptyMVar - siblingLive <- newEmptyMVar - siblingDone <- newEmptyMVar - attempts <- newIORef [] - defaultSeen <- newIORef ([] :: [EventType]) - siblingSeen <- newIORef ([] :: [EventType]) - publisherFailures <- newTVarIO (0 :: Int) - retryEvents <- newTVarIO (0 :: Int) - stopped <- newIORef Nothing - let defaultName = SubscriptionName "decode-default-live" - siblingName = SubscriptionName "decode-sibling-live" - hook event - | event ^. #eventType == EventType "Boom" = do - now <- getMonotonicTimeNSec - modifyIORef' attempts (now :) - pure (Left (failureOf event)) - | otherwise = pure (Right event) - observe event = do - caughtUpEventHandler defaultName defaultLive Nothing event - caughtUpEventHandler siblingName siblingLive Nothing event - case event of - KirokuEventPublisherDecodeFailed{} -> atomically $ modifyTVar' publisherFailures (+ 1) - KirokuEventSubscriptionRetrying name' _ _ _ | name' == defaultName -> atomically $ modifyTVar' retryEvents (+ 1) - KirokuEventSubscriptionStopped name' _ (StopUndecodable failure) _ | name' == defaultName -> modifyIORef' stopped (const (Just failure)) - _ -> pure () - tweak settings = - settings - & #storeSettings .~ defaultStoreSettings{decodeHook = Just hook} - & #eventHandler .~ Just observe - record ref event = modifyIORef' ref ((event ^. #eventType) :) >> pure Continue - siblingHandler event = do - result <- record siblingSeen event - when (event ^. #eventType == EventType "After") $ () <$ tryPutMVar siblingDone () - pure result - withTestStoreSettings tweak $ \store -> do - defaultHandle <- subscribe store ((defaultSubscriptionConfig defaultName AllStreams (record defaultSeen)){retryPolicy = RetryPolicy 3}) - sibling <- - subscribe - store - ( (defaultSubscriptionConfig siblingName AllStreams siblingHandler) - { undecodableHandler = Just (\_ failure -> pure (DeadLetter (DeadLetterDecodeFailure failure))) - } - ) - waitForSubscriptionLive defaultLive - waitForSubscriptionLive siblingLive - appendTypes store "decode-live" ["Before", "Boom", "After"] - failure <- expectDecodeStop defaultHandle - decodeFailureReason failure `shouldBe` "cannot decrypt" - readIORef stopped `shouldReturn` Just failure - atomically (readTVar retryEvents) `shouldReturn` 2 - within "healthy sibling delivery" (waitForSubscriptionLive siblingDone) - awaitCheckpoint store "decode-sibling-live" 3 - waitForPublisher store (GlobalPosition 3) - atomically (readTVar publisherFailures) `shouldReturn` 1 - reverse <$> readIORef defaultSeen `shouldReturn` [EventType "Before"] - reverse <$> readIORef siblingSeen `shouldReturn` [EventType "Before", EventType "After"] - readCheckpoint store "decode-default-live" >>= (`shouldSatisfy` maybe False (< 2)) - (map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-default-live") `shouldReturn` [] - letters <- readDeadLetters store "decode-sibling-live" - map SQL.deadLetterGlobalPosition letters `shouldBe` [2] - map SQL.deadLetterReasonSummary letters `shouldBe` ["decode failure: cannot decrypt"] - map SQL.deadLetterReason letters `shouldBe` [Aeson.object ["kind" .= ("decode_failure" :: Text), "event_id" .= (case decodeFailureEventId failure of EventId eid -> show eid), "detail" .= ("cannot decrypt" :: Text)]] - times <- reverse <$> readIORef attempts - length times `shouldBe` 3 - zipWith (-) (drop 1 times) times `shouldSatisfy` all (>= 900_000_000) - currentState sibling >>= \case - Just Live{} -> pure () - other -> expectationFailure ("expected healthy sibling, got " <> show other) - currentState defaultHandle >>= (`shouldSatisfy` isNothing) - cancel sibling + it "stops only the default subscriber while a sibling dead-letters and continues live" $ do + defaultLive <- newEmptyMVar + siblingLive <- newEmptyMVar + siblingDone <- newEmptyMVar + attempts <- newIORef [] + defaultSeen <- newIORef ([] :: [EventType]) + siblingSeen <- newIORef ([] :: [EventType]) + publisherFailures <- newTVarIO (0 :: Int) + retryEvents <- newTVarIO (0 :: Int) + stopped <- newIORef Nothing + let defaultName = SubscriptionName "decode-default-live" + siblingName = SubscriptionName "decode-sibling-live" + hook event + | event ^. #eventType == EventType "Boom" = do + now <- getMonotonicTimeNSec + modifyIORef' attempts (now :) + pure (Left (failureOf event)) + | otherwise = pure (Right event) + observe event = do + caughtUpEventHandler defaultName defaultLive Nothing event + caughtUpEventHandler siblingName siblingLive Nothing event + case event of + KirokuEventPublisherDecodeFailed {} -> atomically $ modifyTVar' publisherFailures (+ 1) + KirokuEventSubscriptionRetrying name' _ _ _ | name' == defaultName -> atomically $ modifyTVar' retryEvents (+ 1) + KirokuEventSubscriptionStopped name' _ (StopUndecodable failure) _ | name' == defaultName -> modifyIORef' stopped (const (Just failure)) + _ -> pure () + tweak settings = + settings + & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook} + & #eventHandler .~ Just observe + record ref event = modifyIORef' ref ((event ^. #eventType) :) >> pure Continue + siblingHandler event = do + result <- record siblingSeen event + when (event ^. #eventType == EventType "After") $ () <$ tryPutMVar siblingDone () + pure result + withTestStoreSettings tweak $ \store -> do + defaultHandle <- subscribe store ((defaultSubscriptionConfig defaultName AllStreams (record defaultSeen)) {retryPolicy = RetryPolicy 3}) + sibling <- + subscribe + store + ( (defaultSubscriptionConfig siblingName AllStreams siblingHandler) + { undecodableHandler = Just (\_ failure -> pure (DeadLetter (DeadLetterDecodeFailure failure))) + } + ) + waitForSubscriptionLive defaultLive + waitForSubscriptionLive siblingLive + appendTypes store "decode-live" ["Before", "Boom", "After"] + failure <- expectDecodeStop defaultHandle + decodeFailureReason failure `shouldBe` "cannot decrypt" + readIORef stopped `shouldReturn` Just failure + atomically (readTVar retryEvents) `shouldReturn` 2 + within "healthy sibling delivery" (waitForSubscriptionLive siblingDone) + awaitCheckpoint store "decode-sibling-live" 3 + waitForPublisher store (GlobalPosition 3) + atomically (readTVar publisherFailures) `shouldReturn` 1 + reverse <$> readIORef defaultSeen `shouldReturn` [EventType "Before"] + reverse <$> readIORef siblingSeen `shouldReturn` [EventType "Before", EventType "After"] + readCheckpoint store "decode-default-live" >>= (`shouldSatisfy` maybe False (< 2)) + (map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-default-live") `shouldReturn` [] + letters <- readDeadLetters store "decode-sibling-live" + map SQL.deadLetterGlobalPosition letters `shouldBe` [2] + map SQL.deadLetterReasonSummary letters `shouldBe` ["decode failure: cannot decrypt"] + map SQL.deadLetterReason letters `shouldBe` [Aeson.object ["kind" .= ("decode_failure" :: Text), "event_id" .= (case decodeFailureEventId failure of EventId eid -> show eid), "detail" .= ("cannot decrypt" :: Text)]] + times <- reverse <$> readIORef attempts + length times `shouldBe` 3 + zipWith (-) (drop 1 times) times `shouldSatisfy` all (>= 900_000_000) + currentState sibling >>= \case + Just Live {} -> pure () + other -> expectationFailure ("expected healthy sibling, got " <> show other) + currentState defaultHandle >>= (`shouldSatisfy` isNothing) + cancel sibling - it "shares successful live decoding across subscribers" $ do - firstLive <- newEmptyMVar - secondLive <- newEmptyMVar - calls <- newIORef (0 :: Int) - let firstName = SubscriptionName "decode-fanout-first" - secondName = SubscriptionName "decode-fanout-second" - hook event = modifyIORef' calls (+ 1) >> pure (Right event) - observe event = do - caughtUpEventHandler firstName firstLive Nothing event - caughtUpEventHandler secondName secondLive Nothing event - tweak settings = - settings - & #storeSettings .~ defaultStoreSettings{decodeHook = Just hook} - & #eventHandler .~ Just observe - withTestStoreSettings tweak $ \store -> do - first <- subscribe store (defaultSubscriptionConfig firstName AllStreams (\_ -> pure Stop)) - second <- subscribe store (defaultSubscriptionConfig secondName AllStreams (\_ -> pure Stop)) - waitForSubscriptionLive firstLive - waitForSubscriptionLive secondLive - appendTypes store "decode-fanout" ["Good"] - expectCleanStop first - expectCleanStop second - readIORef calls `shouldReturn` 1 + it "shares successful live decoding across subscribers" $ do + firstLive <- newEmptyMVar + secondLive <- newEmptyMVar + calls <- newIORef (0 :: Int) + let firstName = SubscriptionName "decode-fanout-first" + secondName = SubscriptionName "decode-fanout-second" + hook event = modifyIORef' calls (+ 1) >> pure (Right event) + observe event = do + caughtUpEventHandler firstName firstLive Nothing event + caughtUpEventHandler secondName secondLive Nothing event + tweak settings = + settings + & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook} + & #eventHandler .~ Just observe + withTestStoreSettings tweak $ \store -> do + first <- subscribe store (defaultSubscriptionConfig firstName AllStreams (\_ -> pure Stop)) + second <- subscribe store (defaultSubscriptionConfig secondName AllStreams (\_ -> pure Stop)) + waitForSubscriptionLive firstLive + waitForSubscriptionLive secondLive + appendTypes store "decode-fanout" ["Good"] + expectCleanStop first + expectCleanStop second + readIORef calls `shouldReturn` 1 - forM_ [(Category (CategoryName "decode"), Nothing), (AllStreams, Just (validConsumerGroup 0 1))] $ \(target', group) -> - it ("handles an undecodable event after confirmed DB-driven live transition for " <> show (target', group)) $ do - caughtUp <- newEmptyMVar - seen <- newIORef ([] :: [EventType]) - let subName = SubscriptionName "decode-db-live" - tweak settings = - settings - & #storeSettings .~ defaultStoreSettings{decodeHook = Just poisonHook} - & #eventHandler .~ Just (caughtUpEventHandler subName caughtUp Nothing) - handler event = modifyIORef' seen ((event ^. #eventType) :) >> pure Stop - withTestStoreSettings tweak $ \store -> do - handle <- - subscribe - store - ( (defaultSubscriptionConfig subName target' handler) - { consumerGroup = group - , undecodableHandler = Just (\_ failure -> pure (DeadLetter (DeadLetterDecodeFailure failure))) - } - ) - waitForSubscriptionLive caughtUp - appendTypes store "decode-db-live" ["Boom", "After"] - expectCleanStop handle - readIORef seen `shouldReturn` [EventType "After"] - readCheckpoint store "decode-db-live" `shouldReturn` Just 2 - map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-db-live" `shouldReturn` [1] + forM_ [(Category (CategoryName "decode"), Nothing), (AllStreams, Just (validConsumerGroup 0 1))] $ \(target', group) -> + it ("handles an undecodable event after confirmed DB-driven live transition for " <> show (target', group)) $ do + caughtUp <- newEmptyMVar + seen <- newIORef ([] :: [EventType]) + let subName = SubscriptionName "decode-db-live" + tweak settings = + settings + & #storeSettings .~ defaultStoreSettings {decodeHook = Just poisonHook} + & #eventHandler .~ Just (caughtUpEventHandler subName caughtUp Nothing) + handler event = modifyIORef' seen ((event ^. #eventType) :) >> pure Stop + withTestStoreSettings tweak $ \store -> do + handle <- + subscribe + store + ( (defaultSubscriptionConfig subName target' handler) + { consumerGroup = group, + undecodableHandler = Just (\_ failure -> pure (DeadLetter (DeadLetterDecodeFailure failure))) + } + ) + waitForSubscriptionLive caughtUp + appendTypes store "decode-db-live" ["Boom", "After"] + expectCleanStop handle + readIORef seen `shouldReturn` [EventType "After"] + readCheckpoint store "decode-db-live" `shouldReturn` Just 2 + map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-db-live" `shouldReturn` [1] - it "does not apply an undecodable disposition to an explicitly filtered-out event" $ do - let tweak settings = settings & #storeSettings .~ defaultStoreSettings{decodeHook = Just poisonHook} - withTestStoreSettings tweak $ \store -> do - appendTypes store "decode-filter" ["Boom", "After"] - waitForPublisher store (GlobalPosition 2) - handle <- - subscribe - store - ( ( defaultSubscriptionConfig - (SubscriptionName "decode-filter") - AllStreams - ( \event -> do - event ^. #eventType `shouldBe` EventType "After" - pure Stop - ) - ) - { eventTypeFilter = OnlyEventTypes (Set.singleton (EventType "After")) - , retryPolicy = RetryPolicy 1 - } - ) - expectCleanStop handle - readCheckpoint store "decode-filter" `shouldReturn` Just 2 - map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-filter" `shouldReturn` [] + it "does not apply an undecodable disposition to an explicitly filtered-out event" $ do + let tweak settings = settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just poisonHook} + withTestStoreSettings tweak $ \store -> do + appendTypes store "decode-filter" ["Boom", "After"] + waitForPublisher store (GlobalPosition 2) + handle <- + subscribe + store + ( ( defaultSubscriptionConfig + (SubscriptionName "decode-filter") + AllStreams + ( \event -> do + event ^. #eventType `shouldBe` EventType "After" + pure Stop + ) + ) + { eventTypeFilter = OnlyEventTypes (Set.singleton (EventType "After")), + retryPolicy = RetryPolicy 1 + } + ) + expectCleanStop handle + readCheckpoint store "decode-filter" `shouldReturn` Just 2 + map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-filter" `shouldReturn` [] - it "recovers a typed one-shot failure on the default retry without a callback" $ do - failedOnce <- newIORef False - caughtUp <- newEmptyMVar - seen <- newIORef ([] :: [EventType]) - let subName = SubscriptionName "decode-one-shot" - hook event - | event ^. #eventType == EventType "Boom" = do - already <- atomicModifyIORef' failedOnce (\old -> (True, old)) - pure (if already then Right event else Left (failureOf event)) - | otherwise = pure (Right event) - tweak settings = - settings - & #storeSettings .~ defaultStoreSettings{decodeHook = Just hook} - & #eventHandler .~ Just (caughtUpEventHandler subName caughtUp Nothing) - handler event = do - modifyIORef' seen ((event ^. #eventType) :) - pure (if event ^. #eventType == EventType "After" then Stop else Continue) - withTestStoreSettings tweak $ \store -> do - handle <- subscribe store (defaultSubscriptionConfig subName AllStreams handler) - waitForSubscriptionLive caughtUp - appendTypes store "decode-recovery" ["Boom", "After"] - expectCleanStop handle - reverse <$> readIORef seen `shouldReturn` [EventType "Boom", EventType "After"] - readCheckpoint store "decode-one-shot" `shouldReturn` Just 2 - (map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-one-shot") `shouldReturn` [] + forM_ [False, True] $ \fails -> + it ("filters undecodable type rewrites on the initial outcome, failure=" <> show fails) $ do + callbacks <- newIORef (0 :: Int) + seen <- newIORef [] + let v1 = EventType "OrderCreatedV1" + v2 = EventType "OrderCreatedV2" + hook event + | event ^. #eventType == v1 = pure (if fails then Left (failureOf event) else Right (event & #eventType .~ v2)) + | otherwise = pure (Right event) + tweak settings = settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook} + handler event = modifyIORef' seen ((event ^. #eventType) :) >> pure Stop + withTestStoreSettings tweak $ \store -> do + appendTypes store "decode-rewrite" ["OrderCreatedV1", "OrderCreatedV2"] + waitForPublisher store (GlobalPosition 2) + handle <- + subscribe + store + ( (defaultSubscriptionConfig (SubscriptionName "decode-rewrite") AllStreams handler) + { eventTypeFilter = OnlyEventTypes (Set.singleton v2), + undecodableHandler = Just (\_ _ -> modifyIORef' callbacks (+ 1) >> pure Stop) + } + ) + expectCleanStop handle + readIORef callbacks `shouldReturn` 0 + readIORef seen `shouldReturn` [v2] + readCheckpoint store "decode-rewrite" `shouldReturn` Just (if fails then 2 else 1) - forM_ [AllStreams, Category (CategoryName "decode")] $ \target' -> - forM_ [Nothing, Just (validConsumerGroup 0 1)] $ \group -> - it ("stops a persistent undecodable event during catch-up for " <> show (target', group)) $ do - let tweak settings = settings & #storeSettings .~ defaultStoreSettings{decodeHook = Just poisonHook} - handler _ = expectationFailure "undecodable event reached ordinary handler" >> pure Stop - withTestStoreSettings tweak $ \store -> do - appendTypes store "decode-catchup" ["Boom"] - waitForPublisher store (GlobalPosition 1) - handle <- - subscribe - store - ( (defaultSubscriptionConfig (SubscriptionName "decode-catchup") target' handler) - { consumerGroup = group - , retryPolicy = RetryPolicy 1 - } - ) - _ <- expectDecodeStop handle - readCheckpoint store "decode-catchup" `shouldReturn` Just 0 - (map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-catchup") `shouldReturn` [] + it "retains the undecodable raw filter decision when retry recovers to an excluded type" $ do + recover <- newIORef False + callbacks <- newIORef (0 :: Int) + seen <- newIORef [] + rawSeen <- newIORef [] + let v1 = EventType "OrderCreatedV1" + v2 = EventType "OrderCreatedV2" + hook event = do + enabled <- readIORef recover + pure (if enabled then Right (event & #eventType .~ v2) else Left (failureOf event)) + tweak settings = settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook} + callback raw _ = do + modifyIORef' callbacks (+ 1) + modifyIORef' rawSeen (raw :) + writeIORef recover True + pure (Retry (RetryDelay 0)) + handler event = modifyIORef' seen (event :) >> pure Stop + withTestStoreSettings tweak $ \store -> do + appendTypes store "decode-recovered-filter" ["OrderCreatedV1"] + waitForPublisher store (GlobalPosition 1) + withSubscription + store + ( (defaultSubscriptionConfig (SubscriptionName "decode-recovered-filter") AllStreams handler) + { eventTypeFilter = OnlyEventTypes (Set.singleton v1), + undecodableHandler = Just callback + } + ) + $ \handle -> do + expectCleanStop handle + readIORef callbacks `shouldReturn` 1 + delivered <- readIORef seen + raw <- readIORef rawSeen + map (\e -> e ^. #eventType) delivered `shouldBe` [v2] + map (\e -> e ^. #eventType) raw `shouldBe` [v1] + map (\e -> (e ^. #eventId, e ^. #globalPosition)) delivered + `shouldBe` map (\e -> (e ^. #eventId, e ^. #globalPosition)) raw + readCheckpoint store "decode-recovered-filter" `shouldReturn` Just 1 + map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-recovered-filter" `shouldReturn` [] - forM_ [Continue, Stop, Retry (RetryDelay 0)] $ \disposition -> - it ("honors an explicit undecodable disposition " <> show disposition) $ do - callbacks <- newIORef (0 :: Int) - seen <- newIORef ([] :: [EventType]) - let tweak settings = settings & #storeSettings .~ defaultStoreSettings{decodeHook = Just poisonHook} - handler event = modifyIORef' seen ((event ^. #eventType) :) >> pure Stop - callback _ _ = modifyIORef' callbacks (+ 1) >> pure disposition - withTestStoreSettings tweak $ \store -> do - appendTypes store "decode-disposition" ["Boom", "After"] - waitForPublisher store (GlobalPosition 2) - handle <- - subscribe - store - ( (defaultSubscriptionConfig (SubscriptionName "decode-disposition") AllStreams handler) - { undecodableHandler = Just callback - , retryPolicy = RetryPolicy 3 - } - ) - expectCleanStop handle - case disposition of - Stop -> do - readIORef seen `shouldReturn` [] - readCheckpoint store "decode-disposition" `shouldReturn` Just 1 - (map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-disposition") `shouldReturn` [] - Retry _ -> do - readIORef callbacks `shouldReturn` 3 - letters <- readDeadLetters store "decode-disposition" - map SQL.deadLetterReasonSummary letters `shouldBe` ["max retry attempts exceeded (3)"] - readCheckpoint store "decode-disposition" `shouldReturn` Just 2 - _ -> do - readIORef callbacks `shouldReturn` 1 - readIORef seen `shouldReturn` [EventType "After"] - (map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-disposition") `shouldReturn` [] + it "recovers a typed one-shot failure on the default retry without a callback" $ do + failedOnce <- newIORef False + caughtUp <- newEmptyMVar + seen <- newIORef ([] :: [EventType]) + let subName = SubscriptionName "decode-one-shot" + hook event + | event ^. #eventType == EventType "Boom" = do + already <- atomicModifyIORef' failedOnce (\old -> (True, old)) + pure (if already then Right event else Left (failureOf event)) + | otherwise = pure (Right event) + tweak settings = + settings + & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook} + & #eventHandler .~ Just (caughtUpEventHandler subName caughtUp Nothing) + handler event = do + modifyIORef' seen ((event ^. #eventType) :) + pure (if event ^. #eventType == EventType "After" then Stop else Continue) + withTestStoreSettings tweak $ \store -> do + handle <- subscribe store (defaultSubscriptionConfig subName AllStreams handler) + waitForSubscriptionLive caughtUp + appendTypes store "decode-recovery" ["Boom", "After"] + expectCleanStop handle + reverse <$> readIORef seen `shouldReturn` [EventType "Boom", EventType "After"] + readCheckpoint store "decode-one-shot" `shouldReturn` Just 2 + (map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-one-shot") `shouldReturn` [] - it "re-applies the hook on a callback Retry and then calls the ordinary handler" $ do - failedOnce <- newIORef False - callbacks <- newIORef (0 :: Int) - seen <- newIORef ([] :: [EventType]) - let hook event = do - already <- atomicModifyIORef' failedOnce (\old -> (True, old)) - pure (if already then Right event else Left (failureOf event)) - tweak settings = settings & #storeSettings .~ defaultStoreSettings{decodeHook = Just hook} - handler event = modifyIORef' seen ((event ^. #eventType) :) >> pure Stop + forM_ [AllStreams, Category (CategoryName "decode")] $ \target' -> + forM_ [Nothing, Just (validConsumerGroup 0 1)] $ \group -> + it ("stops a persistent undecodable event during catch-up for " <> show (target', group)) $ do + let tweak settings = settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just poisonHook} + handler _ = expectationFailure "undecodable event reached ordinary handler" >> pure Stop withTestStoreSettings tweak $ \store -> do - appendTypes store "decode-callback-retry" ["Boom"] - waitForPublisher store (GlobalPosition 1) - handle <- - subscribe - store - ( (defaultSubscriptionConfig (SubscriptionName "decode-callback-retry") AllStreams handler) - { undecodableHandler = Just (\_ _ -> modifyIORef' callbacks (+ 1) >> pure (Retry (RetryDelay 0))) - } - ) - expectCleanStop handle + appendTypes store "decode-catchup" ["Boom"] + waitForPublisher store (GlobalPosition 1) + handle <- + subscribe + store + ( (defaultSubscriptionConfig (SubscriptionName "decode-catchup") target' handler) + { consumerGroup = group, + retryPolicy = RetryPolicy 1 + } + ) + _ <- expectDecodeStop handle + readCheckpoint store "decode-catchup" `shouldReturn` Just 0 + (map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-catchup") `shouldReturn` [] + + forM_ [Continue, Stop, Retry (RetryDelay 0)] $ \disposition -> + it ("honors an explicit undecodable disposition " <> show disposition) $ do + callbacks <- newIORef (0 :: Int) + seen <- newIORef ([] :: [EventType]) + let tweak settings = settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just poisonHook} + handler event = modifyIORef' seen ((event ^. #eventType) :) >> pure Stop + callback _ _ = modifyIORef' callbacks (+ 1) >> pure disposition + withTestStoreSettings tweak $ \store -> do + appendTypes store "decode-disposition" ["Boom", "After"] + waitForPublisher store (GlobalPosition 2) + handle <- + subscribe + store + ( (defaultSubscriptionConfig (SubscriptionName "decode-disposition") AllStreams handler) + { undecodableHandler = Just callback, + retryPolicy = RetryPolicy 3 + } + ) + expectCleanStop handle + case disposition of + Stop -> do + readIORef seen `shouldReturn` [] + readCheckpoint store "decode-disposition" `shouldReturn` Just 1 + (map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-disposition") `shouldReturn` [] + Retry _ -> do + readIORef callbacks `shouldReturn` 3 + letters <- readDeadLetters store "decode-disposition" + map SQL.deadLetterReasonSummary letters `shouldBe` ["max retry attempts exceeded (3)"] + readCheckpoint store "decode-disposition" `shouldReturn` Just 2 + _ -> do readIORef callbacks `shouldReturn` 1 - readIORef seen `shouldReturn` [EventType "Boom"] + readIORef seen `shouldReturn` [EventType "After"] + (map SQL.deadLetterGlobalPosition <$> readDeadLetters store "decode-disposition") `shouldReturn` [] - it "fails reads with EventDecodeFailed instead of returning a partial vector" $ do - let tweak settings = settings & #storeSettings .~ defaultStoreSettings{decodeHook = Just poisonHook} - withTestStoreSettings tweak $ \store -> do - appendTypes store "decode-read" ["Before", "Boom", "After"] - forM_ - [ readAllForward (GlobalPosition 0) 10 - , readAllBackward (GlobalPosition 10) 10 - , readStreamForward (StreamName "decode-read") (StreamVersion 0) 10 - , readStreamBackward (StreamName "decode-read") (StreamVersion 10) 10 - , readCategory (CategoryName "decode") (GlobalPosition 0) 10 - ] - $ \readEvents -> - runStoreIO store readEvents >>= \case - Left (EventDecodeFailed failure) -> decodeFailureReason failure `shouldBe` "cannot decrypt" - other -> expectationFailure ("expected typed read failure, got " <> show other) + it "re-applies the hook on a callback Retry and then calls the ordinary handler" $ do + failedOnce <- newIORef False + callbacks <- newIORef (0 :: Int) + seen <- newIORef ([] :: [EventType]) + let hook event = do + already <- atomicModifyIORef' failedOnce (\old -> (True, old)) + pure (if already then Right event else Left (failureOf event)) + tweak settings = settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook} + handler event = modifyIORef' seen ((event ^. #eventType) :) >> pure Stop + withTestStoreSettings tweak $ \store -> do + appendTypes store "decode-callback-retry" ["Boom"] + waitForPublisher store (GlobalPosition 1) + handle <- + subscribe + store + ( (defaultSubscriptionConfig (SubscriptionName "decode-callback-retry") AllStreams handler) + { undecodableHandler = Just (\_ _ -> modifyIORef' callbacks (+ 1) >> pure (Retry (RetryDelay 0))) + } + ) + expectCleanStop handle + readIORef callbacks `shouldReturn` 1 + readIORef seen `shouldReturn` [EventType "Boom"] - it "cancels promptly while waiting for the default decode retry" $ do - retrying <- newEmptyMVar - let subName = SubscriptionName "decode-cancel" - observe event = case event of - KirokuEventSubscriptionRetrying{} -> () <$ tryPutMVar retrying () - _ -> pure () - tweak settings = - settings - & #storeSettings .~ defaultStoreSettings{decodeHook = Just poisonHook} - & #eventHandler .~ Just observe - withTestStoreSettings tweak $ \store -> do - appendTypes store "decode-cancel" ["Boom"] - waitForPublisher store (GlobalPosition 1) - handle <- subscribe store (defaultSubscriptionConfig subName AllStreams (\_ -> pure Continue)) - waitForSubscriptionLive retrying - startedAt <- getMonotonicTimeNSec - cancel handle - finishedAt <- getMonotonicTimeNSec - finishedAt - startedAt `shouldSatisfy` (< 500_000_000) - currentState handle >>= (`shouldSatisfy` isNothing) - readCheckpoint store "decode-cancel" `shouldReturn` Just 0 + it "fails reads with EventDecodeFailed instead of returning a partial vector" $ do + let tweak settings = settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just poisonHook} + withTestStoreSettings tweak $ \store -> do + appendTypes store "decode-read" ["Before", "Boom", "After"] + forM_ + [ readAllForward (GlobalPosition 0) 10, + readAllBackward (GlobalPosition 10) 10, + readStreamForward (StreamName "decode-read") (StreamVersion 0) 10, + readStreamBackward (StreamName "decode-read") (StreamVersion 10) 10, + readCategory (CategoryName "decode") (GlobalPosition 0) 10 + ] + $ \readEvents -> + runStoreIO store readEvents >>= \case + Left (EventDecodeFailed failure) -> decodeFailureReason failure `shouldBe` "cannot decrypt" + other -> expectationFailure ("expected typed read failure, got " <> show other) - it "replays the failed event from its durable checkpoint after the hook is fixed" $ do - repaired <- newIORef False - seen <- newIORef ([] :: [EventType]) - let subName = SubscriptionName "decode-restart" - hook event = do - healthy <- readIORef repaired - pure (if healthy then Right event else Left (failureOf event)) - tweak settings = settings & #storeSettings .~ defaultStoreSettings{decodeHook = Just hook} - handler event = modifyIORef' seen ((event ^. #eventType) :) >> pure Stop - withTestStoreSettings tweak $ \store -> do - appendTypes store "decode-restart" ["Boom"] - waitForPublisher store (GlobalPosition 1) - failed <- subscribe store ((defaultSubscriptionConfig subName AllStreams handler){retryPolicy = RetryPolicy 1}) - _ <- expectDecodeStop failed - readCheckpoint store "decode-restart" `shouldReturn` Just 0 - writeIORef repaired True - recovered <- subscribe store (defaultSubscriptionConfig subName AllStreams handler) - expectCleanStop recovered - readIORef seen `shouldReturn` [EventType "Boom"] - readCheckpoint store "decode-restart" `shouldReturn` Just 1 + it "cancels promptly while waiting for the default decode retry" $ do + retrying <- newEmptyMVar + let subName = SubscriptionName "decode-cancel" + observe event = case event of + KirokuEventSubscriptionRetrying {} -> () <$ tryPutMVar retrying () + _ -> pure () + tweak settings = + settings + & #storeSettings .~ defaultStoreSettings {decodeHook = Just poisonHook} + & #eventHandler .~ Just observe + withTestStoreSettings tweak $ \store -> do + appendTypes store "decode-cancel" ["Boom"] + waitForPublisher store (GlobalPosition 1) + handle <- subscribe store (defaultSubscriptionConfig subName AllStreams (\_ -> pure Continue)) + waitForSubscriptionLive retrying + startedAt <- getMonotonicTimeNSec + cancel handle + finishedAt <- getMonotonicTimeNSec + finishedAt - startedAt `shouldSatisfy` (< 500_000_000) + currentState handle >>= (`shouldSatisfy` isNothing) + readCheckpoint store "decode-cancel" `shouldReturn` Just 0 - it "releases a bracketed subscriber during a pending default decode retry" $ do - retrying <- newEmptyMVar - let observe event = case event of - KirokuEventSubscriptionRetrying{} -> () <$ tryPutMVar retrying () - _ -> pure () - tweak settings = - settings - & #storeSettings .~ defaultStoreSettings{decodeHook = Just poisonHook} - & #eventHandler .~ Just observe - within "bracketed store/subscription shutdown" $ withTestStoreSettings tweak $ \store -> do - appendTypes store "decode-shutdown" ["Boom"] - waitForPublisher store (GlobalPosition 1) - handle <- - withSubscription - store - ((defaultSubscriptionConfig (SubscriptionName "decode-shutdown") AllStreams (\_ -> pure Continue)){retryPolicy = RetryPolicy 100}) - (\h -> waitForSubscriptionLive retrying >> pure h) - currentState handle >>= (`shouldSatisfy` isNothing) - within "cancelled worker completion" (wait handle) >>= \case - Left err | Just Async.AsyncCancelled <- fromException err -> pure () - other -> expectationFailure ("expected bracket cancellation, got " <> show other) + it "replays the failed event from its durable checkpoint after the hook is fixed" $ do + repaired <- newIORef False + seen <- newIORef ([] :: [EventType]) + let subName = SubscriptionName "decode-restart" + hook event = do + healthy <- readIORef repaired + pure (if healthy then Right event else Left (failureOf event)) + tweak settings = settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook} + handler event = modifyIORef' seen ((event ^. #eventType) :) >> pure Stop + withTestStoreSettings tweak $ \store -> do + appendTypes store "decode-restart" ["Boom"] + waitForPublisher store (GlobalPosition 1) + failed <- subscribe store ((defaultSubscriptionConfig subName AllStreams handler) {retryPolicy = RetryPolicy 1}) + _ <- expectDecodeStop failed + readCheckpoint store "decode-restart" `shouldReturn` Just 0 + writeIORef repaired True + recovered <- subscribe store (defaultSubscriptionConfig subName AllStreams handler) + expectCleanStop recovered + readIORef seen `shouldReturn` [EventType "Boom"] + readCheckpoint store "decode-restart" `shouldReturn` Just 1 - it "unlifts the undecodable callback in the same persistent effect environment as the handler" $ do - seen <- newIORef ([] :: [Int]) - let tweak settings = settings & #storeSettings .~ defaultStoreSettings{decodeHook = Just poisonHook} - withTestStoreSettings tweak $ \store -> do - appendTypes store "decode-effectful" ["Boom", "After"] - waitForPublisher store (GlobalPosition 2) - runEff $ SubEff.runSubscription store $ State.evalState (0 :: Int) $ do - let config = - ( defaultSubscriptionConfig - (SubscriptionName "decode-effectful") - AllStreams - ( \_ -> do - State.modify @Int (+ 1) - count <- State.get @Int - liftIO (modifyIORef' seen (count :)) - pure Stop - ) - ) - { undecodableHandler = Just (\_ _ -> State.modify @Int (+ 1) >> pure Continue) - } - handle <- SubEff.subscribe config - liftIO (expectCleanStop handle) - readIORef seen `shouldReturn` [2] + it "releases a bracketed subscriber during a pending default decode retry" $ do + retrying <- newEmptyMVar + let observe event = case event of + KirokuEventSubscriptionRetrying {} -> () <$ tryPutMVar retrying () + _ -> pure () + tweak settings = + settings + & #storeSettings .~ defaultStoreSettings {decodeHook = Just poisonHook} + & #eventHandler .~ Just observe + within "bracketed store/subscription shutdown" $ withTestStoreSettings tweak $ \store -> do + appendTypes store "decode-shutdown" ["Boom"] + waitForPublisher store (GlobalPosition 1) + handle <- + withSubscription + store + ((defaultSubscriptionConfig (SubscriptionName "decode-shutdown") AllStreams (\_ -> pure Continue)) {retryPolicy = RetryPolicy 100}) + (\h -> waitForSubscriptionLive retrying >> pure h) + currentState handle >>= (`shouldSatisfy` isNothing) + within "cancelled worker completion" (wait handle) >>= \case + Left err | Just Async.AsyncCancelled <- fromException err -> pure () + other -> expectationFailure ("expected bracket cancellation, got " <> show other) - it "keeps the publisher alive when decodeHook throws once" $ do - failedOnce <- newIORef False - loopErrorSeen <- newEmptyMVar - caughtUp <- newEmptyMVar - delivered <- newIORef ([] :: [EventType]) - deliveredCount <- newTVarIO (0 :: Int) + it "unlifts the undecodable callback in the same persistent effect environment as the handler" $ do + seen <- newIORef ([] :: [Int]) + let tweak settings = settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just poisonHook} + withTestStoreSettings tweak $ \store -> do + appendTypes store "decode-effectful" ["Boom", "After"] + waitForPublisher store (GlobalPosition 2) + runEff $ SubEff.runSubscription store $ State.evalState (0 :: Int) $ do + let config = + ( defaultSubscriptionConfig + (SubscriptionName "decode-effectful") + AllStreams + ( \_ -> do + State.modify @Int (+ 1) + count <- State.get @Int + liftIO (modifyIORef' seen (count :)) + pure Stop + ) + ) + { undecodableHandler = Just (\_ _ -> State.modify @Int (+ 1) >> pure Continue) + } + handle <- SubEff.subscribe config + liftIO (expectCleanStop handle) + readIORef seen `shouldReturn` [2] - let subName = SubscriptionName "publisher-decode-hook-resilience" - decodeOnce event - | event ^. #eventType == EventType "Boom" = do - alreadyFailed <- atomicModifyIORef' failedOnce (\old -> (True, old)) - if alreadyFailed - then pure (Right event) - else throwIO CallbackBoom - | otherwise = pure (Right event) - observe evt = do - case evt of - KirokuEventPublisherLoopError{} -> () <$ tryPutMVar loopErrorSeen () - _ -> pure () - caughtUpEventHandler subName caughtUp Nothing evt - tweak settings = - settings - & #storeSettings .~ defaultStoreSettings{decodeHook = Just decodeOnce} - & #eventHandler .~ Just observe - handler event = do - modifyIORef' delivered ((event ^. #eventType) :) - atomically $ do - n <- readTVar deliveredCount - let n' = n + 1 - writeTVar deliveredCount n' - pure $ if n' >= 2 then Stop else Continue + it "keeps the publisher alive when decodeHook throws once" $ do + failedOnce <- newIORef False + loopErrorSeen <- newEmptyMVar + caughtUp <- newEmptyMVar + delivered <- newIORef ([] :: [EventType]) + deliveredCount <- newTVarIO (0 :: Int) - withTestStoreSettings tweak $ \store -> do - handle <- subscribe store (defaultSubscriptionConfig subName AllStreams handler) - waitForSubscriptionLive caughtUp - Right _ <- runStoreIO store $ appendToStream (StreamName "publisher-decode-boom") NoStream [makeEvent "Boom" (Aeson.object [])] - within "publisher loop error event" (waitForSubscriptionLive loopErrorSeen) - Right _ <- runStoreIO store $ appendToStream (StreamName "publisher-decode-ok") NoStream [makeEvent "Ok" (Aeson.object [])] - result <- waitWithTimeout timeoutMicros handle - case result of - Right (Right ()) -> pure () - Left timeout -> expectationFailure timeout - Right (Left e) -> expectationFailure ("expected clean stop, got: " <> show e) + let subName = SubscriptionName "publisher-decode-hook-resilience" + decodeOnce event + | event ^. #eventType == EventType "Boom" = do + alreadyFailed <- atomicModifyIORef' failedOnce (\old -> (True, old)) + if alreadyFailed + then pure (Right event) + else throwIO CallbackBoom + | otherwise = pure (Right event) + observe evt = do + case evt of + KirokuEventPublisherLoopError {} -> () <$ tryPutMVar loopErrorSeen () + _ -> pure () + caughtUpEventHandler subName caughtUp Nothing evt + tweak settings = + settings + & #storeSettings .~ defaultStoreSettings {decodeHook = Just decodeOnce} + & #eventHandler .~ Just observe + handler event = do + modifyIORef' delivered ((event ^. #eventType) :) + atomically $ do + n <- readTVar deliveredCount + let n' = n + 1 + writeTVar deliveredCount n' + pure $ if n' >= 2 then Stop else Continue - seen <- reverse <$> readIORef delivered - seen `shouldBe` [EventType "Boom", EventType "Ok"] + withTestStoreSettings tweak $ \store -> do + handle <- subscribe store (defaultSubscriptionConfig subName AllStreams handler) + waitForSubscriptionLive caughtUp + Right _ <- runStoreIO store $ appendToStream (StreamName "publisher-decode-boom") NoStream [makeEvent "Boom" (Aeson.object [])] + within "publisher loop error event" (waitForSubscriptionLive loopErrorSeen) + Right _ <- runStoreIO store $ appendToStream (StreamName "publisher-decode-ok") NoStream [makeEvent "Ok" (Aeson.object [])] + result <- waitWithTimeout timeoutMicros handle + case result of + Right (Right ()) -> pure () + Left timeout -> expectationFailure timeout + Right (Left e) -> expectationFailure ("expected clean stop, got: " <> show e) - it "drops throwing eventHandler exceptions without killing publisher or worker" $ do - deliveredCount <- newTVarIO (0 :: Int) - let tweak settings = settings & #eventHandler .~ Just (\_ -> throwIO CallbackBoom) - handler _ = do - atomically $ do - n <- readTVar deliveredCount - let n' = n + 1 - writeTVar deliveredCount n' - pure $ if n' >= 3 then Stop else Continue + seen <- reverse <$> readIORef delivered + seen `shouldBe` [EventType "Boom", EventType "Ok"] - withTestStoreSettings tweak $ \store -> do - handle <- subscribe store (defaultSubscriptionConfig (SubscriptionName "throwing-event-handler-resilience") AllStreams handler) - Right _ <- runStoreIO store $ appendToStream (StreamName "throwing-handler-1") NoStream [makeEvent "One" (Aeson.object [])] - Right _ <- runStoreIO store $ appendToStream (StreamName "throwing-handler-2") NoStream [makeEvent "Two" (Aeson.object [])] - Right _ <- runStoreIO store $ appendToStream (StreamName "throwing-handler-3") NoStream [makeEvent "Three" (Aeson.object [])] - result <- waitWithTimeout timeoutMicros handle - case result of - Right (Right ()) -> pure () - Left timeout -> expectationFailure timeout - Right (Left e) -> expectationFailure ("expected clean stop, got: " <> show e) + it "drops throwing eventHandler exceptions without killing publisher or worker" $ do + deliveredCount <- newTVarIO (0 :: Int) + let tweak settings = settings & #eventHandler .~ Just (\_ -> throwIO CallbackBoom) + handler _ = do + atomically $ do + n <- readTVar deliveredCount + let n' = n + 1 + writeTVar deliveredCount n' + pure $ if n' >= 3 then Stop else Continue - finalCount <- atomically (readTVar deliveredCount) - finalCount `shouldBe` 3 + withTestStoreSettings tweak $ \store -> do + handle <- subscribe store (defaultSubscriptionConfig (SubscriptionName "throwing-event-handler-resilience") AllStreams handler) + Right _ <- runStoreIO store $ appendToStream (StreamName "throwing-handler-1") NoStream [makeEvent "One" (Aeson.object [])] + Right _ <- runStoreIO store $ appendToStream (StreamName "throwing-handler-2") NoStream [makeEvent "Two" (Aeson.object [])] + Right _ <- runStoreIO store $ appendToStream (StreamName "throwing-handler-3") NoStream [makeEvent "Three" (Aeson.object [])] + result <- waitWithTimeout timeoutMicros handle + case result of + Right (Right ()) -> pure () + Left timeout -> expectationFailure timeout + Right (Left e) -> expectationFailure ("expected clean stop, got: " <> show e) + + finalCount <- atomically (readTVar deliveredCount) + finalCount `shouldBe` 3 diff --git a/test/Test/PublisherDropCounter.hs b/test/Test/PublisherDropCounter.hs --- a/test/Test/PublisherDropCounter.hs +++ b/test/Test/PublisherDropCounter.hs @@ -16,44 +16,44 @@ spec :: Spec spec = describe "publisher drop counter" $ do - it "counts drops, keeps the newest batch and preserves the idempotent wrapper" $ withTestStore $ \store -> do - baseline <- IntMap.size <$> readTVarIO (Pub.subscribers store.publisher) - bracket (atomically (Pub.subscribePublisherWith store.publisher 1 DropOldest)) Pub.unsubscribe $ \sub -> do - appendAndWait store "drop-a" 1 - readTVarIO sub.subscriptionDropped `shouldReturn` 0 - appendAndWait store "drop-b" 2 - readTVarIO sub.subscriptionDropped `shouldReturn` 1 - readTVarIO sub.subscriptionStatus `shouldReturn` Pub.Active - newest sub.subscriptionQueue `shouldReturn` [GlobalPosition 2] - bracket (atomically (Pub.subscribePublisher store.publisher 1 DropOldest)) (\(_, _, stop) -> stop) $ \(queue, _, stop) -> do - appendAndWait store "drop-c" 3 - appendAndWait store "drop-d" 4 - newest queue `shouldReturn` [GlobalPosition 4] - stop >> stop - Pub.unsubscribe sub >> Pub.unsubscribe sub - (IntMap.size <$> readTVarIO (Pub.subscribers store.publisher)) `shouldReturn` baseline - it "does not count PauseAndResume or DropSubscription overflow" $ withTestStore $ \store -> - mapM_ - ( \policy -> bracket (atomically (Pub.subscribePublisherWith store.publisher 1 policy)) Pub.unsubscribe $ \sub -> do - Right pos <- runStoreIO store (appendToStream (StreamName "policies-a") AnyVersion [makeEvent "E" (object [])]) - bounded (waitForPublisher store pos.globalPosition) - Right pos2 <- runStoreIO store (appendToStream (StreamName "policies-a") AnyVersion [makeEvent "E" (object [])]) - bounded (waitForPublisher store pos2.globalPosition) - readTVarIO sub.subscriptionDropped `shouldReturn` 0 - readTVarIO sub.subscriptionStatus `shouldReturn` (if policy == PauseAndResume then Pub.Paused else Pub.Overflowed) - ) - [PauseAndResume, DropSubscription] + it "counts drops, keeps the newest batch and preserves the idempotent wrapper" $ withTestStore $ \store -> do + baseline <- IntMap.size <$> readTVarIO (Pub.subscribers store.publisher) + bracket (atomically (Pub.subscribePublisherWith store.publisher 1 DropOldest)) Pub.unsubscribe $ \sub -> do + appendAndWait store "drop-a" 1 + readTVarIO sub.subscriptionDropped `shouldReturn` 0 + appendAndWait store "drop-b" 2 + readTVarIO sub.subscriptionDropped `shouldReturn` 1 + readTVarIO sub.subscriptionStatus `shouldReturn` Pub.Active + newest sub.subscriptionQueue `shouldReturn` [GlobalPosition 2] + bracket (atomically (Pub.subscribePublisher store.publisher 1 DropOldest)) (\(_, _, stop) -> stop) $ \(queue, _, stop) -> do + appendAndWait store "drop-c" 3 + appendAndWait store "drop-d" 4 + newest queue `shouldReturn` [GlobalPosition 4] + stop >> stop + Pub.unsubscribe sub >> Pub.unsubscribe sub + (IntMap.size <$> readTVarIO (Pub.subscribers store.publisher)) `shouldReturn` baseline + it "does not count PauseAndResume or DropSubscription overflow" $ withTestStore $ \store -> + mapM_ + ( \policy -> bracket (atomically (Pub.subscribePublisherWith store.publisher 1 policy)) Pub.unsubscribe $ \sub -> do + Right pos <- runStoreIO store (appendToStream (StreamName "policies-a") AnyVersion [makeEvent "E" (object [])]) + bounded (waitForPublisher store pos.globalPosition) + Right pos2 <- runStoreIO store (appendToStream (StreamName "policies-a") AnyVersion [makeEvent "E" (object [])]) + bounded (waitForPublisher store pos2.globalPosition) + readTVarIO sub.subscriptionDropped `shouldReturn` 0 + readTVarIO sub.subscriptionStatus `shouldReturn` (if policy == PauseAndResume then Pub.Paused else Pub.Overflowed) + ) + [PauseAndResume, DropSubscription] appendAndWait :: KirokuStore -> Text -> Int -> IO () appendAndWait store name n = do - Right _ <- runStoreIO store (appendToStream (StreamName name) NoStream [makeEvent "E" (object [])]) - bounded (waitForPublisher store (GlobalPosition (fromIntegral n))) + Right _ <- runStoreIO store (appendToStream (StreamName name) NoStream [makeEvent "E" (object [])]) + bounded (waitForPublisher store (GlobalPosition (fromIntegral n))) bounded :: IO a -> IO a bounded action = timeout 5_000_000 action >>= maybe (fail "publisher timeout") pure newest :: TBQueue DecodedBatch -> IO [GlobalPosition] newest queue = do - Just (UnchangedBatch events) <- atomically (tryReadTBQueue queue) - atomically (isEmptyTBQueue queue) `shouldReturn` True - pure (map (.globalPosition) (V.toList events)) + Just (UnchangedBatch events) <- atomically (tryReadTBQueue queue) + atomically (isEmptyTBQueue queue) `shouldReturn` True + pure (map (.globalPosition) (V.toList events)) diff --git a/test/Test/PublisherIdleAdvance.hs b/test/Test/PublisherIdleAdvance.hs --- a/test/Test/PublisherIdleAdvance.hs +++ b/test/Test/PublisherIdleAdvance.hs @@ -27,149 +27,149 @@ within :: String -> IO a -> IO a within label action = do - result <- Async.race (threadDelay timeoutMicros) action - case result of - Left () -> fail ("timed out waiting for " <> label) - Right a -> pure a + result <- Async.race (threadDelay timeoutMicros) action + case result of + Left () -> fail ("timed out waiting for " <> label) + Right a -> pure a countingSettings :: IORef Int -> ConnectionSettings -> ConnectionSettings countingSettings counter settings = - settings - & #storeSettings - .~ defaultStoreSettings - { decodeHook = - Just $ \event -> do - atomicModifyIORef' counter (\n -> (n + 1, ())) - pure (Right event) - } + settings + & #storeSettings + .~ defaultStoreSettings + { decodeHook = + Just $ \event -> do + atomicModifyIORef' counter (\n -> (n + 1, ())) + pure (Right event) + } appendEvents :: KirokuStore -> Int -> String -> IO GlobalPosition appendEvents store n prefix = do - results <- - traverse - ( \i -> - runStoreIO store $ - appendToStream - (StreamName (fromString (prefix <> "-" <> show i))) - NoStream - [makeEvent (fromString ("E" <> show i)) (Aeson.object [])] - ) - [1 .. n] - case sequence results of - Left err -> fail ("append failed: " <> show err) - Right [] -> fail "appendEvents called with zero events" - Right xs -> pure (last xs ^. #globalPosition) + results <- + traverse + ( \i -> + runStoreIO store $ + appendToStream + (StreamName (fromString (prefix <> "-" <> show i))) + NoStream + [makeEvent (fromString ("E" <> show i)) (Aeson.object [])] + ) + [1 .. n] + case sequence results of + Left err -> fail ("append failed: " <> show err) + Right [] -> fail "appendEvents called with zero events" + Right xs -> pure (last xs ^. #globalPosition) publisherSubscriberCount :: KirokuStore -> IO Int publisherSubscriberCount store = - IntMap.size <$> readTVarIO (Pub.subscribers (store ^. #publisher)) + IntMap.size <$> readTVarIO (Pub.subscribers (store ^. #publisher)) sampleLargeObjects :: IO Integer sampleLargeObjects = do - enabled <- getRTSStatsEnabled - when (not enabled) (fail "publisher retention test requires RTS statistics") - performMajorGC - fromIntegral . gcdetails_large_objects_bytes . gc <$> getRTSStats + enabled <- getRTSStatsEnabled + when (not enabled) (fail "publisher retention test requires RTS statistics") + performMajorGC + fromIntegral . gcdetails_large_objects_bytes . gc <$> getRTSStats spec :: Spec spec = describe "publisher idle advance" $ do - it "does not retain append results while advancing with no queue subscribers" $ do - withTestStore $ \store -> do - let blockSize :: Int - blockSize = 2_000 - blocks :: Int - blocks = 6 - event = makeEvent "Retention" (Aeson.object []) - appendOne = do - result <- runStoreIO store $ appendToStream (StreamName "pubidle-retention") AnyVersion [event] - case result of - Left err -> fail ("append failed: " <> show err) - Right _ -> pure () - samples <- forM [1 .. blocks] $ \_ -> do - sequence_ (replicate blockSize appendOne) - -- Allow the notification-driven publisher to finish its tail - -- query without reading (and thereby forcing) its position. - threadDelay 100_000 - sampleLargeObjects - publisherSubscriberCount store `shouldReturn` 0 - case samples of - firstSample : _ -> do - let growth = last samples - firstSample - when (growth >= 3 * 1024 * 1024) $ - expectationFailure ("large-object bytes grew by " <> show growth <> "; samples: " <> show samples) - [] -> expectationFailure "publisher retention test collected no heap samples" + it "does not retain append results while advancing with no queue subscribers" $ do + withTestStore $ \store -> do + let blockSize :: Int + blockSize = 2_000 + blocks :: Int + blocks = 6 + event = makeEvent "Retention" (Aeson.object []) + appendOne = do + result <- runStoreIO store $ appendToStream (StreamName "pubidle-retention") AnyVersion [event] + case result of + Left err -> fail ("append failed: " <> show err) + Right _ -> pure () + samples <- forM [1 .. blocks] $ \_ -> do + sequence_ (replicate blockSize appendOne) + -- Allow the notification-driven publisher to finish its tail + -- query without reading (and thereby forcing) its position. + threadDelay 100_000 + sampleLargeObjects + publisherSubscriberCount store `shouldReturn` 0 + case samples of + firstSample : _ -> do + let growth = last samples - firstSample + when (growth >= 3 * 1024 * 1024) $ + expectationFailure ("large-object bytes grew by " <> show growth <> "; samples: " <> show samples) + [] -> expectationFailure "publisher retention test collected no heap samples" - it "advances lastPublished without decoding any rows when no subscriber is registered" $ do - counter <- newIORef 0 - withTestStoreSettings (countingSettings counter) $ \store -> do - tailPos <- appendEvents store 25 "pubidle-empty" - waitForPublisher store tailPos - readIORef counter `shouldReturn` 0 + it "advances lastPublished without decoding any rows when no subscriber is registered" $ do + counter <- newIORef 0 + withTestStoreSettings (countingSettings counter) $ \store -> do + tailPos <- appendEvents store 25 "pubidle-empty" + waitForPublisher store tailPos + readIORef counter `shouldReturn` 0 - it "does not fetch full rows while only a category subscriber exists" $ do - counter <- newIORef 0 - caughtUp <- newEmptyMVar - delivered <- newEmptyMVar - let subName = SubscriptionName "pubidle-category" - observe = caughtUpEventHandler subName caughtUp Nothing - handler event = do - case event ^. #eventType of - EventType "Wake" -> () <$ tryPutMVar delivered () - _ -> pure () - pure Continue - tweak settings = - countingSettings counter settings - & #eventHandler .~ Just observe - withTestStoreSettings tweak $ \store -> - bracket - (subscribe store (defaultSubscriptionConfig subName (Category (CategoryName "pubidlea")) handler)) - cancel - $ \_handle -> do - within "category subscription live" (waitForSubscriptionLive caughtUp) - countBefore <- readIORef counter - tailPos <- appendEvents store 30 "pubidleb" - waitForPublisher store tailPos - countAfter <- readIORef counter - (countAfter - countBefore) `shouldBe` 0 - publisherSubscriberCount store `shouldReturn` 0 + it "does not fetch full rows while only a category subscriber exists" $ do + counter <- newIORef 0 + caughtUp <- newEmptyMVar + delivered <- newEmptyMVar + let subName = SubscriptionName "pubidle-category" + observe = caughtUpEventHandler subName caughtUp Nothing + handler event = do + case event ^. #eventType of + EventType "Wake" -> () <$ tryPutMVar delivered () + _ -> pure () + pure Continue + tweak settings = + countingSettings counter settings + & #eventHandler .~ Just observe + withTestStoreSettings tweak $ \store -> + bracket + (subscribe store (defaultSubscriptionConfig subName (Category (CategoryName "pubidlea")) handler)) + cancel + $ \_handle -> do + within "category subscription live" (waitForSubscriptionLive caughtUp) + countBefore <- readIORef counter + tailPos <- appendEvents store 30 "pubidleb" + waitForPublisher store tailPos + countAfter <- readIORef counter + (countAfter - countBefore) `shouldBe` 0 + publisherSubscriberCount store `shouldReturn` 0 - Right wakePos <- - runStoreIO store $ - appendToStream - (StreamName "pubidlea-1") - NoStream - [makeEvent "Wake" (Aeson.object [])] - waitForPublisher store (wakePos ^. #globalPosition) - within "category wake event" (waitForSubscriptionLive delivered) + Right wakePos <- + runStoreIO store $ + appendToStream + (StreamName "pubidlea-1") + NoStream + [makeEvent "Wake" (Aeson.object [])] + waitForPublisher store (wakePos ^. #globalPosition) + within "category wake event" (waitForSubscriptionLive delivered) - it "switches from cheap advance to all-stream delivery without gaps" $ do - counter <- newIORef 0 - caughtUp <- newEmptyMVar - seenRef <- newIORef ([] :: [GlobalPosition]) - seenEnough <- newEmptyMVar - let subName = SubscriptionName "pubidle-transition" - observe = caughtUpEventHandler subName caughtUp Nothing - handler event = do - let pos = event ^. #globalPosition - count <- - atomicModifyIORef' seenRef $ \old -> - let new = pos : old - in (new, length new) - when (count >= 35) (() <$ tryPutMVar seenEnough ()) - pure Continue - tweak settings = - countingSettings counter settings - & #eventHandler .~ Just observe - withTestStoreSettings tweak $ \store -> do - tailBefore <- appendEvents store 20 "pubidle-before" - waitForPublisher store tailBefore - bracket - (subscribe store (defaultSubscriptionConfig subName AllStreams handler)) - cancel - $ \_handle -> do - within "all-stream subscription live" (waitForSubscriptionLive caughtUp) - tailAfter <- appendEvents store 15 "pubidle-after" - waitForPublisher store tailAfter - within "all-stream events" (waitForSubscriptionLive seenEnough) - seen <- sort <$> readIORef seenRef - seen `shouldBe` fmap GlobalPosition [1 .. 35] + it "switches from cheap advance to all-stream delivery without gaps" $ do + counter <- newIORef 0 + caughtUp <- newEmptyMVar + seenRef <- newIORef ([] :: [GlobalPosition]) + seenEnough <- newEmptyMVar + let subName = SubscriptionName "pubidle-transition" + observe = caughtUpEventHandler subName caughtUp Nothing + handler event = do + let pos = event ^. #globalPosition + count <- + atomicModifyIORef' seenRef $ \old -> + let new = pos : old + in (new, length new) + when (count >= 35) (() <$ tryPutMVar seenEnough ()) + pure Continue + tweak settings = + countingSettings counter settings + & #eventHandler .~ Just observe + withTestStoreSettings tweak $ \store -> do + tailBefore <- appendEvents store 20 "pubidle-before" + waitForPublisher store tailBefore + bracket + (subscribe store (defaultSubscriptionConfig subName AllStreams handler)) + cancel + $ \_handle -> do + within "all-stream subscription live" (waitForSubscriptionLive caughtUp) + tailAfter <- appendEvents store 15 "pubidle-after" + waitForPublisher store tailAfter + within "all-stream events" (waitForSubscriptionLive seenEnough) + seen <- sort <$> readIORef seenRef + seen `shouldBe` fmap GlobalPosition [1 .. 35] diff --git a/test/Test/PublisherRestartNoRebroadcast.hs b/test/Test/PublisherRestartNoRebroadcast.hs --- a/test/Test/PublisherRestartNoRebroadcast.hs +++ b/test/Test/PublisherRestartNoRebroadcast.hs @@ -17,204 +17,204 @@ 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 + 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]) + 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 = either (error . show) Prelude.id (mkBatchSize 10) - , queueCapacity = 1 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , retryPolicy = defaultRetryPolicy - , eventTypeFilter = AllEventTypes - , selector = Nothing - } - liveSettings = - settings - & #eventHandler .~ Just (caughtUpEventHandler subName caughtUp Nothing) + 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 = either (error . show) Prelude.id (mkBatchSize 10), + queueCapacity = 1, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + retryPolicy = defaultRetryPolicy, + eventTypeFilter = AllEventTypes, + selector = Nothing + } + liveSettings = + settings + & #eventHandler .~ Just (caughtUpEventHandler subName caughtUp Nothing) - withStore liveSettings $ \store -> do - handle <- subscribe store cfg - takeMVar firstSeen + 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) + Right _ <- + runStoreIO store $ + appendToStream + (StreamName "tail-init-overflow-live") + NoStream + [makeEvent "TailInitDuringCatchUp" (Aeson.object [])] + waitForPublisher store (GlobalPosition 1002) - putMVar releaseFirst () - waitForSubscriptionLive caughtUp + putMVar releaseFirst () + waitForSubscriptionLive caughtUp - Right _ <- - runStoreIO store $ - appendToStream - (StreamName "tail-init-overflow-stop") - NoStream - [makeEvent "TailInitStop" (Aeson.object [])] + 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 () + 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] + 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 + 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 = either (error . show) Prelude.id (mkBatchSize 10) - , queueCapacity = 1 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , retryPolicy = defaultRetryPolicy - , eventTypeFilter = AllEventTypes - , selector = Nothing - } - liveSettings = - settings - & #eventHandler .~ Just (caughtUpEventHandler subName caughtUp Nothing) + 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 = either (error . show) Prelude.id (mkBatchSize 10), + queueCapacity = 1, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 () + 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] + 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 + 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") 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] + 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 () + 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 = either (error . show) Prelude.id (mkBatchSize 10) - , queueCapacity = 1 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 + 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 = either (error . show) Prelude.id (mkBatchSize 10), + queueCapacity = 1, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 --- a/test/Test/ReadStream.hs +++ b/test/Test/ReadStream.hs @@ -1,9 +1,8 @@ -{- | 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. --} +-- | 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 ((^.)) @@ -22,132 +21,132 @@ spec :: Spec spec = do - describe "readStreamForwardStream" $ do - around withTestStore $ 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) + describe "readStreamForwardStream" $ do + around withTestStore $ 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 "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 "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 "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) + 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) - it "uses one pool checkout per non-empty page when the final page is short" $ do - ref <- newIORef (0 :: Int) - let handler (ConnectionObservation _ InUseConnectionStatus) = - modifyIORef' ref (+ 1) - handler _ = - pure () - withTestStoreSettings (\settings -> settings{observationHandler = Just handler}) $ \store -> do - let name = StreamName "rsfs-short-page-count" - events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. 5 :: Int]] - Right appendResult <- runStoreIO store $ appendToStream name NoStream events - waitForPublisher store (appendResult ^. #globalPosition) - countBefore <- readIORef ref - streamed <- runStoreIO store $ Stream.toList (readStreamForwardStream name (StreamVersion 0) 2) - countAfter <- readIORef ref - case streamed of - Right xs -> do - map (^. #streamVersion) xs - `shouldBe` [StreamVersion 1, StreamVersion 2, StreamVersion 3, StreamVersion 4, StreamVersion 5] - countAfter - countBefore `shouldBe` 3 - Left err -> expectationFailure ("Unexpected error: " <> show err) + it "uses one pool checkout per non-empty page when the final page is short" $ do + ref <- newIORef (0 :: Int) + let handler (ConnectionObservation _ InUseConnectionStatus) = + modifyIORef' ref (+ 1) + handler _ = + pure () + withTestStoreSettings (\settings -> settings {observationHandler = Just handler}) $ \store -> do + let name = StreamName "rsfs-short-page-count" + events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. 5 :: Int]] + Right appendResult <- runStoreIO store $ appendToStream name NoStream events + waitForPublisher store (appendResult ^. #globalPosition) + countBefore <- readIORef ref + streamed <- runStoreIO store $ Stream.toList (readStreamForwardStream name (StreamVersion 0) 2) + countAfter <- readIORef ref + case streamed of + Right xs -> do + map (^. #streamVersion) xs + `shouldBe` [StreamVersion 1, StreamVersion 2, StreamVersion 3, StreamVersion 4, StreamVersion 5] + countAfter - countBefore `shouldBe` 3 + Left err -> expectationFailure ("Unexpected error: " <> show err) - describe "eventExistsInStream" $ - around withTestStore $ do - it "finds an existing event id in its live stream" $ \store -> do - eid <- EventId <$> V7.genUUID - let name = StreamName "event-exists-present" - Right _ <- runStoreIO store $ appendToStream name NoStream [eventWithId eid] - runStoreIO store (eventExistsInStream name eid) `shouldReturn` Right True + describe "eventExistsInStream" $ + around withTestStore $ do + it "finds an existing event id in its live stream" $ \store -> do + eid <- EventId <$> V7.genUUID + let name = StreamName "event-exists-present" + Right _ <- runStoreIO store $ appendToStream name NoStream [eventWithId eid] + runStoreIO store (eventExistsInStream name eid) `shouldReturn` Right True - it "returns False for absent ids and ids linked only to another stream" $ \store -> do - eid <- EventId <$> V7.genUUID - otherEid <- EventId <$> V7.genUUID - let source = StreamName "event-exists-source" - target = StreamName "event-exists-target" - Right _ <- runStoreIO store $ appendToStream source NoStream [eventWithId eid] - runStoreIO store (eventExistsInStream source otherEid) `shouldReturn` Right False - runStoreIO store (eventExistsInStream target eid) `shouldReturn` Right False + it "returns False for absent ids and ids linked only to another stream" $ \store -> do + eid <- EventId <$> V7.genUUID + otherEid <- EventId <$> V7.genUUID + let source = StreamName "event-exists-source" + target = StreamName "event-exists-target" + Right _ <- runStoreIO store $ appendToStream source NoStream [eventWithId eid] + runStoreIO store (eventExistsInStream source otherEid) `shouldReturn` Right False + runStoreIO store (eventExistsInStream target eid) `shouldReturn` Right False - it "treats soft-deleted streams as absent" $ \store -> do - eid <- EventId <$> V7.genUUID - let name = StreamName "event-exists-soft-deleted" - Right _ <- runStoreIO store $ appendToStream name NoStream [eventWithId eid] - Right (Just _) <- runStoreIO store $ softDeleteStream name - runStoreIO store (eventExistsInStream name eid) `shouldReturn` Right False + it "treats soft-deleted streams as absent" $ \store -> do + eid <- EventId <$> V7.genUUID + let name = StreamName "event-exists-soft-deleted" + Right _ <- runStoreIO store $ appendToStream name NoStream [eventWithId eid] + Right (Just _) <- runStoreIO store $ softDeleteStream name + runStoreIO store (eventExistsInStream name eid) `shouldReturn` Right False eventWithId :: EventId -> EventData eventWithId eid = - EventData - { eventId = Just eid - , eventType = EventType "Created" - , payload = Aeson.object [] - , metadata = Nothing - , causationId = Nothing - , correlationId = Nothing - } + EventData + { eventId = Just eid, + eventType = EventType "Created", + payload = Aeson.object [], + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } diff --git a/test/Test/ScriptSessionErrors.hs b/test/Test/ScriptSessionErrors.hs --- a/test/Test/ScriptSessionErrors.hs +++ b/test/Test/ScriptSessionErrors.hs @@ -25,89 +25,89 @@ spec :: Spec spec = describe "structured script session errors" $ do - around withTestStore $ do - it "preserves missing-relation SQLSTATE through runTransaction" $ \store -> do - result <- runStoreIO store (runTransaction (Tx.sql (TE.encodeUtf8 missingRelation))) - shouldBeMissingRelation result - it "preserves missing-relation SQLSTATE without retry" $ \store -> do - result <- runStoreIO store (runTransactionNoRetry (Tx.sql (TE.encodeUtf8 missingRelation))) - shouldBeMissingRelation result - forM_ ["40001", "40P01"] $ \code -> do - it ("preserves script SQLSTATE and message " <> show code) $ \store -> do - result <- timeout 5_000_000 $ runStoreIO store (runTransactionNoRetry (Tx.sql (TE.encodeUtf8 (raiseCode code)))) - result `shouldBe` Just (Left (TransientTransactionFailure code fixtureMessage)) - it ("preserves prepared-statement SQLSTATE and message " <> show code) $ \store -> do - result <- - timeout 5_000_000 $ - runStoreIO store $ - runTransactionNoRetry $ - Tx.statement () (preparable (raiseCode code) E.noParams D.noResult) - result `shouldBe` Just (Left (TransientTransactionFailure code fixtureMessage)) - it "rolls back application writes before a script failure" $ \store -> do - createSideTable store - result <- runStoreIO store $ runTransactionNoRetry $ do - Tx.sql "INSERT INTO public.script_error_rows VALUES (1)" - Tx.sql (TE.encodeUtf8 missingRelation) - shouldBeMissingRelation result - countSideRows store `shouldReturn` Right 0 - it "rolls back composed appends and application writes on script failure" $ \store -> do - createSideTable store - result <- runStoreIO store $ - runTransactionAppendingNoRetry (StreamName "script-rollback") NoStream [makeEvent "Created" (Aeson.object [])] $ \_ -> do - Tx.sql "INSERT INTO public.script_error_rows VALUES (1)" - Tx.sql (TE.encodeUtf8 missingRelation) - shouldBeMissingRelation result - countSideRows store `shouldReturn` Right 0 - runStoreIO store (getStream (StreamName "script-rollback")) `shouldReturn` Right Nothing - countEvents store `shouldReturn` 0 + around withTestStore $ do + it "preserves missing-relation SQLSTATE through runTransaction" $ \store -> do + result <- runStoreIO store (runTransaction (Tx.sql (TE.encodeUtf8 missingRelation))) + shouldBeMissingRelation result + it "preserves missing-relation SQLSTATE without retry" $ \store -> do + result <- runStoreIO store (runTransactionNoRetry (Tx.sql (TE.encodeUtf8 missingRelation))) + shouldBeMissingRelation result + forM_ ["40001", "40P01"] $ \code -> do + it ("preserves script SQLSTATE and message " <> show code) $ \store -> do + result <- timeout 5_000_000 $ runStoreIO store (runTransactionNoRetry (Tx.sql (TE.encodeUtf8 (raiseCode code)))) + result `shouldBe` Just (Left (TransientTransactionFailure code fixtureMessage)) + it ("preserves prepared-statement SQLSTATE and message " <> show code) $ \store -> do + result <- + timeout 5_000_000 $ + runStoreIO store $ + runTransactionNoRetry $ + Tx.statement () (preparable (raiseCode code) E.noParams D.noResult) + result `shouldBe` Just (Left (TransientTransactionFailure code fixtureMessage)) + it "rolls back application writes before a script failure" $ \store -> do + createSideTable store + result <- runStoreIO store $ runTransactionNoRetry $ do + Tx.sql "INSERT INTO public.script_error_rows VALUES (1)" + Tx.sql (TE.encodeUtf8 missingRelation) + shouldBeMissingRelation result + countSideRows store `shouldReturn` Right 0 + it "rolls back composed appends and application writes on script failure" $ \store -> do + createSideTable store + result <- runStoreIO store $ + runTransactionAppendingNoRetry (StreamName "script-rollback") NoStream [makeEvent "Created" (Aeson.object [])] $ \_ -> do + Tx.sql "INSERT INTO public.script_error_rows VALUES (1)" + Tx.sql (TE.encodeUtf8 missingRelation) + shouldBeMissingRelation result + countSideRows store `shouldReturn` Right 0 + runStoreIO store (getStream (StreamName "script-rollback")) `shouldReturn` Right Nothing + countEvents store `shouldReturn` 0 - it "preserves missing-relation SQLSTATE through the public pool-backed read" $ - withMigratedTestDatabase $ \connStr -> - withStore (defaultConnectionSettings connStr) $ \store -> - withPool connStr [Config.initSession (Session.script "SET search_path TO pg_catalog")] $ \pool -> do - result <- runStoreIO (store & #pool .~ pool) (getStream (StreamName "missing")) - shouldBeMissingRelation result + it "preserves missing-relation SQLSTATE through the public pool-backed read" $ + withMigratedTestDatabase $ \connStr -> + withStore (defaultConnectionSettings connStr) $ \store -> + withPool connStr [Config.initSession (Session.script "SET search_path TO pg_catalog")] $ \pool -> do + result <- runStoreIO (store & #pool .~ pool) (getStream (StreamName "missing")) + shouldBeMissingRelation result - it "keeps genuine connection establishment failures typed for transactions and reads" $ - withTestStore $ \store -> - withPool "host=/nonexistent/kiroku-script-errors connect_timeout=1" [] $ \pool -> do - let broken = store & #pool .~ pool - tx <- timeout 5_000_000 $ runStoreIO broken (runTransactionNoRetry (Tx.sql "SELECT 1")) - tx `shouldSatisfy` isConnectionLost - readResult <- timeout 5_000_000 $ runStoreIO broken (getStream (StreamName "missing")) - readResult `shouldSatisfy` isConnectionLost + it "keeps genuine connection establishment failures typed for transactions and reads" $ + withTestStore $ \store -> + withPool "host=/nonexistent/kiroku-script-errors connect_timeout=1" [] $ \pool -> do + let broken = store & #pool .~ pool + tx <- timeout 5_000_000 $ runStoreIO broken (runTransactionNoRetry (Tx.sql "SELECT 1")) + tx `shouldSatisfy` isConnectionLost + readResult <- timeout 5_000_000 $ runStoreIO broken (getStream (StreamName "missing")) + readResult `shouldSatisfy` isConnectionLost - it "routes script server errors through every contextual mapper" $ do - forM_ ["40001", "40P01", "42P01", "40003", "23503"] $ \code -> do - let usage = scriptUsage code fixtureMessage Nothing - expected = if code `elem` ["40001", "40P01"] then TransientTransactionFailure code fixtureMessage else UnexpectedServerError code fixtureMessage - mapGenericUsageError usage `shouldBe` expected - mapTransactionUsageError usage `shouldBe` expected - mapLinkUsageError (StreamName "target") usage `shouldBe` expected - isTransientSerializationError usage `shouldBe` (code `elem` ["40001", "40P01"]) - if code == "23503" - then mapUsageError "target" AnyVersion usage `shouldBe` StreamNotFound (StreamName "target") - else do - mapUsageError "target" AnyVersion usage `shouldBe` expected - attributeMultiStreamError [(StreamName "target", AnyVersion)] usage `shouldBe` expected + it "routes script server errors through every contextual mapper" $ do + forM_ ["40001", "40P01", "42P01", "40003", "23503"] $ \code -> do + let usage = scriptUsage code fixtureMessage Nothing + expected = if code `elem` ["40001", "40P01"] then TransientTransactionFailure code fixtureMessage else UnexpectedServerError code fixtureMessage + mapGenericUsageError usage `shouldBe` expected + mapTransactionUsageError usage `shouldBe` expected + mapLinkUsageError (StreamName "target") usage `shouldBe` expected + isTransientSerializationError usage `shouldBe` (code `elem` ["40001", "40P01"]) + if code == "23503" + then mapUsageError "target" AnyVersion usage `shouldBe` StreamNotFound (StreamName "target") + else do + mapUsageError "target" AnyVersion usage `shouldBe` expected + attributeMultiStreamError [(StreamName "target", AnyVersion)] usage `shouldBe` expected - it "retains script append and link constraint attribution" $ do - let usage = scriptUsage "23505" "duplicate key value violates unique constraint \"stream_events_pkey\"" Nothing - mapTransactionUsageError usage `shouldBe` DuplicateEvent Nothing - mapUsageError "target" AnyVersion usage `shouldBe` DuplicateEvent Nothing - mapLinkUsageError (StreamName "target") usage `shouldBe` EventAlreadyLinked (StreamName "target") Nothing - let named = scriptUsage "23505" "duplicate key value violates unique constraint \"ix_streams_stream_name\"" (Just "Key (stream_name)=(second) already exists.") - attributeMultiStreamError [(StreamName "first", AnyVersion), (StreamName "second", NoStream)] named - `shouldBe` StreamAlreadyExists (StreamName "second") + it "retains script append and link constraint attribution" $ do + let usage = scriptUsage "23505" "duplicate key value violates unique constraint \"stream_events_pkey\"" Nothing + mapTransactionUsageError usage `shouldBe` DuplicateEvent Nothing + mapUsageError "target" AnyVersion usage `shouldBe` DuplicateEvent Nothing + mapLinkUsageError (StreamName "target") usage `shouldBe` EventAlreadyLinked (StreamName "target") Nothing + let named = scriptUsage "23505" "duplicate key value violates unique constraint \"ix_streams_stream_name\"" (Just "Key (stream_name)=(second) already exists.") + attributeMultiStreamError [(StreamName "first", AnyVersion), (StreamName "second", NoStream)] named + `shouldBe` StreamAlreadyExists (StreamName "second") - it "distinguishes session connection loss, acquisition timeout and unsupported errors" $ do - let lost = Pool.SessionUsageError (Errors.ConnectionSessionError "connection detail") - fallback = Pool.SessionUsageError (Errors.DriverSessionError "driver detail") - forM_ [mapGenericUsageError, mapTransactionUsageError, mapUsageError "target" AnyVersion, mapLinkUsageError (StreamName "target")] $ \mapper -> do - mapper lost `shouldBe` ConnectionLost "connection detail" - mapper Pool.AcquisitionTimeoutUsageError `shouldBe` PoolAcquisitionTimeout - mapper fallback `shouldSatisfy` (\case ConnectionError _ -> True; _ -> False) - isTransientSerializationError lost `shouldBe` False + it "distinguishes session connection loss, acquisition timeout and unsupported errors" $ do + let lost = Pool.SessionUsageError (Errors.ConnectionSessionError "connection detail") + fallback = Pool.SessionUsageError (Errors.DriverSessionError "driver detail") + forM_ [mapGenericUsageError, mapTransactionUsageError, mapUsageError "target" AnyVersion, mapLinkUsageError (StreamName "target")] $ \mapper -> do + mapper lost `shouldBe` ConnectionLost "connection detail" + mapper Pool.AcquisitionTimeoutUsageError `shouldBe` PoolAcquisitionTimeout + mapper fallback `shouldSatisfy` (\case ConnectionError _ -> True; _ -> False) + isTransientSerializationError lost `shouldBe` False missingRelation :: Text missingRelation = "INSERT INTO public.kiroku_script_missing_relation VALUES (1)" @@ -123,8 +123,8 @@ shouldBeMissingRelation :: (Show a) => Either StoreError a -> Expectation shouldBeMissingRelation result = case result of - Left (UnexpectedServerError "42P01" _) -> pure () - other -> expectationFailure ("Expected structured 42P01, got " <> show other) + Left (UnexpectedServerError "42P01" _) -> pure () + other -> expectationFailure ("Expected structured 42P01, got " <> show other) isConnectionLost :: Maybe (Either StoreError a) -> Bool isConnectionLost (Just (Left (ConnectionLost _))) = True @@ -138,6 +138,6 @@ countSideRows :: KirokuStore -> IO (Either StoreError Int64) countSideRows store = - runStoreIO store $ - runTransactionNoRetry $ - Tx.statement () (preparable "SELECT count(*) FROM public.script_error_rows" E.noParams (D.singleRow (D.column (D.nonNullable D.int8)))) + runStoreIO store $ + runTransactionNoRetry $ + Tx.statement () (preparable "SELECT count(*) FROM public.script_error_rows" E.noParams (D.singleRow (D.column (D.nonNullable D.int8)))) diff --git a/test/Test/StartupFailureSurfacing.hs b/test/Test/StartupFailureSurfacing.hs --- a/test/Test/StartupFailureSurfacing.hs +++ b/test/Test/StartupFailureSurfacing.hs @@ -20,105 +20,105 @@ spec :: Spec spec = describe "startup failure surfacing" $ do - it "fails subscription startup loudly when checkpoint load fails" $ do - handlerCalled <- newTVarIO False - observedRef <- newIORef ([] :: [KirokuEvent]) - let subName = SubscriptionName "load-checkpoint-fails-loudly" - cfg = - defaultSubscriptionConfig subName AllStreams $ \_ -> do - atomically (writeTVar handlerCalled True) - pure Continue - observe evt = modifyIORef' observedRef (evt :) - injectLoadFailure _ = pure (Just (Left Pool.AcquisitionTimeoutUsageError)) - tweak settings = settings & #eventHandler .~ Just observe + it "fails subscription startup loudly when checkpoint load fails" $ do + handlerCalled <- newTVarIO False + observedRef <- newIORef ([] :: [KirokuEvent]) + let subName = SubscriptionName "load-checkpoint-fails-loudly" + cfg = + defaultSubscriptionConfig subName AllStreams $ \_ -> do + atomically (writeTVar handlerCalled True) + pure Continue + observe evt = modifyIORef' observedRef (evt :) + injectLoadFailure _ = pure (Just (Left Pool.AcquisitionTimeoutUsageError)) + tweak settings = settings & #eventHandler .~ Just observe - withTestStoreSettings tweak $ \store -> - withLoadCheckpointHookForTest injectLoadFailure $ do - handle <- subscribe store cfg - result <- waitWithTimeout 5_000_000 handle - case result of - Right (Left e) - | Just Pool.AcquisitionTimeoutUsageError <- fromException e -> pure () - Left timeout -> expectationFailure timeout - Right other -> expectationFailure ("expected checkpoint load failure, got: " <> show other) + withTestStoreSettings tweak $ \store -> + withLoadCheckpointHookForTest injectLoadFailure $ do + handle <- subscribe store cfg + result <- waitWithTimeout 5_000_000 handle + case result of + Right (Left e) + | Just Pool.AcquisitionTimeoutUsageError <- fromException e -> pure () + Left timeout -> expectationFailure timeout + Right other -> expectationFailure ("expected checkpoint load failure, got: " <> show other) - wasCalled <- readTVarIO handlerCalled - wasCalled `shouldBe` False - observed <- reverse <$> readIORef observedRef - any (isLoadCheckpointError subName) observed `shouldBe` True - any (isCrashedStop subName) observed `shouldBe` True + wasCalled <- readTVarIO handlerCalled + wasCalled `shouldBe` False + observed <- reverse <$> readIORef observedRef + any (isLoadCheckpointError subName) observed `shouldBe` True + any (isCrashedStop subName) observed `shouldBe` True - it "refuses a missing checkpoint before Started or handler delivery" $ do - handlerCalled <- newTVarIO False - observedRef <- newIORef ([] :: [KirokuEvent]) - let subName = SubscriptionName "fail-if-checkpoint-missing" - key = SubscriptionCheckpointKey subName 0 - cfg = - ( defaultSubscriptionConfig subName AllStreams $ \_ -> do - atomically (writeTVar handlerCalled True) - pure Continue - ) - { missingCheckpointPolicy = FailIfMissing - } - observe evt = modifyIORef' observedRef (evt :) - tweak settings = settings & #eventHandler .~ Just observe + it "refuses a missing checkpoint before Started or handler delivery" $ do + handlerCalled <- newTVarIO False + observedRef <- newIORef ([] :: [KirokuEvent]) + let subName = SubscriptionName "fail-if-checkpoint-missing" + key = SubscriptionCheckpointKey subName 0 + cfg = + ( defaultSubscriptionConfig subName AllStreams $ \_ -> do + atomically (writeTVar handlerCalled True) + pure Continue + ) + { missingCheckpointPolicy = FailIfMissing + } + observe evt = modifyIORef' observedRef (evt :) + tweak settings = settings & #eventHandler .~ Just observe - withTestStoreSettings tweak $ \store -> do - handle <- subscribe store cfg - result <- waitWithTimeout 5_000_000 handle - case result of - Right (Left e) - | Just (SubscriptionCheckpointMissing actualKey) <- fromException e -> - actualKey `shouldBe` key - Left timeout -> expectationFailure timeout - Right other -> expectationFailure ("expected missing-checkpoint refusal, got: " <> show other) + withTestStoreSettings tweak $ \store -> do + handle <- subscribe store cfg + result <- waitWithTimeout 5_000_000 handle + case result of + Right (Left e) + | Just (SubscriptionCheckpointMissing actualKey) <- fromException e -> + actualKey `shouldBe` key + Left timeout -> expectationFailure timeout + Right other -> expectationFailure ("expected missing-checkpoint refusal, got: " <> show other) - runStoreIO store subscriptionCheckpointInventory - `shouldReturn` Right (SubscriptionCheckpointInventory (GlobalPosition 0) mempty) + runStoreIO store subscriptionCheckpointInventory + `shouldReturn` Right (SubscriptionCheckpointInventory (GlobalPosition 0) mempty) - readTVarIO handlerCalled `shouldReturn` False - observed <- reverse <$> readIORef observedRef - observed `shouldSatisfy` any (isMissingCheckpoint key) - observed `shouldSatisfy` all (not . isStarted subName) + readTVarIO handlerCalled `shouldReturn` False + observed <- reverse <$> readIORef observedRef + observed `shouldSatisfy` any (isMissingCheckpoint key) + observed `shouldSatisfy` all (not . isStarted subName) - it "leaves no publisher or subscription registry entries after a subscribe/cancel storm" $ - withTestStore $ \store -> do - let cfg = defaultSubscriptionConfig (SubscriptionName "subscribe-cancel-storm") AllStreams (\_ -> pure Continue) - -- 200 iterations gives async exceptions many chances to land in the - -- pre-fork window without making the test expensive on normal runs. - replicateM_ 200 $ do - pendingAsync <- Async.async (subscribe store cfg) - Async.cancel pendingAsync - outcome <- Async.waitCatch pendingAsync - case outcome of - Right handle -> cancel handle >> (() <$ wait handle) - Left (_ :: SomeException) -> pure () + it "leaves no publisher or subscription registry entries after a subscribe/cancel storm" $ + withTestStore $ \store -> do + let cfg = defaultSubscriptionConfig (SubscriptionName "subscribe-cancel-storm") AllStreams (\_ -> pure Continue) + -- 200 iterations gives async exceptions many chances to land in the + -- pre-fork window without making the test expensive on normal runs. + replicateM_ 200 $ do + pendingAsync <- Async.async (subscribe store cfg) + Async.cancel pendingAsync + outcome <- Async.waitCatch pendingAsync + case outcome of + Right handle -> cancel handle >> (() <$ wait handle) + Left (_ :: SomeException) -> pure () - subs <- readTVarIO (Pub.subscribers (store ^. #publisher)) - reg <- readTVarIO (store ^. #subscriptionRegistry) - IntMap.null subs `shouldBe` True - Map.null reg `shouldBe` True + subs <- readTVarIO (Pub.subscribers (store ^. #publisher)) + reg <- readTVarIO (store ^. #subscriptionRegistry) + IntMap.null subs `shouldBe` True + Map.null reg `shouldBe` True isLoadCheckpointError :: SubscriptionName -> KirokuEvent -> Bool isLoadCheckpointError expected = \case - KirokuEventSubscriptionDbError actual LoadCheckpoint Pool.AcquisitionTimeoutUsageError _ - | actual == expected -> True - _ -> False + KirokuEventSubscriptionDbError actual LoadCheckpoint Pool.AcquisitionTimeoutUsageError _ + | actual == expected -> True + _ -> False isCrashedStop :: SubscriptionName -> KirokuEvent -> Bool isCrashedStop expected = \case - KirokuEventSubscriptionStopped actual _ (StopWorkerCrashed e) _ - | actual == expected - , Just Pool.AcquisitionTimeoutUsageError <- fromException e -> - True - _ -> False + KirokuEventSubscriptionStopped actual _ (StopWorkerCrashed e) _ + | actual == expected, + Just Pool.AcquisitionTimeoutUsageError <- fromException e -> + True + _ -> False isMissingCheckpoint :: SubscriptionCheckpointKey -> KirokuEvent -> Bool isMissingCheckpoint expected = \case - KirokuEventSubscriptionCheckpointMissing (SubscriptionCheckpointMissing actual) _ -> actual == expected - _ -> False + KirokuEventSubscriptionCheckpointMissing (SubscriptionCheckpointMissing actual) _ -> actual == expected + _ -> False isStarted :: SubscriptionName -> KirokuEvent -> Bool isStarted expected = \case - KirokuEventSubscriptionStarted actual _ _ -> actual == expected - _ -> False + KirokuEventSubscriptionStarted actual _ _ -> actual == expected + _ -> False diff --git a/test/Test/StreamBridgeTermination.hs b/test/Test/StreamBridgeTermination.hs --- a/test/Test/StreamBridgeTermination.hs +++ b/test/Test/StreamBridgeTermination.hs @@ -20,97 +20,97 @@ import Test.Hspec data TestBoom = TestBoom - deriving stock (Show) - deriving anyclass (Exception) + deriving stock (Show) + deriving anyclass (Exception) timeoutMicros :: Int timeoutMicros = 10_000_000 within :: String -> IO a -> IO a within label action = do - result <- Async.race (threadDelay timeoutMicros) action - case result of - Left () -> fail ("timed out waiting for " <> label) - Right a -> pure a + result <- Async.race (threadDelay timeoutMicros) action + case result of + Left () -> fail ("timed out waiting for " <> label) + Right a -> pure a appendOne :: KirokuStore -> StreamName -> EventType -> IO GlobalPosition appendOne store streamName (EventType eventType') = do - Right r <- runStoreIO store $ appendToStream streamName NoStream [makeEvent eventType' (Aeson.object [])] - pure (r ^. #globalPosition) + Right r <- runStoreIO store $ appendToStream streamName NoStream [makeEvent eventType' (Aeson.object [])] + pure (r ^. #globalPosition) spec :: Spec spec = describe "stream bridge termination" $ do - it "rejects a zero-sized bridge buffer at construction" $ - Buffer.mkStreamBufferSize 0 `shouldBe` Left (InvalidStreamBufferSize 0) + it "rejects a zero-sized bridge buffer at construction" $ + Buffer.mkStreamBufferSize 0 `shouldBe` Left (InvalidStreamBufferSize 0) - it "rethrows the worker exception to the consumer when the worker dies" $ - withTestStore $ \store -> do - pos <- appendOne store (StreamName "bridge-crash") (EventType "BridgeCrash") - waitForPublisher store pos - let cfg = defaultSubscriptionConfig (SubscriptionName "bridge-crash-sub") AllStreams (\_ -> pure Continue) - injectBoom _ _ = throwIO TestBoom - withFetchBatchHookForTest injectBoom $ do - (stream, cancelStream) <- subscriptionAckStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 16)) - pulled <- within "stream pull to throw TestBoom" (try (Stream.uncons stream)) - cancelStream - case pulled of - Left e - | Just TestBoom <- fromException (e :: SomeException) -> pure () - Left e -> expectationFailure ("expected TestBoom, got: " <> show e) - Right _ -> expectationFailure "expected stream pull to throw TestBoom" + it "rethrows the worker exception to the consumer when the worker dies" $ + withTestStore $ \store -> do + pos <- appendOne store (StreamName "bridge-crash") (EventType "BridgeCrash") + waitForPublisher store pos + let cfg = defaultSubscriptionConfig (SubscriptionName "bridge-crash-sub") AllStreams (\_ -> pure Continue) + injectBoom _ _ = throwIO TestBoom + withFetchBatchHookForTest injectBoom $ do + (stream, cancelStream) <- subscriptionAckStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 16)) + pulled <- within "stream pull to throw TestBoom" (try (Stream.uncons stream)) + cancelStream + case pulled of + Left e + | Just TestBoom <- fromException (e :: SomeException) -> pure () + Left e -> expectationFailure ("expected TestBoom, got: " <> show e) + Right _ -> expectationFailure "expected stream pull to throw TestBoom" - it "ends the stream after a clean worker stop" $ - withTestStore $ \store -> do - let cfg = defaultSubscriptionConfig (SubscriptionName "bridge-clean-stop-sub") AllStreams (\_ -> pure Continue) - (stream0, cancelStream) <- subscriptionAckStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 16)) - finally - ( do - pos <- appendOne store (StreamName "bridge-clean-stop") (EventType "BridgeCleanStop") - waitForPublisher store pos - mFirst <- within "first bridge item" (Stream.uncons stream0) - (stream1, item) <- case mFirst of - Nothing -> fail "expected one bridge item before clean stop" - Just (firstItem, rest) -> pure (rest, firstItem) - atomically (putTMVar (ackReply item) Stop) - mNext <- within "stream end after clean stop" (Stream.uncons stream1) - case mNext of - Nothing -> pure () - Just _ -> expectationFailure "expected stream to end after clean stop" - ) - cancelStream + it "ends the stream after a clean worker stop" $ + withTestStore $ \store -> do + let cfg = defaultSubscriptionConfig (SubscriptionName "bridge-clean-stop-sub") AllStreams (\_ -> pure Continue) + (stream0, cancelStream) <- subscriptionAckStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 16)) + finally + ( do + pos <- appendOne store (StreamName "bridge-clean-stop") (EventType "BridgeCleanStop") + waitForPublisher store pos + mFirst <- within "first bridge item" (Stream.uncons stream0) + (stream1, item) <- case mFirst of + Nothing -> fail "expected one bridge item before clean stop" + Just (firstItem, rest) -> pure (rest, firstItem) + atomically (putTMVar (ackReply item) Stop) + mNext <- within "stream end after clean stop" (Stream.uncons stream1) + case mNext of + Nothing -> pure () + Just _ -> expectationFailure "expected stream to end after clean stop" + ) + cancelStream - it "cancelAction returns promptly even when the bridge queue is full" $ - withTestStore $ \store -> do - let cfg = defaultSubscriptionConfig (SubscriptionName "bridge-full-cancel-sub") AllStreams (\_ -> pure Continue) - (stream0, cancelStream) <- subscriptionAckStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 1)) - _pos1 <- appendOne store (StreamName "bridge-full-cancel-1") (EventType "BridgeFullCancel1") - pos2 <- appendOne store (StreamName "bridge-full-cancel-2") (EventType "BridgeFullCancel2") - waitForPublisher store pos2 + it "cancelAction returns promptly even when the bridge queue is full" $ + withTestStore $ \store -> do + let cfg = defaultSubscriptionConfig (SubscriptionName "bridge-full-cancel-sub") AllStreams (\_ -> pure Continue) + (stream0, cancelStream) <- subscriptionAckStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 1)) + _pos1 <- appendOne store (StreamName "bridge-full-cancel-1") (EventType "BridgeFullCancel1") + pos2 <- appendOne store (StreamName "bridge-full-cancel-2") (EventType "BridgeFullCancel2") + waitForPublisher store pos2 - within "non-blocking cancelAction with a full queue" cancelStream + within "non-blocking cancelAction with a full queue" cancelStream - mFirst <- within "drained item after cancel" (Stream.uncons stream0) - case mFirst of - Nothing -> pure () - Just (item, stream1) -> do - atomically (putTMVar (ackReply item) Continue) - mNext <- within "stream end after cancel" (Stream.uncons stream1) - case mNext of - Nothing -> pure () - Just _ -> expectationFailure "expected stream to end after cancel" + mFirst <- within "drained item after cancel" (Stream.uncons stream0) + case mFirst of + Nothing -> pure () + Just (item, stream1) -> do + atomically (putTMVar (ackReply item) Continue) + mNext <- within "stream end after cancel" (Stream.uncons stream1) + case mNext of + Nothing -> pure () + Just _ -> expectationFailure "expected stream to end after cancel" - it "cancelAction is idempotent and leaves no subscription thread registered" $ - withTestStore $ \store -> do - let subscriptionName = SubscriptionName "bridge-idempotent-cancel-sub" - cfg = defaultSubscriptionConfig subscriptionName AllStreams (\_ -> pure Continue) - key = (subscriptionName, 0) - (_stream, cancelStream) <- subscriptionAckStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 1)) + it "cancelAction is idempotent and leaves no subscription thread registered" $ + withTestStore $ \store -> do + let subscriptionName = SubscriptionName "bridge-idempotent-cancel-sub" + cfg = defaultSubscriptionConfig subscriptionName AllStreams (\_ -> pure Continue) + key = (subscriptionName, 0) + (_stream, cancelStream) <- subscriptionAckStream store cfg (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 1)) - statesBefore <- subscriptionStates store - Map.member key statesBefore `shouldBe` True + statesBefore <- subscriptionStates store + Map.member key statesBefore `shouldBe` True - within "first bridge cancellation" cancelStream - within "repeated bridge cancellation" cancelStream + within "first bridge cancellation" cancelStream + within "repeated bridge cancellation" cancelStream - statesAfter <- subscriptionStates store - Map.member key statesAfter `shouldBe` False + statesAfter <- subscriptionStates store + Map.member key statesAfter `shouldBe` False diff --git a/test/Test/StreamHead.hs b/test/Test/StreamHead.hs --- a/test/Test/StreamHead.hs +++ b/test/Test/StreamHead.hs @@ -20,89 +20,89 @@ spec :: Spec spec = describe "stream head" $ do - forM_ [False, True] $ \resource -> describe (if resource then "resource runner" else "direct runner") $ do - let readHead store name = - if resource - then runEff . runErrorNoCallStack @StoreError . runKirokuStoreWith store . runStoreResource $ getStreamWithHead name - else runStoreIO store (getStreamWithHead name) - check store name version headPosition = do - Right (Just metadata) <- runStoreIO store (getStream name) - metadata ^. #version `shouldBe` StreamVersion version - readHead store name `shouldReturn` Right (Just (metadata, headPosition)) - it "distinguishes absent, empty and reserved $all in empty and populated stores" $ withTestStore $ \store -> do - readHead store (StreamName "missing") `shouldReturn` Right Nothing - raw store "INSERT INTO streams(stream_name) VALUES ('empty')" - check store (StreamName "empty") 0 Nothing - check store (StreamName "$all") 0 Nothing - appendOne store (StreamName "origin") - check store (StreamName "$all") 1 Nothing - it "captures interleaved heads, logical lifecycle and a fresh identity after hard deletion" $ withTestStore $ \store -> do - let a = StreamName "a"; b = StreamName "b" - mapM_ (appendOne store) [a, b, a, b] - originated <- appendPosition store a - originated `shouldBe` GlobalPosition 5 - check store a 3 (Just originated) - appendOne store b - check store a 3 (Just originated) - Right (Just _) <- runStoreIO store (setStreamTruncateBefore a (StreamVersion 3)) - check store a 3 (Just originated) - Right (Just _) <- runStoreIO store (softDeleteStream a) - check store a 3 (Just originated) - Right (Just (old, _)) <- readHead store a - Right (Just _) <- runStoreIO store (hardDeleteStream a) - readHead store a `shouldReturn` Right Nothing - raw store "INSERT INTO streams(stream_name) VALUES ('a')" - check store a 0 Nothing - Right (Just (fresh, _)) <- readHead store a - fresh ^. #id `shouldNotBe` (old ^. #id) - recreated <- appendPosition store a - recreated `shouldBe` GlobalPosition 7 - check store a 1 (Just recreated) - it "ignores links while tracking subsequent originated appends" $ withTestStore $ \store -> do - let mixed = StreamName "mixed"; source = StreamName "source"; linked = StreamName "linked" - appendOne store mixed - appendOne store source - Right events <- runStoreIO store (readAllForward (GlobalPosition 0) 10) - let eid = (events V.! 1) ^. #eventId - Right _ <- runStoreIO store (linkToStream linked [eid]) - check store linked 1 Nothing - Right _ <- runStoreIO store (linkToStream mixed [eid]) - check store mixed 2 (Just ((events V.! 0) ^. #globalPosition)) - next <- appendPosition store mixed - next `shouldBe` GlobalPosition 3 - check store mixed 3 (Just next) - it "never invokes the event decode hook" $ do - calls <- newIORef (0 :: Int) - let hook _ = modifyIORef' calls (+ 1) >> error "unexpected event decode" - withTestStoreSettings (\settings -> settings & #storeSettings .~ defaultStoreSettings{decodeHook = Just hook}) $ \store -> do - expected <- appendPosition store (StreamName "hook") - Right (Just (_, actual)) <- runStoreIO store (getStreamWithHead (StreamName "hook")) - actual `shouldBe` Just expected - readIORef calls `shouldReturn` 0 - it "observes version and head from one snapshot while appends commit" $ withTestStore $ \store -> do - let name = StreamName "concurrent" - appendOne store name - start <- newEmptyMVar - let writer = takeMVar start >> replicateM_ 100 (appendOne store name) - reader = replicateM_ 200 $ do - Right (Just (info, Just (GlobalPosition position))) <- runStoreIO store (getStreamWithHead name) - info ^. #version `shouldBe` StreamVersion position - outcome <- timeout 20_000_000 $ Async.withAsync writer $ \worker -> do - putMVar start () - reader - Async.wait worker - outcome `shouldBe` Just () - Right (Just (info, headPosition)) <- runStoreIO store (getStreamWithHead name) - info ^. #version `shouldBe` StreamVersion 101 - headPosition `shouldBe` Just (GlobalPosition 101) + forM_ [False, True] $ \resource -> describe (if resource then "resource runner" else "direct runner") $ do + let readHead store name = + if resource + then runEff . runErrorNoCallStack @StoreError . runKirokuStoreWith store . runStoreResource $ getStreamWithHead name + else runStoreIO store (getStreamWithHead name) + check store name version headPosition = do + Right (Just metadata) <- runStoreIO store (getStream name) + metadata ^. #version `shouldBe` StreamVersion version + readHead store name `shouldReturn` Right (Just (metadata, headPosition)) + it "distinguishes absent, empty and reserved $all in empty and populated stores" $ withTestStore $ \store -> do + readHead store (StreamName "missing") `shouldReturn` Right Nothing + raw store "INSERT INTO streams(stream_name) VALUES ('empty')" + check store (StreamName "empty") 0 Nothing + check store (StreamName "$all") 0 Nothing + appendOne store (StreamName "origin") + check store (StreamName "$all") 1 Nothing + it "captures interleaved heads, logical lifecycle and a fresh identity after hard deletion" $ withTestStore $ \store -> do + let a = StreamName "a"; b = StreamName "b" + mapM_ (appendOne store) [a, b, a, b] + originated <- appendPosition store a + originated `shouldBe` GlobalPosition 5 + check store a 3 (Just originated) + appendOne store b + check store a 3 (Just originated) + Right (Just _) <- runStoreIO store (setStreamTruncateBefore a (StreamVersion 3)) + check store a 3 (Just originated) + Right (Just _) <- runStoreIO store (softDeleteStream a) + check store a 3 (Just originated) + Right (Just (old, _)) <- readHead store a + Right (Just _) <- runStoreIO store (hardDeleteStream a) + readHead store a `shouldReturn` Right Nothing + raw store "INSERT INTO streams(stream_name) VALUES ('a')" + check store a 0 Nothing + Right (Just (fresh, _)) <- readHead store a + fresh ^. #id `shouldNotBe` (old ^. #id) + recreated <- appendPosition store a + recreated `shouldBe` GlobalPosition 7 + check store a 1 (Just recreated) + it "ignores links while tracking subsequent originated appends" $ withTestStore $ \store -> do + let mixed = StreamName "mixed"; source = StreamName "source"; linked = StreamName "linked" + appendOne store mixed + appendOne store source + Right events <- runStoreIO store (readAllForward (GlobalPosition 0) 10) + let eid = (events V.! 1) ^. #eventId + Right _ <- runStoreIO store (linkToStream linked [eid]) + check store linked 1 Nothing + Right _ <- runStoreIO store (linkToStream mixed [eid]) + check store mixed 2 (Just ((events V.! 0) ^. #globalPosition)) + next <- appendPosition store mixed + next `shouldBe` GlobalPosition 3 + check store mixed 3 (Just next) + it "never invokes the event decode hook" $ do + calls <- newIORef (0 :: Int) + let hook _ = modifyIORef' calls (+ 1) >> error "unexpected event decode" + withTestStoreSettings (\settings -> settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook}) $ \store -> do + expected <- appendPosition store (StreamName "hook") + Right (Just (_, actual)) <- runStoreIO store (getStreamWithHead (StreamName "hook")) + actual `shouldBe` Just expected + readIORef calls `shouldReturn` 0 + it "observes version and head from one snapshot while appends commit" $ withTestStore $ \store -> do + let name = StreamName "concurrent" + appendOne store name + start <- newEmptyMVar + let writer = takeMVar start >> replicateM_ 100 (appendOne store name) + reader = replicateM_ 200 $ do + Right (Just (info, Just (GlobalPosition position))) <- runStoreIO store (getStreamWithHead name) + info ^. #version `shouldBe` StreamVersion position + outcome <- timeout 20_000_000 $ Async.withAsync writer $ \worker -> do + putMVar start () + reader + Async.wait worker + outcome `shouldBe` Just () + Right (Just (info, headPosition)) <- runStoreIO store (getStreamWithHead name) + info ^. #version `shouldBe` StreamVersion 101 + headPosition `shouldBe` Just (GlobalPosition 101) appendOne :: KirokuStore -> StreamName -> IO () appendOne store name = void (appendPosition store name) appendPosition :: KirokuStore -> StreamName -> IO GlobalPosition appendPosition store name = do - result <- runStoreIO store (appendToStream name AnyVersion [makeEvent "StreamHeadEvent" Null]) - either (fail . show) (pure . (^. #globalPosition)) result + result <- runStoreIO store (appendToStream name AnyVersion [makeEvent "StreamHeadEvent" Null]) + either (fail . show) (pure . (^. #globalPosition)) result raw :: KirokuStore -> Text -> IO () raw store command = Pool.use (store ^. #pool) (Session.script command) >>= either (expectationFailure . show) pure diff --git a/test/Test/StreamHeadIsolation.hs b/test/Test/StreamHeadIsolation.hs --- a/test/Test/StreamHeadIsolation.hs +++ b/test/Test/StreamHeadIsolation.hs @@ -10,27 +10,27 @@ spec :: Spec spec = describe "stream head legacy isolation" $ do - forM_ statements $ \(name, actual) -> - it ("preserves " <> name <> " byte for byte") $ do - path <- getDataFileName ("test/fixtures/stream-head-isolation/" <> name <> ".sql") - expected <- T.readFile path - actual `shouldBe` expected - it "keeps the six metadata and eleven event result columns" $ do - columnCount (Statement.toSql SQL.getStreamStmt) `shouldBe` 6 - columnCount (Statement.toSql SQL.readAllForwardStmt) `shouldBe` 11 + forM_ statements $ \(name, actual) -> + it ("preserves " <> name <> " byte for byte") $ do + path <- getDataFileName ("test/fixtures/stream-head-isolation/" <> name <> ".sql") + expected <- T.readFile path + actual `shouldBe` expected + it "keeps the six metadata and eleven event result columns" $ do + columnCount (Statement.toSql SQL.getStreamStmt) `shouldBe` 6 + columnCount (Statement.toSql SQL.readAllForwardStmt) `shouldBe` 11 where columnCount = length . T.splitOn "," . fst . T.breakOn "FROM" . snd . T.breakOn "SELECT" statements = - [ ("getStreamStmt", Statement.toSql SQL.getStreamStmt) - , ("readStreamForwardStmt", Statement.toSql SQL.readStreamForwardStmt) - , ("readStreamBackwardStmt", Statement.toSql SQL.readStreamBackwardStmt) - , ("readAllForwardStmt", Statement.toSql SQL.readAllForwardStmt) - , ("readAllBackwardStmt", Statement.toSql SQL.readAllBackwardStmt) - , ("readCategoryForwardStmt", Statement.toSql SQL.readCategoryForwardStmt) - , ("readCategoryForwardConsumerGroupStmt", Statement.toSql SQL.readCategoryForwardConsumerGroupStmt) - , ("appendExpectedVersion", Statement.toSql SQL.appendExpectedVersion) - , ("appendStreamExists", Statement.toSql SQL.appendStreamExists) - , ("appendNoStream", Statement.toSql SQL.appendNoStream) - , ("appendAnyVersion", Statement.toSql SQL.appendAnyVersion) - , ("linkToStreamStmt", Statement.toSql SQL.linkToStreamStmt) - ] + [ ("getStreamStmt", Statement.toSql SQL.getStreamStmt), + ("readStreamForwardStmt", Statement.toSql SQL.readStreamForwardStmt), + ("readStreamBackwardStmt", Statement.toSql SQL.readStreamBackwardStmt), + ("readAllForwardStmt", Statement.toSql SQL.readAllForwardStmt), + ("readAllBackwardStmt", Statement.toSql SQL.readAllBackwardStmt), + ("readCategoryForwardStmt", Statement.toSql SQL.readCategoryForwardStmt), + ("readCategoryForwardConsumerGroupStmt", Statement.toSql SQL.readCategoryForwardConsumerGroupStmt), + ("appendExpectedVersion", Statement.toSql SQL.appendExpectedVersion), + ("appendStreamExists", Statement.toSql SQL.appendStreamExists), + ("appendNoStream", Statement.toSql SQL.appendNoStream), + ("appendAnyVersion", Statement.toSql SQL.appendAnyVersion), + ("linkToStreamStmt", Statement.toSql SQL.linkToStreamStmt) + ] diff --git a/test/Test/StreamHeadMock.hs b/test/Test/StreamHeadMock.hs --- a/test/Test/StreamHeadMock.hs +++ b/test/Test/StreamHeadMock.hs @@ -10,19 +10,19 @@ spec :: Spec spec = describe "stream head mock" $ it "sends exactly one dedicated constructor and preserves all nested-Maybe outcomes" $ do - now <- getCurrentTime - let name = StreamName "mock" - info = StreamInfo (StreamId 42) name (StreamVersion 3) now Nothing (StreamVersion 0) - forM_ [Nothing, Just (info, Nothing), Just (info, Just (GlobalPosition 5))] $ \expected -> do - calls <- newIORef (0 :: Int) - actual <- runEff $ runMock calls name expected (getStreamWithHead name) - actual `shouldBe` expected - readIORef calls `shouldReturn` 1 + now <- getCurrentTime + let name = StreamName "mock" + info = StreamInfo (StreamId 42) name (StreamVersion 3) now Nothing (StreamVersion 0) + forM_ [Nothing, Just (info, Nothing), Just (info, Just (GlobalPosition 5))] $ \expected -> do + calls <- newIORef (0 :: Int) + actual <- runEff $ runMock calls name expected (getStreamWithHead name) + actual `shouldBe` expected + readIORef calls `shouldReturn` 1 runMock :: (IOE :> es) => IORef Int -> StreamName -> Maybe (StreamInfo, Maybe GlobalPosition) -> Eff (Store : es) a -> Eff es a runMock calls name expected = interpret_ $ \case - GetStreamWithHead actual -> do - liftIO $ actual `shouldBe` name - liftIO $ modifyIORef' calls (+ 1) - pure expected - _ -> error "unexpected Store operation in stream-head mock" + GetStreamWithHead actual -> do + liftIO $ actual `shouldBe` name + liftIO $ modifyIORef' calls (+ 1) + pure expected + _ -> error "unexpected Store operation in stream-head mock" diff --git a/test/Test/StreamHistoryGuard.hs b/test/Test/StreamHistoryGuard.hs --- a/test/Test/StreamHistoryGuard.hs +++ b/test/Test/StreamHistoryGuard.hs @@ -22,184 +22,184 @@ spec :: Spec spec = describe "stream history guard" $ do - it "returns exact metadata and pages with production cursor semantics" $ - withTestStore $ \store -> do - let stream = StreamName "guard-metadata" - Right _ <- runStoreIO store $ appendToStream stream NoStream (events 3) - Right _ <- runStoreIO store $ setStreamTruncateBefore stream (StreamVersion 2) - result <- runTx store $ do - locked <- lockStreamHistoryForReplayTx stream - page <- readStreamForwardTx stream (StreamVersion 0) 10 - pure (locked, page) - case result of - (Right info, page) -> do - info ^. #version `shouldBe` StreamVersion 3 - info ^. #truncateBefore `shouldBe` StreamVersion 2 - info ^. #deletedAt `shouldBe` Nothing - fmap (^. #streamVersion) (Vector.toList page) - `shouldBe` [StreamVersion 2, StreamVersion 3] - (Left unavailable, _) -> expectationFailure ("guard unexpectedly unavailable: " <> show unavailable) + it "returns exact metadata and pages with production cursor semantics" $ + withTestStore $ \store -> do + let stream = StreamName "guard-metadata" + Right _ <- runStoreIO store $ appendToStream stream NoStream (events 3) + Right _ <- runStoreIO store $ setStreamTruncateBefore stream (StreamVersion 2) + result <- runTx store $ do + locked <- lockStreamHistoryForReplayTx stream + page <- readStreamForwardTx stream (StreamVersion 0) 10 + pure (locked, page) + case result of + (Right info, page) -> do + info ^. #version `shouldBe` StreamVersion 3 + info ^. #truncateBefore `shouldBe` StreamVersion 2 + info ^. #deletedAt `shouldBe` Nothing + fmap (^. #streamVersion) (Vector.toList page) + `shouldBe` [StreamVersion 2, StreamVersion 3] + (Left unavailable, _) -> expectationFailure ("guard unexpectedly unavailable: " <> show unavailable) - it "returns typed unavailable results for missing and reserved streams" $ - withTestStore $ \store -> do - missing <- runTx store (lockStreamHistoryForReplayTx (StreamName "guard-missing")) - missing `shouldBe` Left (StreamHistoryNotFound (StreamName "guard-missing")) - reserved <- runTx store (lockStreamHistoryForReplayTx (StreamName "$all")) - reserved `shouldBe` Left (StreamHistoryReserved (StreamName "$all")) + it "returns typed unavailable results for missing and reserved streams" $ + withTestStore $ \store -> do + missing <- runTx store (lockStreamHistoryForReplayTx (StreamName "guard-missing")) + missing `shouldBe` Left (StreamHistoryNotFound (StreamName "guard-missing")) + reserved <- runTx store (lockStreamHistoryForReplayTx (StreamName "$all")) + reserved `shouldBe` Left (StreamHistoryReserved (StreamName "$all")) - it "returns soft-deleted metadata and blocks undelete until guard completion" $ - withTestStore $ \store -> do - let stream = StreamName "guard-undelete" - Right _ <- runStoreIO store $ appendToStream stream NoStream (events 1) - Right _ <- runStoreIO store $ softDeleteStream stream - assertBlockedByGuard store stream $ do - info <- runTx store (lockStreamHistoryForReplayTx stream) - info `shouldSatisfy` \case Right StreamInfo{deletedAt = Just _} -> True; _ -> False - runStoreIO store (undeleteStream stream) + it "returns soft-deleted metadata and blocks undelete until guard completion" $ + withTestStore $ \store -> do + let stream = StreamName "guard-undelete" + Right _ <- runStoreIO store $ appendToStream stream NoStream (events 1) + Right _ <- runStoreIO store $ softDeleteStream stream + assertBlockedByGuard store stream $ do + info <- runTx store (lockStreamHistoryForReplayTx stream) + info `shouldSatisfy` \case Right StreamInfo {deletedAt = Just _} -> True; _ -> False + runStoreIO store (undeleteStream stream) - it "blocks append until guard completion" $ - withTestStore $ \store -> do - let stream = StreamName "guard-append" - Right _ <- runStoreIO store $ appendToStream stream NoStream (events 1) - assertBlockedByGuard store stream $ - runStoreIO store (appendToStream stream AnyVersion (events 1)) + it "blocks append until guard completion" $ + withTestStore $ \store -> do + let stream = StreamName "guard-append" + Right _ <- runStoreIO store $ appendToStream stream NoStream (events 1) + assertBlockedByGuard store stream $ + runStoreIO store (appendToStream stream AnyVersion (events 1)) - it "releases the guard on rollback and lets the blocked append complete" $ - withTestStore $ \store -> do - let stream = StreamName "guard-rollback" - Right _ <- runStoreIO store $ appendToStream stream NoStream (events 1) - assertBlockedByGuardEnding True store stream $ - runStoreIO store (appendToStream stream AnyVersion (events 1)) + it "releases the guard on rollback and lets the blocked append complete" $ + withTestStore $ \store -> do + let stream = StreamName "guard-rollback" + Right _ <- runStoreIO store $ appendToStream stream NoStream (events 1) + assertBlockedByGuardEnding True store stream $ + runStoreIO store (appendToStream stream AnyVersion (events 1)) - it "blocks link into the guarded stream until guard completion" $ - withTestStore $ \store -> do - let source = StreamName "guard-link-source" - target = StreamName "guard-link-target" - Right _ <- runStoreIO store $ appendToStream source NoStream (events 1) - Right _ <- runStoreIO store $ appendToStream target NoStream (events 1) - Right sourceRows <- runStoreIO store $ readStreamForward source (StreamVersion 0) 10 - let eventId = Vector.head sourceRows ^. #eventId - assertBlockedByGuard store target $ - runStoreIO store (linkToStream target [eventId]) + it "blocks link into the guarded stream until guard completion" $ + withTestStore $ \store -> do + let source = StreamName "guard-link-source" + target = StreamName "guard-link-target" + Right _ <- runStoreIO store $ appendToStream source NoStream (events 1) + Right _ <- runStoreIO store $ appendToStream target NoStream (events 1) + Right sourceRows <- runStoreIO store $ readStreamForward source (StreamVersion 0) 10 + let eventId = Vector.head sourceRows ^. #eventId + assertBlockedByGuard store target $ + runStoreIO store (linkToStream target [eventId]) - it "blocks soft delete and logical truncate until guard completion" $ - withTestStore $ \store -> do - let soft = StreamName "guard-soft-delete" - truncated = StreamName "guard-truncate" - Right _ <- runStoreIO store $ appendToStream soft NoStream (events 1) - Right _ <- runStoreIO store $ appendToStream truncated NoStream (events 2) - assertBlockedByGuard store soft $ - runStoreIO store (softDeleteStream soft) - assertBlockedByGuard store truncated $ - runStoreIO store (setStreamTruncateBefore truncated (StreamVersion 2)) + it "blocks soft delete and logical truncate until guard completion" $ + withTestStore $ \store -> do + let soft = StreamName "guard-soft-delete" + truncated = StreamName "guard-truncate" + Right _ <- runStoreIO store $ appendToStream soft NoStream (events 1) + Right _ <- runStoreIO store $ appendToStream truncated NoStream (events 2) + assertBlockedByGuard store soft $ + runStoreIO store (softDeleteStream soft) + assertBlockedByGuard store truncated $ + runStoreIO store (setStreamTruncateBefore truncated (StreamVersion 2)) - it "blocks hard delete of the guarded origin until guard completion" $ - withTestStore $ \store -> do - let stream = StreamName "guard-hard-delete" - Right _ <- runStoreIO store $ appendToStream stream NoStream (events 1) - assertBlockedByGuard store stream $ - runStoreIO store (hardDeleteStream stream) + it "blocks hard delete of the guarded origin until guard completion" $ + withTestStore $ \store -> do + let stream = StreamName "guard-hard-delete" + Right _ <- runStoreIO store $ appendToStream stream NoStream (events 1) + assertBlockedByGuard store stream $ + runStoreIO store (hardDeleteStream stream) - it "blocks hard delete of another origin linked into the guarded stream" $ - withTestStore $ \store -> do - let origin = StreamName "guard-linked-origin" - guarded = StreamName "guard-linked-target" - Right _ <- runStoreIO store $ appendToStream origin NoStream (events 1) - Right _ <- runStoreIO store $ appendToStream guarded NoStream (events 1) - Right sourceRows <- runStoreIO store $ readStreamForward origin (StreamVersion 0) 10 - Right _ <- runStoreIO store $ linkToStream guarded [Vector.head sourceRows ^. #eventId] - assertBlockedByGuard store guarded $ - runStoreIO store (hardDeleteStream origin) + it "blocks hard delete of another origin linked into the guarded stream" $ + withTestStore $ \store -> do + let origin = StreamName "guard-linked-origin" + guarded = StreamName "guard-linked-target" + Right _ <- runStoreIO store $ appendToStream origin NoStream (events 1) + Right _ <- runStoreIO store $ appendToStream guarded NoStream (events 1) + Right sourceRows <- runStoreIO store $ readStreamForward origin (StreamVersion 0) 10 + Right _ <- runStoreIO store $ linkToStream guarded [Vector.head sourceRows ^. #eventId] + assertBlockedByGuard store guarded $ + runStoreIO store (hardDeleteStream origin) - it "keeps opposing hard deletes and multi-stream appends deadlock-free" $ - withTestStore $ \store -> - forM_ [1 .. 5 :: Int] $ \index -> do - let suffix = Text.pack (show index) - first = StreamName ("guard-race-a-" <> suffix) - second = StreamName ("guard-race-b-" <> suffix) - Right _ <- runStoreIO store $ appendToStream first NoStream (events 1) - Right _ <- runStoreIO store $ appendToStream second NoStream (events 1) - operations <- - Async.async $ - Async.concurrently - (runStoreIO store $ hardDeleteStream first) - ( runStoreIO store $ - appendMultiStream - [ (first, AnyVersion, events 1) - , (second, AnyVersion, events 1) - ] - ) - _ <- waitWithin "hard-delete/multi-append race" operations - pure () + it "keeps opposing hard deletes and multi-stream appends deadlock-free" $ + withTestStore $ \store -> + forM_ [1 .. 5 :: Int] $ \index -> do + let suffix = Text.pack (show index) + first = StreamName ("guard-race-a-" <> suffix) + second = StreamName ("guard-race-b-" <> suffix) + Right _ <- runStoreIO store $ appendToStream first NoStream (events 1) + Right _ <- runStoreIO store $ appendToStream second NoStream (events 1) + operations <- + Async.async $ + Async.concurrently + (runStoreIO store $ hardDeleteStream first) + ( runStoreIO store $ + appendMultiStream + [ (first, AnyVersion, events 1), + (second, AnyVersion, events 1) + ] + ) + _ <- waitWithin "hard-delete/multi-append race" operations + pure () assertBlockedByGuard :: KirokuStore -> StreamName -> IO result -> IO () assertBlockedByGuard = assertBlockedByGuardEnding False assertBlockedByGuardEnding :: Bool -> KirokuStore -> StreamName -> IO result -> IO () assertBlockedByGuardEnding rollBack store stream mutation = do - guard <- Async.async $ runStoreIO store $ runTransaction $ do - locked <- lockStreamHistoryForReplayTx stream - _ <- Tx.statement () holdGuardStmt - when rollBack Tx.condemn - pure locked - waitForGuardPhase store 100 - waiter <- Async.async mutation - threadDelay 50_000 - Async.poll waiter >>= \case - Nothing -> pure () - Just _ -> expectationFailure "mutation completed while the stream-history guard was held" - guardResult <- waitWithin "guard transaction" guard - guardResult `shouldSatisfy` \case Right (Right _) -> True; _ -> False - _ <- waitWithin "blocked mutation" waiter - pure () + guard <- Async.async $ runStoreIO store $ runTransaction $ do + locked <- lockStreamHistoryForReplayTx stream + _ <- Tx.statement () holdGuardStmt + when rollBack Tx.condemn + pure locked + waitForGuardPhase store 100 + waiter <- Async.async mutation + threadDelay 50_000 + Async.poll waiter >>= \case + Nothing -> pure () + Just _ -> expectationFailure "mutation completed while the stream-history guard was held" + guardResult <- waitWithin "guard transaction" guard + guardResult `shouldSatisfy` \case Right (Right _) -> True; _ -> False + _ <- waitWithin "blocked mutation" waiter + pure () waitForGuardPhase :: KirokuStore -> Int -> IO () waitForGuardPhase _ 0 = expectationFailure "guard never reached its held phase" waitForGuardPhase store attempts = do - result <- Pool.use (store ^. #pool) (Session.statement () guardActiveStmt) - case result of - Right True -> pure () - Right False -> threadDelay 10_000 >> waitForGuardPhase store (attempts - 1) - Left err -> expectationFailure ("could not observe guard phase: " <> show err) + result <- Pool.use (store ^. #pool) (Session.statement () guardActiveStmt) + case result of + Right True -> pure () + Right False -> threadDelay 10_000 >> waitForGuardPhase store (attempts - 1) + Left err -> expectationFailure ("could not observe guard phase: " <> show err) waitWithin :: String -> Async.Async value -> IO value waitWithin label action = do - result <- Async.race (threadDelay 2_000_000) (Async.wait action) - case result of - Left () -> do - Async.cancel action - expectationFailure (label <> " timed out") - error "unreachable" - Right value -> pure value + result <- Async.race (threadDelay 2_000_000) (Async.wait action) + case result of + Left () -> do + Async.cancel action + expectationFailure (label <> " timed out") + error "unreachable" + Right value -> pure value runTx :: KirokuStore -> Tx.Transaction value -> IO value runTx store transaction = do - result <- runStoreIO store (runTransaction transaction) - case result of - Left err -> expectationFailure ("guard transaction failed: " <> show err) >> error "unreachable" - Right value -> pure value + result <- runStoreIO store (runTransaction transaction) + case result of + Left err -> expectationFailure ("guard transaction failed: " <> show err) >> error "unreachable" + Right value -> pure value events :: Int -> [EventData] events count = - [makeEvent "Guarded" (Aeson.object [("n", Aeson.toJSON n)]) | n <- [1 .. count]] + [makeEvent "Guarded" (Aeson.object [("n", Aeson.toJSON n)]) | n <- [1 .. count]] holdGuardStmt :: Statement () Bool holdGuardStmt = - preparable - "SELECT pg_sleep(0.4) IS NULL" - E.noParams - (D.singleRow (D.column (D.nonNullable D.bool))) + preparable + "SELECT pg_sleep(0.4) IS NULL" + E.noParams + (D.singleRow (D.column (D.nonNullable D.bool))) guardActiveStmt :: Statement () Bool guardActiveStmt = - preparable - """ - SELECT EXISTS ( - SELECT 1 - FROM pg_stat_activity - WHERE state = 'active' - AND query = 'SELECT pg_sleep(0.4) IS NULL' - ) - """ - E.noParams - (D.singleRow (D.column (D.nonNullable D.bool))) + preparable + """ + SELECT EXISTS ( + SELECT 1 + FROM pg_stat_activity + WHERE state = 'active' + AND query = 'SELECT pg_sleep(0.4) IS NULL' + ) + """ + E.noParams + (D.singleRow (D.column (D.nonNullable D.bool))) diff --git a/test/Test/StreamNameLookup.hs b/test/Test/StreamNameLookup.hs --- a/test/Test/StreamNameLookup.hs +++ b/test/Test/StreamNameLookup.hs @@ -1,8 +1,7 @@ -{- | 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). --} +-- | 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, noOpSpec) where import Control.Lens ((^.)) @@ -17,65 +16,65 @@ spec :: Spec spec = describe "lookupStreamNames / lookupStreamName" $ do - around withTestStore $ 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") + around withTestStore $ 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 "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 "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 + 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 noOpSpec :: Spec noOpSpec = - describe "empty stream-name lookup" $ - it "short-circuits empty input without a pool checkout" $ do - ref <- newIORef (0 :: Int) - let handler (ConnectionObservation _ InUseConnectionStatus) = - modifyIORef' ref (+ 1) - handler _ = - pure () - withTestStoreSettings (\settings -> settings{observationHandler = Just handler}) $ \store -> do - Right appendResult <- - runStoreIO store $ - appendToStream (StreamName "lookup-count-1") NoStream [makeEvent "LookupCounted" (Aeson.object [])] - waitForPublisher store (appendResult ^. #globalPosition) - Right (Just sid) <- runStoreIO store $ lookupStreamId (StreamName "lookup-count-1") + describe "empty stream-name lookup" $ + it "short-circuits empty input without a pool checkout" $ do + ref <- newIORef (0 :: Int) + let handler (ConnectionObservation _ InUseConnectionStatus) = + modifyIORef' ref (+ 1) + handler _ = + pure () + withTestStoreSettings (\settings -> settings {observationHandler = Just handler}) $ \store -> do + Right appendResult <- + runStoreIO store $ + appendToStream (StreamName "lookup-count-1") NoStream [makeEvent "LookupCounted" (Aeson.object [])] + waitForPublisher store (appendResult ^. #globalPosition) + Right (Just sid) <- runStoreIO store $ lookupStreamId (StreamName "lookup-count-1") - beforeEmpty <- readIORef ref - Right emptyNames <- runStoreIO store $ lookupStreamNames [] - afterEmpty <- readIORef ref - emptyNames `shouldBe` Map.empty - afterEmpty - beforeEmpty `shouldBe` 0 + beforeEmpty <- readIORef ref + Right emptyNames <- runStoreIO store $ lookupStreamNames [] + afterEmpty <- readIORef ref + emptyNames `shouldBe` Map.empty + afterEmpty - beforeEmpty `shouldBe` 0 - beforeReal <- readIORef ref - Right names <- runStoreIO store $ lookupStreamNames [sid] - afterReal <- readIORef ref - names `shouldBe` Map.singleton sid (StreamName "lookup-count-1") - afterReal - beforeReal `shouldBe` 1 + beforeReal <- readIORef ref + Right names <- runStoreIO store $ lookupStreamNames [sid] + afterReal <- readIORef ref + names `shouldBe` Map.singleton sid (StreamName "lookup-count-1") + afterReal - beforeReal `shouldBe` 1 diff --git a/test/Test/SubscriptionCheckpointInitialization.hs b/test/Test/SubscriptionCheckpointInitialization.hs --- a/test/Test/SubscriptionCheckpointInitialization.hs +++ b/test/Test/SubscriptionCheckpointInitialization.hs @@ -3,134 +3,265 @@ module Test.SubscriptionCheckpointInitialization (spec) where +import Control.Concurrent (threadDelay) import Control.Concurrent.Async qualified as Async +import Control.Exception (bracket, finally) +import Control.Lens ((^.)) +import Control.Monad (forM_) import Data.Aeson qualified as Aeson +import Data.Generics.Labels () import Data.Int (Int32) import Data.Text (Text) import Data.Text qualified as T import Data.Vector qualified as V import Effectful (runEff) import Effectful.Error.Static (runErrorNoCallStack) +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 Hasql.Transaction qualified as Tx +import Hasql.Transaction.Sessions qualified as TxSessions import Kiroku.Store -import Test.Helpers (makeEvent, withTestStore) +import Kiroku.Test.Postgres (withMigratedTestDatabase) +import System.Timeout (timeout) +import Test.Helpers (makeEvent, validConsumerGroup, withTestStore) import Test.Hspec spec :: Spec spec = describe "subscription checkpoint initialization" $ do - it "materializes position zero for FromBeginning" $ - withTestStore $ \store -> do - let name = SubscriptionName "initialize-from-beginning" - key = SubscriptionCheckpointKey name 0 - result <- initialize store name 0 FromBeginning - result `shouldBe` Right (InitializedCheckpoint FromBeginning key (GlobalPosition 0)) - inventoryKeys <$> inventory store `shouldReturn` [(name, 0, GlobalPosition 0)] + it "materializes position zero for FromBeginning" $ + withTestStore $ \store -> do + let name = SubscriptionName "initialize-from-beginning" + key = SubscriptionCheckpointKey name 0 + result <- initialize store name 0 FromBeginning + result `shouldBe` Right (InitializedCheckpoint FromBeginning key (GlobalPosition 0)) + inventoryKeys <$> inventory store `shouldReturn` [(name, 0, GlobalPosition 0)] + topology store `shouldReturn` [(0, 1, "unbound", Nothing)] - it "atomically materializes the current store head for FromCurrentHead" $ - withTestStore $ \store -> do - appendEvents store "initialize-current-head-events" 3 - let name = SubscriptionName "initialize-current-head" - key = SubscriptionCheckpointKey name 0 - result <- initialize store name 0 FromCurrentHead - result `shouldBe` Right (InitializedCheckpoint FromCurrentHead key (GlobalPosition 3)) - inventoryKeys <$> inventory store `shouldReturn` [(name, 0, GlobalPosition 3)] + it "atomically materializes the current store head for FromCurrentHead" $ + withTestStore $ \store -> do + appendEvents store "initialize-current-head-events" 3 + let name = SubscriptionName "initialize-current-head" + key = SubscriptionCheckpointKey name 0 + result <- initialize store name 0 FromCurrentHead + result `shouldBe` Right (InitializedCheckpoint FromCurrentHead key (GlobalPosition 3)) + inventoryKeys <$> inventory store `shouldReturn` [(name, 0, GlobalPosition 3)] - it "returns a typed missing result without creating a row for FailIfMissing" $ - withTestStore $ \store -> do - let name = SubscriptionName "initialize-fail-if-missing" - key = SubscriptionCheckpointKey name 0 - result <- initialize store name 0 FailIfMissing - result `shouldBe` Left (SubscriptionCheckpointMissing key) - inventoryKeys <$> inventory store `shouldReturn` [] + it "returns a typed missing result without creating a row for FailIfMissing" $ + withTestStore $ \store -> do + let name = SubscriptionName "initialize-fail-if-missing" + key = SubscriptionCheckpointKey name 0 + result <- initialize store name 0 FailIfMissing + result `shouldBe` Left (SubscriptionCheckpointMissing key) + inventoryKeys <$> inventory store `shouldReturn` [] - it "preserves an existing row for every configured policy" $ - withTestStore $ \store -> do - appendEvents store "initialize-existing-events" 5 - let name = SubscriptionName "initialize-existing" - key = SubscriptionCheckpointKey name 0 - initialize store name 0 FromCurrentHead - `shouldReturn` Right (InitializedCheckpoint FromCurrentHead key (GlobalPosition 5)) - mapM_ (assertExisting store key) [FromBeginning, FromCurrentHead, FailIfMissing] - inventoryKeys <$> inventory store `shouldReturn` [(name, 0, GlobalPosition 5)] + it "preserves an existing row for every configured policy" $ + withTestStore $ \store -> do + appendEvents store "initialize-existing-events" 5 + let name = SubscriptionName "initialize-existing" + key = SubscriptionCheckpointKey name 0 + initialize store name 0 FromCurrentHead + `shouldReturn` Right (InitializedCheckpoint FromCurrentHead key (GlobalPosition 5)) + mapM_ (assertExisting store key) [FromBeginning, FromCurrentHead, FailIfMissing] + inventoryKeys <$> inventory store `shouldReturn` [(name, 0, GlobalPosition 5)] - it "isolates checkpoint initialization by consumer-group member" $ - withTestStore $ \store -> do - appendEvents store "initialize-member-events" 4 - let name = SubscriptionName "initialize-members" - initialize store name 0 FromBeginning - `shouldReturn` Right (InitializedCheckpoint FromBeginning (SubscriptionCheckpointKey name 0) (GlobalPosition 0)) - initialize store name 1 FromCurrentHead - `shouldReturn` Right (InitializedCheckpoint FromCurrentHead (SubscriptionCheckpointKey name 1) (GlobalPosition 4)) - inventoryKeys <$> inventory store - `shouldReturn` [ (name, 0, GlobalPosition 0) - , (name, 1, GlobalPosition 4) - ] + it "isolates checkpoint initialization by consumer-group member" $ + withTestStore $ \store -> do + appendEvents store "initialize-member-events" 4 + let name = SubscriptionName "initialize-members" + initialize store name 0 FromBeginning + `shouldReturn` Right (InitializedCheckpoint FromBeginning (SubscriptionCheckpointKey name 0) (GlobalPosition 0)) + initialize store name 1 FromCurrentHead + `shouldReturn` Right (InitializedCheckpoint FromCurrentHead (SubscriptionCheckpointKey name 1) (GlobalPosition 4)) + inventoryKeys <$> inventory store + `shouldReturn` [ (name, 0, GlobalPosition 0), + (name, 1, GlobalPosition 4) + ] - it "converges concurrent initializers on one durable winner" $ - withTestStore $ \store -> do - appendEvents store "initialize-race-events" 7 - let name = SubscriptionName "initialize-race" - policies = take 20 (cycle [FromBeginning, FromCurrentHead]) - results <- Async.mapConcurrently (initialize store name 3) policies - let successes = [initialization | Right initialization <- results] - positions = fmap checkpointInitializationPosition successes - initializedCount = length [() | InitializedCheckpoint{} <- successes] - length successes `shouldBe` length policies - initializedCount `shouldBe` 1 - positions `shouldSatisfy` \case - [] -> False - first : rest -> all (== first) rest - case positions of - [] -> expectationFailure "expected concurrent initialization results" - winner : _ -> - inventoryKeys <$> inventory store - `shouldReturn` [(name, 3, winner)] + it "converges concurrent initializers on one durable winner" $ + withTestStore $ \store -> do + appendEvents store "initialize-race-events" 7 + let name = SubscriptionName "initialize-race" + policies = take 20 (cycle [FromBeginning, FromCurrentHead]) + results <- Async.mapConcurrently (initialize store name 3) policies + let successes = [initialization | Right initialization <- results] + positions = fmap checkpointInitializationPosition successes + initializedCount = length [() | InitializedCheckpoint {} <- successes] + length successes `shouldBe` length policies + initializedCount `shouldBe` 1 + positions `shouldSatisfy` \case + [] -> False + first : rest -> all (== first) rest + case positions of + [] -> expectationFailure "expected concurrent initialization results" + winner : _ -> + inventoryKeys <$> inventory store + `shouldReturn` [(name, 3, winner)] - it "runs through the resource-backed Store interpreter" $ - withTestStore $ \store -> do - let name = SubscriptionName "initialize-resource" - key = SubscriptionCheckpointKey name 2 - result <- - runEff - . runErrorNoCallStack @StoreError - . runKirokuStoreWith store - . runStoreResource - $ initializeSubscriptionCheckpoint name 2 FromBeginning - result `shouldBe` Right (Right (InitializedCheckpoint FromBeginning key (GlobalPosition 0))) + it "initializes an absent member with sibling size and category binding, then starts under RequireBound" $ + withTestStore $ \store -> do + let name = SubscriptionName "initialize-bound" + target = Category (CategoryName "orders") + config memberIndex = + (defaultSubscriptionConfig name target (\_ -> pure Continue)) + { consumerGroup = Just (validConsumerGroup memberIndex 2), + targetBindingPolicy = RequireBound + } + withSubscription store (config 0) $ \handle -> awaitLive handle + topology store `shouldReturn` [(0, 2, "category", Just "orders")] + initialize store name 1 FromBeginning + `shouldReturn` Right (InitializedCheckpoint FromBeginning (SubscriptionCheckpointKey name 1) (GlobalPosition 0)) + topology store `shouldReturn` [(0, 2, "category", Just "orders"), (1, 2, "category", Just "orders")] + withSubscription store (config 1) $ \handle -> awaitLive handle + forM_ (["uniform-unbound", "mixed-size", "mixed-binding"] :: [Text]) $ \variant -> + it ("initializes with uniform topology or legacy defaults for " <> show variant) $ + withTestStore $ \store -> do + let secondSize = if variant == "mixed-size" then "3" else "2" + secondBinding = if variant == "mixed-binding" then "all" else "unbound" + runSession + store + ( Session.script + ("INSERT INTO subscriptions (subscription_name, consumer_group_member, consumer_group_size, last_seen, target_kind) VALUES ('initialize-fallback', 0, 2, 7, 'unbound'), ('initialize-fallback', 1, " <> secondSize <> ", 9, '" <> secondBinding <> "')") + ) + originalRows <- topology store + initialize store (SubscriptionName "initialize-fallback") 2 FromBeginning + `shouldReturn` Right (InitializedCheckpoint FromBeginning (SubscriptionCheckpointKey (SubscriptionName "initialize-fallback") 2) (GlobalPosition 0)) + initializedRows <- topology store + take 2 initializedRows `shouldBe` originalRows + drop 2 initializedRows `shouldBe` [(2, if variant == "uniform-unbound" then 2 else 1, "unbound", Nothing)] + + it "initializes after a concurrent rebind commits, waiting on the name lock before reading topology" $ + withMigratedTestDatabase $ \connStr -> withStore (defaultConnectionSettings connStr) $ \store -> + bracket + (Connection.acquire (Conn.connectionString connStr) >>= either (fail . show) pure) + Connection.release + $ \gate -> do + let name = SubscriptionName "initialize-rebind" + newTarget = Category (CategoryName "new-orders") + useGate session = Connection.use gate session >>= either (fail . show) pure + initialize store name 0 FromBeginning + `shouldReturn` Right (InitializedCheckpoint FromBeginning (SubscriptionCheckpointKey name 0) (GlobalPosition 0)) + -- The session lock is a test gate. Rebind blocks at the gate after + -- changing its rows, while still owning the transaction's name lock. + useGate (Session.script "SELECT pg_advisory_lock(103)") + ( Async.withAsync + ( runSession store $ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do + Tx.sql "SET LOCAL statement_timeout = '5s'" + report <- rebindSubscriptionTargetTx name newTarget (GlobalPosition 0) + Tx.sql "SELECT pg_advisory_xact_lock(103)" + pure report + ) + $ \rebinder -> do + within $ awaitQuery store gateWaitStmt + Async.withAsync (initialize store name 1 FromBeginning) $ \initializer -> do + ( do + within $ awaitQuery store topologyWaitStmt + useGate (Session.script "SELECT pg_advisory_unlock(103)") + _ <- within (Async.wait rebinder) + within (Async.wait initializer) + `shouldReturn` Right (InitializedCheckpoint FromBeginning (SubscriptionCheckpointKey name 1) (GlobalPosition 0)) + topology store `shouldReturn` [(0, 1, "category", Just "new-orders"), (1, 1, "category", Just "new-orders")] + ) + `finally` useGate (Session.script "SELECT pg_advisory_unlock_all()") + ) + `finally` useGate (Session.script "SELECT pg_advisory_unlock_all()") + + it "runs through the resource-backed Store interpreter" $ + withTestStore $ \store -> do + let name = SubscriptionName "initialize-resource" + key = SubscriptionCheckpointKey name 2 + result <- + runEff + . runErrorNoCallStack @StoreError + . runKirokuStoreWith store + . runStoreResource + $ initializeSubscriptionCheckpoint name 2 FromBeginning + result `shouldBe` Right (Right (InitializedCheckpoint FromBeginning key (GlobalPosition 0))) + assertExisting :: KirokuStore -> SubscriptionCheckpointKey -> MissingCheckpointPolicy -> IO () assertExisting store key@(SubscriptionCheckpointKey name member) policy = - initialize store name member policy - `shouldReturn` Right (ExistingCheckpoint key (GlobalPosition 5)) + initialize store name member policy + `shouldReturn` Right (ExistingCheckpoint key (GlobalPosition 5)) initialize :: - KirokuStore -> - SubscriptionName -> - Int32 -> - MissingCheckpointPolicy -> - IO (Either SubscriptionCheckpointMissing CheckpointInitialization) + KirokuStore -> + SubscriptionName -> + Int32 -> + MissingCheckpointPolicy -> + IO (Either SubscriptionCheckpointMissing CheckpointInitialization) initialize store name member policy = do - result <- runStoreIO store (initializeSubscriptionCheckpoint name member policy) - case result of - Left err -> expectationFailure ("checkpoint initialization failed: " <> show err) >> error "unreachable" - Right initialized -> pure initialized + result <- runStoreIO store (initializeSubscriptionCheckpoint name member policy) + case result of + Left err -> expectationFailure ("checkpoint initialization failed: " <> show err) >> error "unreachable" + Right initialized -> pure initialized inventory :: KirokuStore -> IO SubscriptionCheckpointInventory inventory store = do - result <- runStoreIO store subscriptionCheckpointInventory - case result of - Left err -> expectationFailure ("checkpoint inventory failed: " <> show err) >> error "unreachable" - Right rows -> pure rows + result <- runStoreIO store subscriptionCheckpointInventory + case result of + Left err -> expectationFailure ("checkpoint inventory failed: " <> show err) >> error "unreachable" + Right rows -> pure rows inventoryKeys :: SubscriptionCheckpointInventory -> [(SubscriptionName, Int32, GlobalPosition)] inventoryKeys (SubscriptionCheckpointInventory _ rows) = - [ (name, member, position) - | SubscriptionCheckpoint name member position _ <- V.toList rows - ] + [ (name, member, position) + | SubscriptionCheckpoint name member position _ <- V.toList rows + ] appendEvents :: KirokuStore -> Text -> Int -> IO () appendEvents store stream count = do - let events = [makeEvent ("Initialize" <> T.pack (show i)) (Aeson.object []) | i <- [1 .. count]] - result <- runStoreIO store $ appendToStream (StreamName stream) NoStream events - case result of - Left err -> expectationFailure ("append failed: " <> show err) - Right _ -> pure () + let events = [makeEvent ("Initialize" <> T.pack (show i)) (Aeson.object []) | i <- [1 .. count]] + result <- runStoreIO store $ appendToStream (StreamName stream) NoStream events + case result of + Left err -> expectationFailure ("append failed: " <> show err) + Right _ -> pure () + +within :: IO a -> IO a +within action = timeout 5_000_000 action >>= maybe (fail "checkpoint initialization test timed out") pure + +awaitLive :: SubscriptionHandle -> IO () +awaitLive handle = within loop + where + loop = + currentState handle >>= \case + Just state | stateName state == "live" -> pure () + _ -> threadDelay 1_000 >> loop + +runSession :: KirokuStore -> Session.Session a -> IO a +runSession store session = Pool.use (store ^. #pool) session >>= either (fail . show) pure + +topology :: KirokuStore -> IO [(Int32, Int32, Text, Maybe Text)] +topology store = V.toList <$> runSession store (Session.statement () stmt) + where + stmt = + preparable + "SELECT consumer_group_member, consumer_group_size, target_kind, target_category FROM subscriptions ORDER BY consumer_group_member" + E.noParams + (D.rowVector ((,,,) <$> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.text) <*> D.column (D.nullable D.text))) + +awaitQuery :: KirokuStore -> Statement () Bool -> IO () +awaitQuery store stmt = do + ready <- runSession store (Session.statement () stmt) + if ready then pure () else threadDelay 1_000 >> awaitQuery store stmt + +-- Only this test database participates; unrelated advisory locks cannot satisfy +-- either barrier. The second query observes the initializer blocked on a lock +-- held by the rebind transaction, which is itself waiting at the test gate. +gateWaitStmt :: Statement () Bool +gateWaitStmt = + preparable + "SELECT EXISTS (SELECT 1 FROM pg_locks WHERE locktype = 'advisory' AND NOT granted AND classid = 0 AND objid = 103 AND objsubid = 1 AND database = (SELECT oid FROM pg_database WHERE datname = current_database()))" + E.noParams + (D.singleRow (D.column (D.nonNullable D.bool))) + +topologyWaitStmt :: Statement () Bool +topologyWaitStmt = + preparable + "SELECT EXISTS (SELECT 1 FROM pg_locks waiting JOIN pg_locks held USING (locktype, database, classid, objid, objsubid) JOIN pg_locks gate ON gate.pid = held.pid WHERE waiting.locktype = 'advisory' AND NOT waiting.granted AND held.granted AND gate.locktype = 'advisory' AND NOT gate.granted AND gate.classid = 0 AND gate.objid = 103 AND gate.objsubid = 1 AND waiting.database = (SELECT oid FROM pg_database WHERE datname = current_database()))" + E.noParams + (D.singleRow (D.column (D.nonNullable D.bool))) diff --git a/test/Test/SubscriptionCheckpointInitializationMock.hs b/test/Test/SubscriptionCheckpointInitializationMock.hs --- a/test/Test/SubscriptionCheckpointInitializationMock.hs +++ b/test/Test/SubscriptionCheckpointInitializationMock.hs @@ -12,33 +12,33 @@ spec :: Spec spec = describe "subscription checkpoint initialization mock interpreter" $ do - it "carries the closed policy and typed result through one Store effect call" $ do - calls <- newIORef (0 :: Int) - let name = SubscriptionName "mock-initialization" - key = SubscriptionCheckpointKey name 4 - expected = Right (InitializedCheckpoint FromCurrentHead key (GlobalPosition 23)) - actual <- - runEff $ - runInitializationMock calls name 4 FromCurrentHead expected $ - initializeSubscriptionCheckpoint name 4 FromCurrentHead - actual `shouldBe` expected - readIORef calls `shouldReturn` 1 + it "carries the closed policy and typed result through one Store effect call" $ do + calls <- newIORef (0 :: Int) + let name = SubscriptionName "mock-initialization" + key = SubscriptionCheckpointKey name 4 + expected = Right (InitializedCheckpoint FromCurrentHead key (GlobalPosition 23)) + actual <- + runEff $ + runInitializationMock calls name 4 FromCurrentHead expected $ + initializeSubscriptionCheckpoint name 4 FromCurrentHead + actual `shouldBe` expected + readIORef calls `shouldReturn` 1 runInitializationMock :: - (IOE :> es) => - IORef Int -> - SubscriptionName -> - Int -> - MissingCheckpointPolicy -> - Either SubscriptionCheckpointMissing CheckpointInitialization -> - Eff (Store : es) a -> - Eff es a + (IOE :> es) => + IORef Int -> + SubscriptionName -> + Int -> + MissingCheckpointPolicy -> + Either SubscriptionCheckpointMissing CheckpointInitialization -> + Eff (Store : es) a -> + Eff es a runInitializationMock calls expectedName expectedMember expectedPolicy expected = interpret_ $ \case - InitializeSubscriptionCheckpoint actualName actualMember actualPolicy -> do - liftIO $ do - actualName `shouldBe` expectedName - fromIntegral actualMember `shouldBe` expectedMember - actualPolicy `shouldBe` expectedPolicy - modifyIORef' calls (+ 1) - pure expected - _ -> error "unexpected Store operation in checkpoint initialization mock" + InitializeSubscriptionCheckpoint actualName actualMember actualPolicy -> do + liftIO $ do + actualName `shouldBe` expectedName + fromIntegral actualMember `shouldBe` expectedMember + actualPolicy `shouldBe` expectedPolicy + modifyIORef' calls (+ 1) + pure expected + _ -> error "unexpected Store operation in checkpoint initialization mock" diff --git a/test/Test/SubscriptionCheckpointInventory.hs b/test/Test/SubscriptionCheckpointInventory.hs --- a/test/Test/SubscriptionCheckpointInventory.hs +++ b/test/Test/SubscriptionCheckpointInventory.hs @@ -29,216 +29,216 @@ spec :: Spec spec = describe "SubscriptionCheckpointInventory" $ do - it "returns position zero and no rows for an empty migrated store" $ - withTestStore $ \store -> do - inventory@(SubscriptionCheckpointInventory captured rows) <- readInventory store - captured `shouldBe` GlobalPosition 0 - rows `shouldBe` V.empty - assertSqlRelationMatchesInventory store inventory + it "returns position zero and no rows for an empty migrated store" $ + withTestStore $ \store -> do + inventory@(SubscriptionCheckpointInventory captured rows) <- readInventory store + captured `shouldBe` GlobalPosition 0 + rows `shouldBe` V.empty + assertSqlRelationMatchesInventory store inventory - it "runs through the resource-backed Store interpreter" $ - withTestStore $ \store -> do - result <- - runEff - . runErrorNoCallStack @StoreError - . runKirokuStoreWith store - . runStoreResource - $ subscriptionCheckpointInventory - result `shouldBe` Right (SubscriptionCheckpointInventory (GlobalPosition 0) V.empty) + it "runs through the resource-backed Store interpreter" $ + withTestStore $ \store -> do + result <- + runEff + . runErrorNoCallStack @StoreError + . runKirokuStoreWith store + . runStoreResource + $ subscriptionCheckpointInventory + result `shouldBe` Right (SubscriptionCheckpointInventory (GlobalPosition 0) V.empty) - it "returns the exact store position and a member-zero checkpoint" $ - withTestStore $ \store -> do - appendEvents store "inventory-single" 3 - saveCheckpoint store "single" 0 2 + it "returns the exact store position and a member-zero checkpoint" $ + withTestStore $ \store -> do + appendEvents store "inventory-single" 3 + saveCheckpoint store "single" 0 2 - SubscriptionCheckpointInventory captured rows <- readInventory store - captured `shouldBe` GlobalPosition 3 - checkpointKeys rows `shouldBe` [("single", 0, 2)] - now <- getCurrentTime - case V.toList rows of - [SubscriptionCheckpoint _ _ _ updatedAt] -> updatedAt `shouldSatisfy` (<= now) - _ -> expectationFailure "expected exactly one checkpoint" + SubscriptionCheckpointInventory captured rows <- readInventory store + captured `shouldBe` GlobalPosition 3 + checkpointKeys rows `shouldBe` [("single", 0, 2)] + now <- getCurrentTime + case V.toList rows of + [SubscriptionCheckpoint _ _ _ updatedAt] -> updatedAt `shouldSatisfy` (<= now) + _ -> expectationFailure "expected exactly one checkpoint" - it "returns multiple names and members in deterministic key order" $ - withTestStore $ \store -> do - appendEvents store "inventory-many" 20 - saveCheckpoint store "zeta" 2 7 - saveCheckpoint store "alpha" 10 3 - saveCheckpoint store "alpha" 2 5 + it "returns multiple names and members in deterministic key order" $ + withTestStore $ \store -> do + appendEvents store "inventory-many" 20 + saveCheckpoint store "zeta" 2 7 + saveCheckpoint store "alpha" 10 3 + saveCheckpoint store "alpha" 2 5 - inventory@(SubscriptionCheckpointInventory captured rows) <- readInventory store - captured `shouldBe` GlobalPosition 20 - checkpointKeys rows - `shouldBe` [ ("alpha", 2, 5) - , ("alpha", 10, 3) - , ("zeta", 2, 7) - ] - assertSqlRelationMatchesInventory store inventory + inventory@(SubscriptionCheckpointInventory captured rows) <- readInventory store + captured `shouldBe` GlobalPosition 20 + checkpointKeys rows + `shouldBe` [ ("alpha", 2, 5), + ("alpha", 10, 3), + ("zeta", 2, 7) + ] + assertSqlRelationMatchesInventory store inventory - it "preserves monotonic checkpoints and observes later commits on a fresh read" $ - withTestStore $ \store -> do - appendEvents store "inventory-monotonic" 10 - saveCheckpoint store "monotonic" 0 8 - saveCheckpoint store "monotonic" 0 4 + it "preserves monotonic checkpoints and observes later commits on a fresh read" $ + withTestStore $ \store -> do + appendEvents store "inventory-monotonic" 10 + saveCheckpoint store "monotonic" 0 8 + saveCheckpoint store "monotonic" 0 4 - first <- readInventory store - inventoryKeys first `shouldBe` [("monotonic", 0, 8)] + first <- readInventory store + inventoryKeys first `shouldBe` [("monotonic", 0, 8)] - saveCheckpoint store "monotonic" 0 9 - second <- readInventory store - inventoryKeys second `shouldBe` [("monotonic", 0, 9)] + saveCheckpoint store "monotonic" 0 9 + second <- readInventory store + inventoryKeys second `shouldBe` [("monotonic", 0, 9)] - it "retains a durable row after the worker stops and leaves live state" $ - withTestStore $ \store -> do - appendEvents store "inventory-stopped" 1 - waitForPublisher store (GlobalPosition 1) - let name = SubscriptionName "stopped" - handle <- subscribe store (defaultSubscriptionConfig name AllStreams (\_ -> pure Stop)) - waitClean handle + it "retains a durable row after the worker stops and leaves live state" $ + withTestStore $ \store -> do + appendEvents store "inventory-stopped" 1 + waitForPublisher store (GlobalPosition 1) + let name = SubscriptionName "stopped" + handle <- subscribe store (defaultSubscriptionConfig name AllStreams (\_ -> pure Stop)) + waitClean handle - states <- subscriptionStates store - Map.member (name, 0) states `shouldBe` False - inventory <- readInventory store - inventoryKeys inventory `shouldBe` [("stopped", 0, 1)] - assertSqlRelationMatchesInventory store inventory + states <- subscriptionStates store + Map.member (name, 0) states `shouldBe` False + inventory <- readInventory store + inventoryKeys inventory `shouldBe` [("stopped", 0, 1)] + assertSqlRelationMatchesInventory store inventory - it "does not expose in-flight live handler progress before checkpoint commit" $ do - caughtUp <- newEmptyMVar - enteredHandler <- newEmptyMVar - releaseHandler <- newEmptyMVar - let name = SubscriptionName "in-flight" - observe = caughtUpEventHandler name caughtUp Nothing - handler _ = do - putMVar enteredHandler () - takeMVar releaseHandler - pure Stop - config = defaultSubscriptionConfig name AllStreams handler - withTestStoreSettings (& #eventHandler .~ Just observe) $ \store -> do - appendEvents store "inventory-live" 1 - saveCheckpoint store "in-flight" 0 1 - waitForPublisher store (GlobalPosition 1) - handle <- subscribe store config - waitForSubscriptionLive caughtUp + it "does not expose in-flight live handler progress before checkpoint commit" $ do + caughtUp <- newEmptyMVar + enteredHandler <- newEmptyMVar + releaseHandler <- newEmptyMVar + let name = SubscriptionName "in-flight" + observe = caughtUpEventHandler name caughtUp Nothing + handler _ = do + putMVar enteredHandler () + takeMVar releaseHandler + pure Stop + config = defaultSubscriptionConfig name AllStreams handler + withTestStoreSettings (& #eventHandler .~ Just observe) $ \store -> do + appendEvents store "inventory-live" 1 + saveCheckpoint store "in-flight" 0 1 + waitForPublisher store (GlobalPosition 1) + handle <- subscribe store config + waitForSubscriptionLive caughtUp - appendEventsExisting store "inventory-live" 1 - waitForMVar "live handler did not receive the event" enteredHandler - beforeCommit <- readInventory store - inventoryKeys beforeCommit `shouldBe` [("in-flight", 0, 1)] - assertSqlRelationMatchesInventory store beforeCommit + appendEventsExisting store "inventory-live" 1 + waitForMVar "live handler did not receive the event" enteredHandler + beforeCommit <- readInventory store + inventoryKeys beforeCommit `shouldBe` [("in-flight", 0, 1)] + assertSqlRelationMatchesInventory store beforeCommit - putMVar releaseHandler () - waitClean handle - afterCommit <- readInventory store - inventoryKeys afterCommit `shouldBe` [("in-flight", 0, 2)] - assertSqlRelationMatchesInventory store afterCommit + putMVar releaseHandler () + waitClean handle + afterCommit <- readInventory store + inventoryKeys afterCommit `shouldBe` [("in-flight", 0, 2)] + assertSqlRelationMatchesInventory store afterCommit - it "observes the checkpoint advanced by a dead-letter transaction" $ - withTestStore $ \store -> do - appendEvents store "inventory-dead-letter" 1 - Right events <- runStoreIO store $ readAllForward (GlobalPosition 0) 10 - let event = V.head events - insertDeadLetterForEvent store "dead-lettered" event + it "observes the checkpoint advanced by a dead-letter transaction" $ + withTestStore $ \store -> do + appendEvents store "inventory-dead-letter" 1 + Right events <- runStoreIO store $ readAllForward (GlobalPosition 0) 10 + let event = V.head events + insertDeadLetterForEvent store "dead-lettered" event - inventory <- readInventory store - inventoryKeys inventory `shouldBe` [("dead-lettered", 0, 1)] + inventory <- readInventory store + inventoryKeys inventory `shouldBe` [("dead-lettered", 0, 1)] - it "captures a head at or beyond every normally written checkpoint" $ - withTestStore $ \store -> do - appendEvents store "inventory-bounds" 6 - saveCheckpoint store "bounds-a" 0 2 - saveCheckpoint store "bounds-b" 1 6 + it "captures a head at or beyond every normally written checkpoint" $ + withTestStore $ \store -> do + appendEvents store "inventory-bounds" 6 + saveCheckpoint store "bounds-a" 0 2 + saveCheckpoint store "bounds-b" 1 6 - SubscriptionCheckpointInventory (GlobalPosition captured) rows <- readInventory store - let positions = [position | SubscriptionCheckpoint _ _ (GlobalPosition position) _ <- V.toList rows] - positions `shouldSatisfy` all (<= captured) + SubscriptionCheckpointInventory (GlobalPosition captured) rows <- readInventory store + let positions = [position | SubscriptionCheckpoint _ _ (GlobalPosition position) _ <- V.toList rows] + positions `shouldSatisfy` all (<= captured) readInventory :: KirokuStore -> IO SubscriptionCheckpointInventory readInventory store = do - result <- runStoreIO store subscriptionCheckpointInventory - case result of - Left err -> error ("subscriptionCheckpointInventory failed: " <> show err) - Right inventory -> pure inventory + result <- runStoreIO store subscriptionCheckpointInventory + case result of + Left err -> error ("subscriptionCheckpointInventory failed: " <> show err) + Right inventory -> pure inventory saveCheckpoint :: KirokuStore -> Text -> Int32 -> Int64 -> IO () saveCheckpoint store name member position = do - result <- Pool.use (store ^. #pool) $ Session.statement (name, member, position, max 1 (member + 1), "unbound", Nothing) SQL.saveCheckpointMemberStmt - case result of - Left err -> error ("saveCheckpoint failed: " <> show err) - Right () -> pure () + result <- Pool.use (store ^. #pool) $ Session.statement (name, member, position, max 1 (member + 1), "unbound", Nothing) SQL.saveCheckpointMemberStmt + case result of + Left err -> error ("saveCheckpoint failed: " <> show err) + Right () -> pure () appendEvents :: KirokuStore -> Text -> Int -> IO () appendEvents store stream count = do - let events = [makeEvent ("E" <> T.pack (show i)) (Aeson.object []) | i <- [1 .. count]] - result <- runStoreIO store $ appendToStream (StreamName stream) NoStream events - case result of - Left err -> error ("appendEvents failed: " <> show err) - Right _ -> pure () + let events = [makeEvent ("E" <> T.pack (show i)) (Aeson.object []) | i <- [1 .. count]] + result <- runStoreIO store $ appendToStream (StreamName stream) NoStream events + case result of + Left err -> error ("appendEvents failed: " <> show err) + Right _ -> pure () appendEventsExisting :: KirokuStore -> Text -> Int -> IO () appendEventsExisting store stream count = do - let events = [makeEvent ("Live" <> T.pack (show i)) (Aeson.object []) | i <- [1 .. count]] - result <- runStoreIO store $ appendToStream (StreamName stream) StreamExists events - case result of - Left err -> error ("appendEventsExisting failed: " <> show err) - Right _ -> pure () + let events = [makeEvent ("Live" <> T.pack (show i)) (Aeson.object []) | i <- [1 .. count]] + result <- runStoreIO store $ appendToStream (StreamName stream) StreamExists events + case result of + Left err -> error ("appendEventsExisting failed: " <> show err) + Right _ -> pure () waitClean :: SubscriptionHandle -> IO () waitClean handle = do - result <- waitWithTimeout 20_000_000 handle - case result of - Left message -> expectationFailure message - Right (Left err) -> expectationFailure ("subscription failed: " <> show err) - Right (Right ()) -> pure () + result <- waitWithTimeout 20_000_000 handle + case result of + Left message -> expectationFailure message + Right (Left err) -> expectationFailure ("subscription failed: " <> show err) + Right (Right ()) -> pure () waitForMVar :: String -> MVar () -> IO () waitForMVar failureMessage var = do - result <- timeout 5_000_000 (takeMVar var) - case result of - Nothing -> expectationFailure failureMessage - Just () -> pure () + result <- timeout 5_000_000 (takeMVar var) + case result of + Nothing -> expectationFailure failureMessage + Just () -> pure () inventoryKeys :: SubscriptionCheckpointInventory -> [(Text, Int32, Int64)] inventoryKeys (SubscriptionCheckpointInventory _ rows) = checkpointKeys rows checkpointKeys :: V.Vector SubscriptionCheckpoint -> [(Text, Int32, Int64)] checkpointKeys rows = - [ (name, member, position) - | SubscriptionCheckpoint (SubscriptionName name) member (GlobalPosition position) _ <- V.toList rows - ] + [ (name, member, position) + | SubscriptionCheckpoint (SubscriptionName name) member (GlobalPosition position) _ <- V.toList rows + ] assertSqlRelationMatchesInventory :: KirokuStore -> SubscriptionCheckpointInventory -> Expectation assertSqlRelationMatchesInventory store (SubscriptionCheckpointInventory _ inventoryRows) = do - result <- Pool.use (store ^. #pool) $ Session.statement () subscriptionCheckpointRelationStmt - case result of - Left err -> expectationFailure ("subscription checkpoint relation failed: " <> show err) - Right sqlRows -> - sqlRows - `shouldBe` [ (name, member, position, updatedAt) - | SubscriptionCheckpoint - (SubscriptionName name) - member - (GlobalPosition position) - updatedAt <- - V.toList inventoryRows - ] + result <- Pool.use (store ^. #pool) $ Session.statement () subscriptionCheckpointRelationStmt + case result of + Left err -> expectationFailure ("subscription checkpoint relation failed: " <> show err) + Right sqlRows -> + sqlRows + `shouldBe` [ (name, member, position, updatedAt) + | SubscriptionCheckpoint + (SubscriptionName name) + member + (GlobalPosition position) + updatedAt <- + V.toList inventoryRows + ] subscriptionCheckpointRelationStmt :: Statement () [(Text, Int32, Int64, UTCTime)] subscriptionCheckpointRelationStmt = - preparable - """ - SELECT subscription_name, - consumer_group_member, - checkpoint_position, - checkpoint_updated_at - FROM kiroku.subscription_checkpoints_v1 - ORDER BY subscription_name, consumer_group_member - """ - E.noParams - ( D.rowList - ( (,,,) - <$> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.int4) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nonNullable D.timestamptz) - ) + preparable + """ + SELECT subscription_name, + consumer_group_member, + checkpoint_position, + checkpoint_updated_at + FROM kiroku.subscription_checkpoints_v1 + ORDER BY subscription_name, consumer_group_member + """ + E.noParams + ( D.rowList + ( (,,,) + <$> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.int4) + <*> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.timestamptz) ) + ) diff --git a/test/Test/SubscriptionCheckpointInventoryMock.hs b/test/Test/SubscriptionCheckpointInventoryMock.hs --- a/test/Test/SubscriptionCheckpointInventoryMock.hs +++ b/test/Test/SubscriptionCheckpointInventoryMock.hs @@ -15,31 +15,31 @@ spec :: Spec spec = describe "SubscriptionCheckpointInventory mock interpreter" $ do - it "returns a public inventory through one Store effect call" $ do - calls <- newIORef (0 :: Int) - let updatedAt = UTCTime (fromGregorian 2026 8 9) 0 - expected = - SubscriptionCheckpointInventory - (GlobalPosition 17) - ( V.singleton $ - SubscriptionCheckpoint - (SubscriptionName "mock") - 3 - (GlobalPosition 11) - updatedAt - ) - actual <- runEff $ runInventoryMock calls expected subscriptionCheckpointInventory - actual `shouldBe` expected - readIORef calls `shouldReturn` 1 + it "returns a public inventory through one Store effect call" $ do + calls <- newIORef (0 :: Int) + let updatedAt = UTCTime (fromGregorian 2026 8 9) 0 + expected = + SubscriptionCheckpointInventory + (GlobalPosition 17) + ( V.singleton $ + SubscriptionCheckpoint + (SubscriptionName "mock") + 3 + (GlobalPosition 11) + updatedAt + ) + actual <- runEff $ runInventoryMock calls expected subscriptionCheckpointInventory + actual `shouldBe` expected + readIORef calls `shouldReturn` 1 runInventoryMock :: - (IOE :> es) => - IORef Int -> - SubscriptionCheckpointInventory -> - Eff (Store : es) a -> - Eff es a + (IOE :> es) => + IORef Int -> + SubscriptionCheckpointInventory -> + Eff (Store : es) a -> + Eff es a runInventoryMock calls expected = interpret_ $ \case - GetSubscriptionCheckpointInventory -> do - liftIO $ modifyIORef' calls (+ 1) - pure expected - _ -> error "unexpected Store operation in inventory mock" + GetSubscriptionCheckpointInventory -> do + liftIO $ modifyIORef' calls (+ 1) + pure expected + _ -> error "unexpected Store operation in inventory mock" diff --git a/test/Test/SubscriptionCheckpointReset.hs b/test/Test/SubscriptionCheckpointReset.hs --- a/test/Test/SubscriptionCheckpointReset.hs +++ b/test/Test/SubscriptionCheckpointReset.hs @@ -24,190 +24,190 @@ spec :: Spec spec = describe "subscription checkpoint reset" $ do - it "commits every persisted member and reports sorted affected and missing names exactly" $ - withTestStore $ \store -> do - appendEvents store "reset-commit-events" 10 - initializeRows store [("zeta", 1), ("alpha", 2), ("alpha", 0)] - createSentinelTable store + it "commits every persisted member and reports sorted affected and missing names exactly" $ + withTestStore $ \store -> do + appendEvents store "reset-commit-events" 10 + initializeRows store [("zeta", 1), ("alpha", 2), ("alpha", 0)] + createSentinelTable store - result <- runStoreIO store $ runTransaction $ do - Tx.statement (1, "committed") insertSentinelStmt - resetSubscriptionCheckpointsTx - ( SubscriptionName "zeta" - :| [ SubscriptionName "missing" - , SubscriptionName "alpha" - , SubscriptionName "alpha" - ] - ) - (GlobalPosition 7) + result <- runStoreIO store $ runTransaction $ do + Tx.statement (1, "committed") insertSentinelStmt + resetSubscriptionCheckpointsTx + ( SubscriptionName "zeta" + :| [ SubscriptionName "missing", + SubscriptionName "alpha", + SubscriptionName "alpha" + ] + ) + (GlobalPosition 7) - result - `shouldBe` Right - SubscriptionCheckpointResetReport - { resetCheckpointKeys = - Vector.fromList - [ SubscriptionCheckpointKey (SubscriptionName "alpha") 0 - , SubscriptionCheckpointKey (SubscriptionName "alpha") 2 - , SubscriptionCheckpointKey (SubscriptionName "zeta") 1 - ] - , missingSubscriptionNames = Vector.singleton (SubscriptionName "missing") - } - countSentinels store `shouldReturn` 1 - inventoryKeys <$> inventory store - `shouldReturn` [ ("alpha", 0, 7) - , ("alpha", 2, 7) - , ("zeta", 1, 7) - ] + result + `shouldBe` Right + SubscriptionCheckpointResetReport + { resetCheckpointKeys = + Vector.fromList + [ SubscriptionCheckpointKey (SubscriptionName "alpha") 0, + SubscriptionCheckpointKey (SubscriptionName "alpha") 2, + SubscriptionCheckpointKey (SubscriptionName "zeta") 1 + ], + missingSubscriptionNames = Vector.singleton (SubscriptionName "missing") + } + countSentinels store `shouldReturn` 1 + inventoryKeys <$> inventory store + `shouldReturn` [ ("alpha", 0, 7), + ("alpha", 2, 7), + ("zeta", 1, 7) + ] - it "rolls back the reset and an application-table write when the transaction is condemned" $ - withTestStore $ \store -> do - appendEvents store "reset-rollback-events" 10 - initializeRows store [("rollback", 0)] - _ <- reset store (SubscriptionName "rollback" :| []) (GlobalPosition 9) - createSentinelTable store + it "rolls back the reset and an application-table write when the transaction is condemned" $ + withTestStore $ \store -> do + appendEvents store "reset-rollback-events" 10 + initializeRows store [("rollback", 0)] + _ <- reset store (SubscriptionName "rollback" :| []) (GlobalPosition 9) + createSentinelTable store - result <- runStoreIO store $ runTransaction $ do - Tx.statement (2, "rolled back") insertSentinelStmt - report <- - resetSubscriptionCheckpointsTx - (SubscriptionName "rollback" :| []) - (GlobalPosition 3) - Tx.condemn - pure report + result <- runStoreIO store $ runTransaction $ do + Tx.statement (2, "rolled back") insertSentinelStmt + report <- + resetSubscriptionCheckpointsTx + (SubscriptionName "rollback" :| []) + (GlobalPosition 3) + Tx.condemn + pure report - result - `shouldBe` Right - SubscriptionCheckpointResetReport - { resetCheckpointKeys = - Vector.singleton - (SubscriptionCheckpointKey (SubscriptionName "rollback") 0) - , missingSubscriptionNames = Vector.empty - } - countSentinels store `shouldReturn` 0 - inventoryKeys <$> inventory store `shouldReturn` [("rollback", 0, 9)] + result + `shouldBe` Right + SubscriptionCheckpointResetReport + { resetCheckpointKeys = + Vector.singleton + (SubscriptionCheckpointKey (SubscriptionName "rollback") 0), + missingSubscriptionNames = Vector.empty + } + countSentinels store `shouldReturn` 0 + inventoryKeys <$> inventory store `shouldReturn` [("rollback", 0, 9)] - it "can rewind while later ordinary saves remain monotonic" $ - withTestStore $ \store -> do - appendEvents store "reset-rewind-events" 10 - initializeRows store [("rewind", 0)] - _ <- reset store (SubscriptionName "rewind" :| []) (GlobalPosition 8) - _ <- reset store (SubscriptionName "rewind" :| []) (GlobalPosition 4) - inventoryKeys <$> inventory store `shouldReturn` [("rewind", 0, 4)] + it "can rewind while later ordinary saves remain monotonic" $ + withTestStore $ \store -> do + appendEvents store "reset-rewind-events" 10 + initializeRows store [("rewind", 0)] + _ <- reset store (SubscriptionName "rewind" :| []) (GlobalPosition 8) + _ <- reset store (SubscriptionName "rewind" :| []) (GlobalPosition 4) + inventoryKeys <$> inventory store `shouldReturn` [("rewind", 0, 4)] - saveCheckpoint store "rewind" 0 2 - inventoryKeys <$> inventory store `shouldReturn` [("rewind", 0, 4)] - saveCheckpoint store "rewind" 0 6 - inventoryKeys <$> inventory store `shouldReturn` [("rewind", 0, 6)] + saveCheckpoint store "rewind" 0 2 + inventoryKeys <$> inventory store `shouldReturn` [("rewind", 0, 4)] + saveCheckpoint store "rewind" 0 6 + inventoryKeys <$> inventory store `shouldReturn` [("rewind", 0, 6)] - it "reports missing names without manufacturing checkpoint rows" $ - withTestStore $ \store -> do - result <- - reset - store - (SubscriptionName "absent-b" :| [SubscriptionName "absent-a"]) - (GlobalPosition 5) - result - `shouldBe` SubscriptionCheckpointResetReport - { resetCheckpointKeys = Vector.empty - , missingSubscriptionNames = - Vector.fromList - [SubscriptionName "absent-a", SubscriptionName "absent-b"] - } - inventoryKeys <$> inventory store `shouldReturn` [] + it "reports missing names without manufacturing checkpoint rows" $ + withTestStore $ \store -> do + result <- + reset + store + (SubscriptionName "absent-b" :| [SubscriptionName "absent-a"]) + (GlobalPosition 5) + result + `shouldBe` SubscriptionCheckpointResetReport + { resetCheckpointKeys = Vector.empty, + missingSubscriptionNames = + Vector.fromList + [SubscriptionName "absent-a", SubscriptionName "absent-b"] + } + inventoryKeys <$> inventory store `shouldReturn` [] initializeRows :: KirokuStore -> [(Text, Int32)] -> IO () initializeRows store rows = - mapM_ initialize rows + mapM_ initialize rows where initialize (name, member) = do - result <- - runStoreIO store $ - initializeSubscriptionCheckpoint - (SubscriptionName name) - member - FromBeginning - case result of - Right (Right _) -> pure () - other -> expectationFailure ("checkpoint initialization failed: " <> show other) + result <- + runStoreIO store $ + initializeSubscriptionCheckpoint + (SubscriptionName name) + member + FromBeginning + case result of + Right (Right _) -> pure () + other -> expectationFailure ("checkpoint initialization failed: " <> show other) reset :: - KirokuStore -> - NonEmpty SubscriptionName -> - GlobalPosition -> - IO SubscriptionCheckpointResetReport + KirokuStore -> + NonEmpty SubscriptionName -> + GlobalPosition -> + IO SubscriptionCheckpointResetReport reset store names position = do - result <- runStoreIO store $ runTransaction $ resetSubscriptionCheckpointsTx names position - case result of - Left err -> expectationFailure ("checkpoint reset failed: " <> show err) >> error "unreachable" - Right report -> pure report + result <- runStoreIO store $ runTransaction $ resetSubscriptionCheckpointsTx names position + case result of + Left err -> expectationFailure ("checkpoint reset failed: " <> show err) >> error "unreachable" + Right report -> pure report inventory :: KirokuStore -> IO SubscriptionCheckpointInventory inventory store = do - result <- runStoreIO store subscriptionCheckpointInventory - case result of - Left err -> expectationFailure ("checkpoint inventory failed: " <> show err) >> error "unreachable" - Right rows -> pure rows + result <- runStoreIO store subscriptionCheckpointInventory + case result of + Left err -> expectationFailure ("checkpoint inventory failed: " <> show err) >> error "unreachable" + Right rows -> pure rows inventoryKeys :: SubscriptionCheckpointInventory -> [(Text, Int32, Int64)] inventoryKeys (SubscriptionCheckpointInventory _ rows) = - [ (name, member, position) - | SubscriptionCheckpoint (SubscriptionName name) member (GlobalPosition position) _ <- - Vector.toList rows - ] + [ (name, member, position) + | SubscriptionCheckpoint (SubscriptionName name) member (GlobalPosition position) _ <- + Vector.toList rows + ] appendEvents :: KirokuStore -> Text -> Int -> IO () appendEvents store stream count = do - let events = - [makeEvent ("Reset" <> Text.pack (show i)) (Aeson.object []) | i <- [1 .. count]] - result <- runStoreIO store $ appendToStream (StreamName stream) NoStream events - case result of - Left err -> expectationFailure ("append failed: " <> show err) - Right _ -> pure () + let events = + [makeEvent ("Reset" <> Text.pack (show i)) (Aeson.object []) | i <- [1 .. count]] + result <- runStoreIO store $ appendToStream (StreamName stream) NoStream events + case result of + Left err -> expectationFailure ("append failed: " <> show err) + Right _ -> pure () saveCheckpoint :: KirokuStore -> Text -> Int32 -> Int64 -> IO () saveCheckpoint store name member position = do - result <- - Pool.use (store ^. #pool) $ - Session.statement (name, member, position, max 1 (member + 1), "unbound", Nothing) SQL.saveCheckpointMemberStmt - case result of - Left err -> expectationFailure ("ordinary checkpoint save failed: " <> show err) - Right () -> pure () + result <- + Pool.use (store ^. #pool) $ + Session.statement (name, member, position, max 1 (member + 1), "unbound", Nothing) SQL.saveCheckpointMemberStmt + case result of + Left err -> expectationFailure ("ordinary checkpoint save failed: " <> show err) + Right () -> pure () createSentinelTable :: KirokuStore -> IO () createSentinelTable store = do - result <- Pool.use (store ^. #pool) (Session.statement () createSentinelTableStmt) - case result of - Left err -> expectationFailure ("sentinel table creation failed: " <> show err) - Right () -> pure () + result <- Pool.use (store ^. #pool) (Session.statement () createSentinelTableStmt) + case result of + Left err -> expectationFailure ("sentinel table creation failed: " <> show err) + Right () -> pure () countSentinels :: KirokuStore -> IO Int64 countSentinels store = do - result <- Pool.use (store ^. #pool) (Session.statement () countSentinelsStmt) - case result of - Left err -> expectationFailure ("sentinel count failed: " <> show err) >> error "unreachable" - Right count -> pure count + result <- Pool.use (store ^. #pool) (Session.statement () countSentinelsStmt) + case result of + Left err -> expectationFailure ("sentinel count failed: " <> show err) >> error "unreachable" + Right count -> pure count createSentinelTableStmt :: Statement () () createSentinelTableStmt = - unpreparable - "CREATE TABLE public.checkpoint_reset_sentinel \ - \(id BIGINT PRIMARY KEY, value TEXT NOT NULL)" - E.noParams - D.noResult + unpreparable + "CREATE TABLE public.checkpoint_reset_sentinel \ + \(id BIGINT PRIMARY KEY, value TEXT NOT NULL)" + E.noParams + D.noResult insertSentinelStmt :: Statement (Int64, Text) () insertSentinelStmt = - preparable - "INSERT INTO public.checkpoint_reset_sentinel (id, value) VALUES ($1, $2)" - ( contrazip2 - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.text)) - ) - D.noResult + preparable + "INSERT INTO public.checkpoint_reset_sentinel (id, value) VALUES ($1, $2)" + ( contrazip2 + (E.param (E.nonNullable E.int8)) + (E.param (E.nonNullable E.text)) + ) + D.noResult countSentinelsStmt :: Statement () Int64 countSentinelsStmt = - preparable - "SELECT COUNT(*) FROM public.checkpoint_reset_sentinel" - E.noParams - (D.singleRow (D.column (D.nonNullable D.int8))) + preparable + "SELECT COUNT(*) FROM public.checkpoint_reset_sentinel" + E.noParams + (D.singleRow (D.column (D.nonNullable D.int8))) diff --git a/test/Test/SubscriptionCheckpointWorker.hs b/test/Test/SubscriptionCheckpointWorker.hs --- a/test/Test/SubscriptionCheckpointWorker.hs +++ b/test/Test/SubscriptionCheckpointWorker.hs @@ -28,224 +28,224 @@ spec :: Spec spec = describe "subscription checkpoint worker policies" $ do - it "starts a non-group worker FromBeginning and reports the durable seed" $ do - eventsRef <- newIORef [] - resolutionsRef <- newIORef [] - let name = SubscriptionName "worker-from-beginning" - observe evt = case evt of - KirokuEventSubscriptionCheckpointResolved initialization NonGroup -> - modifyIORef' resolutionsRef (initialization :) - _ -> pure () - tweak settings = settings & #eventHandler .~ Just observe - withTestStoreSettings tweak $ \store -> do - _ <- appendBatch store "worker-from-beginning-events" 3 - waitForPublisher store (GlobalPosition 3) - let handler event = do - modifyIORef' eventsRef (event ^. #globalPosition :) - seen <- length <$> readIORef eventsRef - pure (if seen >= 3 then Stop else Continue) - config = - (defaultSubscriptionConfig name AllStreams handler) - { missingCheckpointPolicy = FromBeginning - } - handle <- subscribe store config - expectClean handle + it "starts a non-group worker FromBeginning and reports the durable seed" $ do + eventsRef <- newIORef [] + resolutionsRef <- newIORef [] + let name = SubscriptionName "worker-from-beginning" + observe evt = case evt of + KirokuEventSubscriptionCheckpointResolved initialization NonGroup -> + modifyIORef' resolutionsRef (initialization :) + _ -> pure () + tweak settings = settings & #eventHandler .~ Just observe + withTestStoreSettings tweak $ \store -> do + _ <- appendBatch store "worker-from-beginning-events" 3 + waitForPublisher store (GlobalPosition 3) + let handler event = do + modifyIORef' eventsRef (event ^. #globalPosition :) + seen <- length <$> readIORef eventsRef + pure (if seen >= 3 then Stop else Continue) + config = + (defaultSubscriptionConfig name AllStreams handler) + { missingCheckpointPolicy = FromBeginning + } + handle <- subscribe store config + expectClean handle - reverse <$> readIORef eventsRef - `shouldReturn` fmap GlobalPosition [1, 2, 3] - inventoryPositions store - `shouldReturn` [(SubscriptionCheckpointKey name 0, GlobalPosition 3)] + reverse <$> readIORef eventsRef + `shouldReturn` fmap GlobalPosition [1, 2, 3] + inventoryPositions store + `shouldReturn` [(SubscriptionCheckpointKey name 0, GlobalPosition 3)] - readIORef resolutionsRef - `shouldReturn` [InitializedCheckpoint FromBeginning (SubscriptionCheckpointKey name 0) (GlobalPosition 0)] + readIORef resolutionsRef + `shouldReturn` [InitializedCheckpoint FromBeginning (SubscriptionCheckpointKey name 0) (GlobalPosition 0)] - it "forms a clean FromCurrentHead cut while appends race startup" $ do - initializationReady <- newEmptyMVar - deliveredRef <- newIORef [] - let name = SubscriptionName "worker-current-head-race" - key = SubscriptionCheckpointKey name 0 - observe evt = case evt of - KirokuEventSubscriptionCheckpointResolved initialization NonGroup - | initializationKey initialization == key -> - void (tryPutMVar initializationReady initialization) - _ -> pure () - tweak settings = settings & #eventHandler .~ Just observe - withTestStoreSettings tweak $ \store -> do - _ <- appendBatch store "worker-current-head-race-events" 10 - waitForPublisher store (GlobalPosition 10) - gate <- newEmptyMVar - let handler event = do - modifyIORef' deliveredRef (event ^. #globalPosition :) - pure $ if event ^. #eventType == EventType "RaceSentinel" then Stop else Continue - config = - (defaultSubscriptionConfig name AllStreams handler) - { missingCheckpointPolicy = FromCurrentHead - , batchSize = either (error . show) Prelude.id (mkBatchSize 3) - } - subscribeThread <- Async.async (takeMVar gate >> subscribe store config) - appendThread <- Async.async $ do - takeMVar gate - forM [1 .. 20 :: Int] $ \i -> - appendExisting store "worker-current-head-race-events" ("Racing" <> T.pack (show i)) - putMVar gate () - putMVar gate () - handle <- Async.wait subscribeThread - initialization <- waitMVar "checkpoint resolution" initializationReady - racePositions <- Async.wait appendThread - raceTail <- case reverse racePositions of - [] -> expectationFailure "expected racing appends" >> error "unreachable" - position : _ -> pure position - let seed = checkpointInitializationPosition initialization - waitForPublisher store raceTail - finalPosition <- appendExisting store "worker-current-head-race-events" "RaceSentinel" - waitForPublisher store finalPosition - expectClean handle + it "forms a clean FromCurrentHead cut while appends race startup" $ do + initializationReady <- newEmptyMVar + deliveredRef <- newIORef [] + let name = SubscriptionName "worker-current-head-race" + key = SubscriptionCheckpointKey name 0 + observe evt = case evt of + KirokuEventSubscriptionCheckpointResolved initialization NonGroup + | initializationKey initialization == key -> + void (tryPutMVar initializationReady initialization) + _ -> pure () + tweak settings = settings & #eventHandler .~ Just observe + withTestStoreSettings tweak $ \store -> do + _ <- appendBatch store "worker-current-head-race-events" 10 + waitForPublisher store (GlobalPosition 10) + gate <- newEmptyMVar + let handler event = do + modifyIORef' deliveredRef (event ^. #globalPosition :) + pure $ if event ^. #eventType == EventType "RaceSentinel" then Stop else Continue + config = + (defaultSubscriptionConfig name AllStreams handler) + { missingCheckpointPolicy = FromCurrentHead, + batchSize = either (error . show) Prelude.id (mkBatchSize 3) + } + subscribeThread <- Async.async (takeMVar gate >> subscribe store config) + appendThread <- Async.async $ do + takeMVar gate + forM [1 .. 20 :: Int] $ \i -> + appendExisting store "worker-current-head-race-events" ("Racing" <> T.pack (show i)) + putMVar gate () + putMVar gate () + handle <- Async.wait subscribeThread + initialization <- waitMVar "checkpoint resolution" initializationReady + racePositions <- Async.wait appendThread + raceTail <- case reverse racePositions of + [] -> expectationFailure "expected racing appends" >> error "unreachable" + position : _ -> pure position + let seed = checkpointInitializationPosition initialization + waitForPublisher store raceTail + finalPosition <- appendExisting store "worker-current-head-race-events" "RaceSentinel" + waitForPublisher store finalPosition + expectClean handle - initialization `shouldBe` InitializedCheckpoint FromCurrentHead key seed - delivered <- reverse <$> readIORef deliveredRef - delivered `shouldBe` positionsAfter seed finalPosition + initialization `shouldBe` InitializedCheckpoint FromCurrentHead key seed + delivered <- reverse <$> readIORef deliveredRef + delivered `shouldBe` positionsAfter seed finalPosition - it "initializes each consumer-group member independently at the current head" $ do - resolutionsVar <- newTVarIO [] - handlerCalled <- newTVarIO False - let name = SubscriptionName "worker-current-head-members" - observe evt = case evt of - KirokuEventSubscriptionCheckpointResolved initialization GroupMember{} -> - atomically (modifyTVar' resolutionsVar (initialization :)) - _ -> pure () - tweak settings = settings & #eventHandler .~ Just observe - withTestStoreSettings tweak $ \store -> do - _ <- appendBatch store "worker-current-head-members-events" 6 - waitForPublisher store (GlobalPosition 6) - let config member = - ( defaultSubscriptionConfig name AllStreams $ \_ -> do - atomically (writeTVar handlerCalled True) - pure Continue - ) - { consumerGroup = Just (validConsumerGroup member 2) - , missingCheckpointPolicy = FromCurrentHead - } - handles <- mapM (subscribe store . config) [0, 1] - atomically $ do - resolutions <- readTVar resolutionsVar - check (length resolutions >= 2) - mapM_ cancel handles - mapM_ wait handles + it "initializes each consumer-group member independently at the current head" $ do + resolutionsVar <- newTVarIO [] + handlerCalled <- newTVarIO False + let name = SubscriptionName "worker-current-head-members" + observe evt = case evt of + KirokuEventSubscriptionCheckpointResolved initialization GroupMember {} -> + atomically (modifyTVar' resolutionsVar (initialization :)) + _ -> pure () + tweak settings = settings & #eventHandler .~ Just observe + withTestStoreSettings tweak $ \store -> do + _ <- appendBatch store "worker-current-head-members-events" 6 + waitForPublisher store (GlobalPosition 6) + let config member = + ( defaultSubscriptionConfig name AllStreams $ \_ -> do + atomically (writeTVar handlerCalled True) + pure Continue + ) + { consumerGroup = Just (validConsumerGroup member 2), + missingCheckpointPolicy = FromCurrentHead + } + handles <- mapM (subscribe store . config) [0, 1] + atomically $ do + resolutions <- readTVar resolutionsVar + check (length resolutions >= 2) + mapM_ cancel handles + mapM_ wait handles - resolutions <- sortOn initializationKey <$> readTVarIO resolutionsVar - resolutions - `shouldBe` [ InitializedCheckpoint FromCurrentHead (SubscriptionCheckpointKey name 0) (GlobalPosition 6) - , InitializedCheckpoint FromCurrentHead (SubscriptionCheckpointKey name 1) (GlobalPosition 6) - ] - readTVarIO handlerCalled `shouldReturn` False - inventoryPositions store - `shouldReturn` [ (SubscriptionCheckpointKey name 0, GlobalPosition 6) - , (SubscriptionCheckpointKey name 1, GlobalPosition 6) - ] + resolutions <- sortOn initializationKey <$> readTVarIO resolutionsVar + resolutions + `shouldBe` [ InitializedCheckpoint FromCurrentHead (SubscriptionCheckpointKey name 0) (GlobalPosition 6), + InitializedCheckpoint FromCurrentHead (SubscriptionCheckpointKey name 1) (GlobalPosition 6) + ] + readTVarIO handlerCalled `shouldReturn` False + inventoryPositions store + `shouldReturn` [ (SubscriptionCheckpointKey name 0, GlobalPosition 6), + (SubscriptionCheckpointKey name 1, GlobalPosition 6) + ] - it "preserves FailIfMissing through the bracketed plain-IO entry point" $ - withTestStore $ \store -> do - let name = SubscriptionName "worker-bracketed-missing" - key = SubscriptionCheckpointKey name 0 - config = - (defaultSubscriptionConfig name AllStreams (\_ -> pure Continue)) - { missingCheckpointPolicy = FailIfMissing - } - outcome <- withSubscription store config wait - case outcome of - Left err - | Just (SubscriptionCheckpointMissing actual) <- fromException err -> - actual `shouldBe` key - other -> expectationFailure ("expected bracketed missing refusal, got: " <> show other) + it "preserves FailIfMissing through the bracketed plain-IO entry point" $ + withTestStore $ \store -> do + let name = SubscriptionName "worker-bracketed-missing" + key = SubscriptionCheckpointKey name 0 + config = + (defaultSubscriptionConfig name AllStreams (\_ -> pure Continue)) + { missingCheckpointPolicy = FailIfMissing + } + outcome <- withSubscription store config wait + case outcome of + Left err + | Just (SubscriptionCheckpointMissing actual) <- fromException err -> + actual `shouldBe` key + other -> expectationFailure ("expected bracketed missing refusal, got: " <> show other) - it "preserves FromCurrentHead through the higher-order effect entry point" $ do - initializationReady <- newEmptyMVar - deliveredRef <- newIORef [] - let name = SubscriptionName "worker-effect-current-head" - key = SubscriptionCheckpointKey name 0 - observe evt = case evt of - KirokuEventSubscriptionCheckpointResolved initialization NonGroup - | initializationKey initialization == key -> - void (tryPutMVar initializationReady initialization) - _ -> pure () - tweak settings = settings & #eventHandler .~ Just observe - withTestStoreSettings tweak $ \store -> do - _ <- appendBatch store "worker-effect-current-head-events" 5 - waitForPublisher store (GlobalPosition 5) - runEff $ SubEff.runSubscription store $ do - let config = - ( defaultSubscriptionConfig name AllStreams $ \event -> do - liftIO (modifyIORef' deliveredRef (event ^. #globalPosition :)) - pure Stop - ) - { missingCheckpointPolicy = FromCurrentHead - } - handle <- SubEff.subscribe config - initialization <- liftIO (waitMVar "effect checkpoint resolution" initializationReady) - liftIO $ initialization `shouldBe` InitializedCheckpoint FromCurrentHead key (GlobalPosition 5) - position <- liftIO $ appendExisting store "worker-effect-current-head-events" "EffectFuture" - liftIO (waitForPublisher store position) - liftIO (expectClean handle) - reverse <$> readIORef deliveredRef `shouldReturn` [GlobalPosition 6] + it "preserves FromCurrentHead through the higher-order effect entry point" $ do + initializationReady <- newEmptyMVar + deliveredRef <- newIORef [] + let name = SubscriptionName "worker-effect-current-head" + key = SubscriptionCheckpointKey name 0 + observe evt = case evt of + KirokuEventSubscriptionCheckpointResolved initialization NonGroup + | initializationKey initialization == key -> + void (tryPutMVar initializationReady initialization) + _ -> pure () + tweak settings = settings & #eventHandler .~ Just observe + withTestStoreSettings tweak $ \store -> do + _ <- appendBatch store "worker-effect-current-head-events" 5 + waitForPublisher store (GlobalPosition 5) + runEff $ SubEff.runSubscription store $ do + let config = + ( defaultSubscriptionConfig name AllStreams $ \event -> do + liftIO (modifyIORef' deliveredRef (event ^. #globalPosition :)) + pure Stop + ) + { missingCheckpointPolicy = FromCurrentHead + } + handle <- SubEff.subscribe config + initialization <- liftIO (waitMVar "effect checkpoint resolution" initializationReady) + liftIO $ initialization `shouldBe` InitializedCheckpoint FromCurrentHead key (GlobalPosition 5) + position <- liftIO $ appendExisting store "worker-effect-current-head-events" "EffectFuture" + liftIO (waitForPublisher store position) + liftIO (expectClean handle) + reverse <$> readIORef deliveredRef `shouldReturn` [GlobalPosition 6] - it "preserves FailIfMissing through the Streamly bridge" $ - withTestStore $ \store -> do - let name = SubscriptionName "worker-streamly-missing" - key = SubscriptionCheckpointKey name 0 - config = - (defaultSubscriptionConfig name AllStreams (\_ -> pure Continue)) - { missingCheckpointPolicy = FailIfMissing - } - (stream, cancelStream) <- subscriptionAckStream store config (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 1)) - pulled <- finally (try (Stream.uncons stream)) cancelStream - case pulled of - Left err - | Just (SubscriptionCheckpointMissing actual) <- fromException (err :: SomeException) -> - actual `shouldBe` key - Left err -> expectationFailure ("expected typed Streamly refusal, got: " <> show err) - Right _ -> expectationFailure "expected Streamly bridge startup to fail" + it "preserves FailIfMissing through the Streamly bridge" $ + withTestStore $ \store -> do + let name = SubscriptionName "worker-streamly-missing" + key = SubscriptionCheckpointKey name 0 + config = + (defaultSubscriptionConfig name AllStreams (\_ -> pure Continue)) + { missingCheckpointPolicy = FailIfMissing + } + (stream, cancelStream) <- subscriptionAckStream store config (either (error . show) Prelude.id (Buffer.mkStreamBufferSize 1)) + pulled <- finally (try (Stream.uncons stream)) cancelStream + case pulled of + Left err + | Just (SubscriptionCheckpointMissing actual) <- fromException (err :: SomeException) -> + actual `shouldBe` key + Left err -> expectationFailure ("expected typed Streamly refusal, got: " <> show err) + Right _ -> expectationFailure "expected Streamly bridge startup to fail" initializationKey :: CheckpointInitialization -> SubscriptionCheckpointKey initializationKey = \case - ExistingCheckpoint key _ -> key - InitializedCheckpoint _ key _ -> key + ExistingCheckpoint key _ -> key + InitializedCheckpoint _ key _ -> key positionsAfter :: GlobalPosition -> GlobalPosition -> [GlobalPosition] positionsAfter (GlobalPosition start) (GlobalPosition end) = - fmap GlobalPosition [start + 1 .. end] + fmap GlobalPosition [start + 1 .. end] inventoryPositions :: KirokuStore -> IO [(SubscriptionCheckpointKey, GlobalPosition)] inventoryPositions store = do - Right (SubscriptionCheckpointInventory _ rows) <- runStoreIO store subscriptionCheckpointInventory - pure - [ (SubscriptionCheckpointKey name member, position) - | SubscriptionCheckpoint name member position _ <- V.toList rows - ] + Right (SubscriptionCheckpointInventory _ rows) <- runStoreIO store subscriptionCheckpointInventory + pure + [ (SubscriptionCheckpointKey name member, position) + | SubscriptionCheckpoint name member position _ <- V.toList rows + ] appendBatch :: KirokuStore -> Text -> Int -> IO GlobalPosition appendBatch store stream count = do - let events = [makeEvent ("History" <> T.pack (show i)) (Aeson.object []) | i <- [1 .. count]] - Right result <- runStoreIO store $ appendToStream (StreamName stream) NoStream events - pure (result ^. #globalPosition) + let events = [makeEvent ("History" <> T.pack (show i)) (Aeson.object []) | i <- [1 .. count]] + Right result <- runStoreIO store $ appendToStream (StreamName stream) NoStream events + pure (result ^. #globalPosition) appendExisting :: KirokuStore -> Text -> Text -> IO GlobalPosition appendExisting store stream typ = do - Right result <- - runStoreIO store $ - appendToStream (StreamName stream) StreamExists [makeEvent typ (Aeson.object [])] - pure (result ^. #globalPosition) + Right result <- + runStoreIO store $ + appendToStream (StreamName stream) StreamExists [makeEvent typ (Aeson.object [])] + pure (result ^. #globalPosition) expectClean :: SubscriptionHandle -> IO () expectClean handle = do - result <- waitWithTimeout 15_000_000 handle - case result of - Left message -> expectationFailure message - Right (Left err) -> expectationFailure ("subscription failed: " <> show err) - Right (Right ()) -> pure () + result <- waitWithTimeout 15_000_000 handle + case result of + Left message -> expectationFailure message + Right (Left err) -> expectationFailure ("subscription failed: " <> show err) + Right (Right ()) -> pure () waitMVar :: String -> MVar a -> IO a waitMVar label var = do - result <- Async.race (threadDelay 10_000_000) (takeMVar var) - case result of - Left () -> expectationFailure ("timed out waiting for " <> label) >> error "unreachable" - Right value -> pure value + result <- Async.race (threadDelay 10_000_000) (takeMVar var) + case result of + Left () -> expectationFailure ("timed out waiting for " <> label) >> error "unreachable" + Right value -> pure value diff --git a/test/Test/SubscriptionDeadLetters.hs b/test/Test/SubscriptionDeadLetters.hs --- a/test/Test/SubscriptionDeadLetters.hs +++ b/test/Test/SubscriptionDeadLetters.hs @@ -21,106 +21,109 @@ spec :: Spec spec = describe "SubscriptionDeadLetters" $ do - it "validates page sizes including both boundaries" $ do - forM_ [0, -1, 1001] $ \n -> mkSubscriptionDeadLetterLimit n `shouldBe` Left (SubscriptionDeadLetterLimitOutOfRange n) - forM_ [1, 1000] $ \n -> fmap subscriptionDeadLetterLimitValue (mkSubscriptionDeadLetterLimit n) `shouldBe` Right n - subscriptionDeadLetterLimitValue defaultSubscriptionDeadLetterLimit `shouldBe` 100 - around withTestStore $ do - it "returns empty pages through both Store interpreters" $ \store -> do - let query = defaultSubscriptionDeadLetterQuery (SubscriptionName "absent") - runStoreIO store (subscriptionDeadLetters query) `shouldReturn` Right (SubscriptionDeadLetterPage V.empty Nothing) - (runEff . runErrorNoCallStack @StoreError . runKirokuStoreWith store . runStoreResource $ subscriptionDeadLetters query) - `shouldReturn` Right (SubscriptionDeadLetterPage V.empty Nothing) - it "pages without omissions, isolates names and matches the internal member read" $ \store -> do - events <- seedEvents store 7 - mapM_ (insertDeadLetterForEvent store "page") (take 5 events) - mapM_ (insertDeadLetterForEvent store "other") (drop 5 events) - let query = (defaultSubscriptionDeadLetterQuery (SubscriptionName "page")){limit = validLimit 2} - first <- page store query - second <- page store query{after = first ^. #nextCursor} - third <- page store query{after = second ^. #nextCursor} - map positions [first, second, third] `shouldBe` [[5, 4], [3, 2], [1]] - third ^. #nextCursor `shouldBe` Nothing - Right internal <- Pool.use (store ^. #pool) (Session.statement ("page", 0) SQL.readDeadLettersStmt) - map SQL.deadLetterGlobalPosition (V.toList internal) `shouldBe` [5, 4, 3, 2, 1] - forM_ [5, 1000] $ \n -> do - final <- page store query{limit = validLimit n} - positions final `shouldBe` [5, 4, 3, 2, 1] - final ^. #nextCursor `shouldBe` Nothing - it "merges historical members and resolves same-position ties with an exclusive cursor" $ \store -> do - [event] <- seedEvents store 1 - forM_ [0, 1, 9] $ \member -> insertDeadLetterWith store "ties" member (object []) "tie" 2 event - let query = (defaultSubscriptionDeadLetterQuery (SubscriptionName "ties")){limit = validLimit 1} - first <- page store query - second <- page store query{after = first ^. #nextCursor} - third <- page store query{after = second ^. #nextCursor} - map (\p -> map (\row -> row ^. #consumerGroupMember) (V.toList (p ^. #deadLetters))) [first, second, third] `shouldBe` [[9], [1], [0]] - third ^. #nextCursor `shouldBe` Nothing - forM_ [0, 1, 9, 7] $ \member -> do - selected <- page store (query & #consumerGroupMember .~ Just member) - positions selected `shouldBe` if member == 7 then [] else [1] - it "preserves arbitrary and decode-failure JSON unchanged" $ \store -> do - events <- seedEvents store 2 - let reasons = [object ["kind" .= ("other" :: T.Text), "detail" .= object ["code" .= (42 :: Int)]], object ["kind" .= ("decode_failure" :: T.Text), "detail" .= ("bad version" :: T.Text)]] - forM_ (zip events reasons) $ \(event, reason) -> insertDeadLetterWith store "json" 0 reason "summary" 3 event - result <- page store (defaultSubscriptionDeadLetterQuery (SubscriptionName "json")) - map (\row -> row ^. #reason) (V.toList (result ^. #deadLetters)) `shouldBe` reverse reasons - now <- getCurrentTime - forM_ (V.toList (result ^. #deadLetters)) $ \row -> do - row ^. #attemptCount `shouldBe` 3 - row ^. #createdAt `shouldSatisfy` (<= now) - it "never invokes a configured event decode hook for dead-letter reads" $ \_ -> - withTestStoreSettings (\settings -> (settings & #storeSettings .~ defaultStoreSettings{decodeHook = Just (\_ -> fail "dead-letter read invoked decode hook")})) $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "hook-1") NoStream [makeEvent "E" (object [])] - Right () <- Pool.use (store ^. #pool) (Session.script "INSERT INTO dead_letters(subscription_name,global_position,event_id,reason,reason_summary,attempt_count) SELECT 'hook',1,event_id,'{}','fixture',1 FROM events") - result <- page store (defaultSubscriptionDeadLetterQuery (SubscriptionName "hook")) - positions result `shouldBe` [1] + it "validates page sizes including both boundaries" $ do + forM_ [0, -1, 1001] $ \n -> mkSubscriptionDeadLetterLimit n `shouldBe` Left (SubscriptionDeadLetterLimitOutOfRange n) + forM_ [1, 1000] $ \n -> fmap subscriptionDeadLetterLimitValue (mkSubscriptionDeadLetterLimit n) `shouldBe` Right n + subscriptionDeadLetterLimitValue defaultSubscriptionDeadLetterLimit `shouldBe` 100 + around withTestStore $ do + it "returns empty pages through both Store interpreters" $ \store -> do + let query = defaultSubscriptionDeadLetterQuery (SubscriptionName "absent") + runStoreIO store (subscriptionDeadLetters query) `shouldReturn` Right (SubscriptionDeadLetterPage V.empty Nothing) + (runEff . runErrorNoCallStack @StoreError . runKirokuStoreWith store . runStoreResource $ subscriptionDeadLetters query) + `shouldReturn` Right (SubscriptionDeadLetterPage V.empty Nothing) + it "pages without omissions, isolates names and matches the internal member read" $ \store -> do + events <- seedEvents store 7 + mapM_ (insertDeadLetterForEvent store "page") (take 5 events) + mapM_ (insertDeadLetterForEvent store "other") (drop 5 events) + let query = (defaultSubscriptionDeadLetterQuery (SubscriptionName "page")) {limit = validLimit 2} + first <- page store query + second <- page store query {after = first ^. #nextCursor} + third <- page store query {after = second ^. #nextCursor} + map positions [first, second, third] `shouldBe` [[5, 4], [3, 2], [1]] + third ^. #nextCursor `shouldBe` Nothing + Right internal <- Pool.use (store ^. #pool) (Session.statement ("page", 0) SQL.readDeadLettersStmt) + map SQL.deadLetterGlobalPosition (V.toList internal) `shouldBe` [5, 4, 3, 2, 1] + forM_ [5, 1000] $ \n -> do + final <- page store query {limit = validLimit n} + positions final `shouldBe` [5, 4, 3, 2, 1] + final ^. #nextCursor `shouldBe` Nothing + it "merges historical members and resolves same-position ties with an exclusive cursor" $ \store -> do + [event] <- seedEvents store 1 + forM_ [0, 1, 9] $ \member -> insertDeadLetterWith store "ties" member (object []) "tie" 2 event + let query = (defaultSubscriptionDeadLetterQuery (SubscriptionName "ties")) {limit = validLimit 1} + first <- page store query + second <- page store query {after = first ^. #nextCursor} + third <- page store query {after = second ^. #nextCursor} + map (\p -> map (\row -> row ^. #consumerGroupMember) (V.toList (p ^. #deadLetters))) [first, second, third] `shouldBe` [[9], [1], [0]] + third ^. #nextCursor `shouldBe` Nothing + forM_ [0, 1, 9, 7] $ \member -> do + selected <- page store (query & #consumerGroupMember .~ Just member) + positions selected `shouldBe` if member == 7 then [] else [1] + it "preserves arbitrary and decode-failure JSON unchanged" $ \store -> do + events <- seedEvents store 2 + let reasons = [object ["kind" .= ("other" :: T.Text), "detail" .= object ["code" .= (42 :: Int)]], object ["kind" .= ("decode_failure" :: T.Text), "detail" .= ("bad version" :: T.Text)]] + forM_ (zip events reasons) $ \(event, reason) -> insertDeadLetterWith store "json" 0 reason "summary" 3 event + result <- page store (defaultSubscriptionDeadLetterQuery (SubscriptionName "json")) + map (\row -> row ^. #reason) (V.toList (result ^. #deadLetters)) `shouldBe` reverse reasons + now <- getCurrentTime + forM_ (V.toList (result ^. #deadLetters)) $ \row -> do + row ^. #attemptCount `shouldBe` 3 + row ^. #createdAt `shouldSatisfy` (<= now) + it "never invokes a configured event decode hook for dead-letter reads" $ \_ -> + withTestStoreSettings (\settings -> (settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just (\_ -> fail "dead-letter read invoked decode hook")})) $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "hook-1") NoStream [makeEvent "E" (object [])] + Right () <- Pool.use (store ^. #pool) (Session.script "INSERT INTO dead_letters(subscription_name,global_position,event_id,reason,reason_summary,attempt_count) SELECT 'hook',1,event_id,'{}','fixture',1 FROM events") + result <- page store (defaultSubscriptionDeadLetterQuery (SubscriptionName "hook")) + positions result `shouldBe` [1] - it "keeps a cursor valid after its event and row are hard-deleted" $ \store -> do - events <- seedEvents store 3 - mapM_ (insertDeadLetterForEvent store "delete") events - let query = (defaultSubscriptionDeadLetterQuery (SubscriptionName "delete")){limit = validLimit 1} - first <- page store query - Right _ <- runStoreIO store $ hardDeleteStream (StreamName "dead-3") - older <- page store query{after = first ^. #nextCursor, limit = validLimit 10} - positions older `shouldBe` [2, 1] - it "includes legal maxBound pairs on first pages" $ \store -> do - [event] <- seedEvents store 1 - insertDeadLetterForEvent store "boundary" event - Right () <- Pool.use (store ^. #pool) (Session.script "UPDATE dead_letters SET global_position=9223372036854775807, dead_letter_id=9223372036854775807 WHERE subscription_name='boundary'") - let query = defaultSubscriptionDeadLetterQuery (SubscriptionName "boundary") - forM_ [Nothing, Just 0] $ \member -> do - result <- page store (query & #consumerGroupMember .~ member) - positions result `shouldBe` [maxBound] - older <- page store (query & #consumerGroupMember .~ member & #after .~ Just (SubscriptionDeadLetterCursor (GlobalPosition maxBound) maxBound)) - positions older `shouldBe` [] - it "reads a real worker-produced poison reason without changing its checkpoint" $ \store -> do - events <- seedEvents store 3 - waitForPublisher store (GlobalPosition 3) - handle <- subscribe store $ defaultSubscriptionConfig (SubscriptionName "worker") AllStreams $ \event -> pure $ case event ^. #globalPosition of - GlobalPosition 2 -> DeadLetter (DeadLetterPoison "boom") - GlobalPosition 3 -> Stop - _ -> Continue - waitWithTimeout 10_000_000 handle >>= \case - Right (Right ()) -> pure () - other -> expectationFailure (show other) - result <- page store (defaultSubscriptionDeadLetterQuery (SubscriptionName "worker")) - case V.toList (result ^. #deadLetters) of - [row] -> do - row ^. #eventId `shouldBe` (events !! 1) ^. #eventId - row ^. #reason `shouldBe` object ["kind" .= ("poison" :: T.Text), "detail" .= ("boom" :: T.Text)] - row ^. #reasonSummary `shouldBe` "poison: boom" - _ -> expectationFailure (show result) - Pool.use (store ^. #pool) (Session.statement ("worker", 0) SQL.getCheckpointMemberStmt) `shouldReturn` Right (Just 3) + it "keeps a cursor valid after its event and row are hard-deleted" $ \store -> do + events <- seedEvents store 3 + mapM_ (insertDeadLetterForEvent store "delete") events + let query = (defaultSubscriptionDeadLetterQuery (SubscriptionName "delete")) {limit = validLimit 1} + first <- page store query + Right _ <- runStoreIO store $ hardDeleteStream (StreamName "dead-3") + older <- page store query {after = first ^. #nextCursor, limit = validLimit 10} + positions older `shouldBe` [2, 1] + it "includes legal maxBound pairs on first pages" $ \store -> do + [event] <- seedEvents store 1 + insertDeadLetterForEvent store "boundary" event + Right () <- Pool.use (store ^. #pool) (Session.script "UPDATE dead_letters SET global_position=9223372036854775807, dead_letter_id=9223372036854775807 WHERE subscription_name='boundary'") + let query = defaultSubscriptionDeadLetterQuery (SubscriptionName "boundary") + forM_ [Nothing, Just 0] $ \member -> do + result <- page store (query & #consumerGroupMember .~ member) + positions result `shouldBe` [maxBound] + older <- page store (query & #consumerGroupMember .~ member & #after .~ Just (SubscriptionDeadLetterCursor (GlobalPosition maxBound) maxBound)) + positions older `shouldBe` [] + it "reads a real worker-produced poison reason without changing its checkpoint" $ \store -> do + events <- seedEvents store 3 + waitForPublisher store (GlobalPosition 3) + handle <- subscribe store $ defaultSubscriptionConfig (SubscriptionName "worker") AllStreams $ \event -> pure $ case event ^. #globalPosition of + GlobalPosition 2 -> DeadLetter (DeadLetterPoison "boom") + GlobalPosition 3 -> Stop + _ -> Continue + waitWithTimeout 10_000_000 handle >>= \case + Right (Right ()) -> pure () + other -> expectationFailure (show other) + result <- page store (defaultSubscriptionDeadLetterQuery (SubscriptionName "worker")) + case V.toList (result ^. #deadLetters) of + [row] -> do + row ^. #eventId `shouldBe` (events !! 1) ^. #eventId + row ^. #reason `shouldBe` object ["kind" .= ("poison" :: T.Text), "detail" .= ("boom" :: T.Text)] + row ^. #reasonSummary `shouldBe` "poison: boom" + _ -> expectationFailure (show result) + Pool.use (store ^. #pool) (Session.statement ("worker", 0) SQL.getCheckpointMemberStmt) `shouldReturn` Right (Just 3) validLimit :: Int32 -> SubscriptionDeadLetterLimit validLimit = either (error . show) (\value -> value) . mkSubscriptionDeadLetterLimit + page :: KirokuStore -> SubscriptionDeadLetterQuery -> IO SubscriptionDeadLetterPage page store query = runStoreIO store (subscriptionDeadLetters query) >>= either (fail . show) pure + positions :: SubscriptionDeadLetterPage -> [Int64] positions result = map (\row -> let GlobalPosition p = row ^. #globalPosition in p) (V.toList (result ^. #deadLetters)) + seedEvents :: KirokuStore -> Int -> IO [RecordedEvent] seedEvents store count = do - forM_ [1 .. count] $ \n -> void $ runStoreIO store $ appendToStream (StreamName ("dead-" <> T.pack (show n))) NoStream [makeEvent "E" (object [])] - Right events <- runStoreIO store $ readAllForward (GlobalPosition 0) (fromIntegral count) - pure (V.toList events) + forM_ [1 .. count] $ \n -> void $ runStoreIO store $ appendToStream (StreamName ("dead-" <> T.pack (show n))) NoStream [makeEvent "E" (object [])] + Right events <- runStoreIO store $ readAllForward (GlobalPosition 0) (fromIntegral count) + pure (V.toList events) diff --git a/test/Test/SubscriptionDeadLettersMock.hs b/test/Test/SubscriptionDeadLettersMock.hs --- a/test/Test/SubscriptionDeadLettersMock.hs +++ b/test/Test/SubscriptionDeadLettersMock.hs @@ -10,14 +10,14 @@ spec :: Spec spec = describe "SubscriptionDeadLetters mock interpreter" $ it "dispatches the public wrapper once with the entire query and returns the interpreter page" $ do - calls <- newIORef (0 :: Int) - let query = (defaultSubscriptionDeadLetterQuery (SubscriptionName "mock")){consumerGroupMember = Just 9, after = Just (SubscriptionDeadLetterCursor (GlobalPosition 21) 7)} - expected = SubscriptionDeadLetterPage V.empty (Just (SubscriptionDeadLetterCursor (GlobalPosition 10) 3)) - runner = interpret_ $ \case - ListSubscriptionDeadLetters actual -> do - liftIO $ actual `shouldBe` query - liftIO $ modifyIORef' calls (+ 1) - pure expected - _ -> error "unexpected Store operation" - runEff (runner (subscriptionDeadLetters query)) `shouldReturn` expected - readIORef calls `shouldReturn` 1 + calls <- newIORef (0 :: Int) + let query = (defaultSubscriptionDeadLetterQuery (SubscriptionName "mock")) {consumerGroupMember = Just 9, after = Just (SubscriptionDeadLetterCursor (GlobalPosition 21) 7)} + expected = SubscriptionDeadLetterPage V.empty (Just (SubscriptionDeadLetterCursor (GlobalPosition 10) 3)) + runner = interpret_ $ \case + ListSubscriptionDeadLetters actual -> do + liftIO $ actual `shouldBe` query + liftIO $ modifyIORef' calls (+ 1) + pure expected + _ -> error "unexpected Store operation" + runEff (runner (subscriptionDeadLetters query)) `shouldReturn` expected + readIORef calls `shouldReturn` 1 diff --git a/test/Test/SubscriptionNamespace.hs b/test/Test/SubscriptionNamespace.hs new file mode 100644 --- /dev/null +++ b/test/Test/SubscriptionNamespace.hs @@ -0,0 +1,375 @@ +module Test.SubscriptionNamespace (spec) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.STM (atomically, newTVarIO, readTVarIO) +import Control.Exception (bracket, fromException) +import Control.Lens ((^.)) +import Control.Monad (forM_, replicateM_, when) +import Data.Aeson qualified as Aeson +import Data.Generics.Labels () +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +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.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 (preparable) +import Hasql.Transaction qualified as Transaction +import Hasql.Transaction.Sessions qualified as Tx +import Kiroku.Store +import Kiroku.Store.Notification qualified as Notify +import Kiroku.Store.SQL qualified as SQL +import Kiroku.Store.Subscription.Fsm qualified as Fsm +import Kiroku.Store.Subscription.Worker (withNamespaceSafetyPollForTest, withNamespaceWindowHookForTest, withSaveCheckpointHookForTest) +import System.Timeout (timeout) +import Test.Helpers +import Test.Hspec + +spec :: Spec +spec = describe "namespace subscriptions" $ do + forM_ [1, 3] $ \width -> + it ("catches up across empty windows, includes future categories, and restarts (W=" <> show width <> ")") $ + withTestStore $ \store -> do + replicateM_ 9 (append store "noise-1") + append store "pm-1" + append store "pm:fulfillment-1" + append store "pm:billing-1" + append store "orders-1" + seen <- newIORef [] + let config = (cfg "restart" "pm" (record seen)) {batchSize = batch width} + withSubscription store config $ \handle -> do + awaitLive handle + positions seen `shouldReturn` [10, 11, 12] + checkpoint store "restart" 0 `shouldReturn` Just 13 + append store "pm:new-1" + await (positions seen) (== [10, 11, 12, 14]) + await (checkpoint store "restart" 0) (== Just 14) + Map.null <$> readTVarIO (Notify.namespaceRegistry (store ^. #notifier)) `shouldReturn` True + restarted <- subscribe store ((cfg "restart" "pm" (\event -> record seen event >> pure Stop)) {batchSize = batch width}) + append store "pm:newer-1" + clean restarted + positions seen `shouldReturn` [10, 11, 12, 14, 15] + binding store "restart" `shouldReturn` ("category_namespace", Just "pm") + + forM_ + [ ("pm", ["pm", "pm:a", "pm:a:b"], ["pmm", "pmish", "orders"]), + ("pm:a", ["pm:a", "pm:a:b"], ["pm", "pm:ab"]), + ("%_\\,雪", ["%_\\,雪", "%_\\,雪:子"], ["xx雪", "%X\\,雪"]), + ("", ["", ":", ":a"], ["pm", "orders"]), + ("pm:", ["pm:", "pm::child"], ["pm", "pm:child"]), + ("pm-x", [], ["pm", "pm:x", "pm-x"]) + ] + $ \(namespace, included, excluded) -> + it ("matches literal category boundaries for " <> show namespace) $ + withTestStore $ \store -> do + forM_ (included <> excluded) $ \category -> append store (category <> "-1") + seen <- newIORef [] + withSubscription store (cfg "literal" namespace (record seen)) $ \handle -> do + awaitLive handle + positions seen `shouldReturn` [1 .. fromIntegral (length included)] + + it "keeps Stop at the stopping event, then replays the rest of a prefetched window" $ + withTestStore $ \store -> do + forM_ ["pm-1", "pm:a-1", "pm:b-1", "noise-1"] (append store) + first <- subscribe store (cfg "stop" "pm" (\_ -> pure Stop)) + clean first + checkpoint store "stop" 0 `shouldReturn` Just 1 + seen <- newIORef [] + withSubscription store (cfg "stop" "pm" (record seen)) $ \handle -> do + awaitLive handle + positions seen `shouldReturn` [2, 3] + checkpoint store "stop" 0 `shouldReturn` Just 4 + + it "does not publish speculative completion while a handler is blocked or cancelled" $ + withTestStore $ \store -> do + append store "pm-1" + append store "noise-1" + entered <- newEmptyMVar + blocked <- newEmptyMVar + withSubscription store (cfg "cancel" "pm" (\_ -> putMVar entered () >> takeMVar blocked >> pure Continue)) $ \handle -> do + bounded (takeMVar entered) + checkpoint store "cancel" 0 `shouldReturn` Just 0 + currentState handle >>= \case + Just (Fsm.CatchingUp (GlobalPosition 0) _) -> pure () + other -> expectationFailure (show other) + seen <- newIORef [] + withSubscription store (cfg "cancel" "pm" (record seen)) $ \handle -> do + awaitLive handle + positions seen `shouldReturn` [1] + checkpoint store "cancel" 0 `shouldReturn` Just 2 + + it "resolves Retry, DeadLetter, filtering and completed trailing rows with one tail save" $ + withTestStore $ \store -> do + append store "pm-1" + append store "pm:a-1" + append store "noise-1" + attempts <- newIORef (0 :: Int) + saves <- newIORef [] + let handler' event + | event ^. #globalPosition == GlobalPosition 1 = do + attempt <- atomicModifyIORef' attempts (\n -> (n + 1, n)) + pure (if attempt == 0 then Retry (RetryDelay 0) else Continue) + | otherwise = pure (DeadLetter (DeadLetterPoison "test")) + withSaveCheckpointHookForTest (\_ p -> atomicModifyIORef' saves (\ps -> (p : ps, ()))) $ + withSubscription store (cfg "dispositions" "pm" handler') awaitLive + readIORef attempts `shouldReturn` 2 + readIORef saves `shouldReturn` [GlobalPosition 3] + checkpoint store "dispositions" 0 `shouldReturn` Just 3 + binding store "dispositions" `shouldReturn` ("category_namespace", Just "pm") + let filtered = (cfg "filter" "pm" (\_ -> expectationFailure "filtered handler ran" >> pure Continue)) {selector = Just (const False)} + withSubscription store filtered awaitLive + checkpoint store "filter" 0 `shouldReturn` Just 3 + + it "coalesces empty-window saves at 32 windows and the head" $ + withTestStore $ \store -> do + replicateM_ 70 (append store "noise-1") + saves <- newIORef [] + withSaveCheckpointHookForTest (\_ p -> atomicModifyIORef' saves (\ps -> (ps <> [p], ()))) $ + withSubscription store ((cfg "coalesce" "pm" (\_ -> pure Continue)) {batchSize = batch 1}) awaitLive + readIORef saves `shouldReturn` map GlobalPosition [32, 64, 70] + + it "does not mistake hard-deleted tail gaps or an empty window for pending delivery" $ + withTestStore $ \store -> do + append store "pm-1" + append store "gone-1" + Right _ <- runStoreIO store (hardDeleteStream (StreamName "gone-1")) + seen <- newIORef [] + withSubscription store ((cfg "gaps" "pm" (record seen)) {batchSize = batch 1}) awaitLive + positions seen `shouldReturn` [1] + checkpoint store "gaps" 0 `shouldReturn` Just 2 + + it "partitions plain and grouped namespaces completely with per-member empty windows" $ + withTestStore $ \store -> do + forM_ [1 .. 25 :: Int] $ \n -> do + append store "noise-1" + append store ("pm:" <> T.pack (show n) <> "-1") + members <- mapM (const (newIORef [])) [0 .. 2 :: Int32] + forM_ (zip [0 ..] members) $ \(index, seen) -> + withSubscription store ((cfg "group" "pm" (record seen)) {consumerGroup = Just (validConsumerGroup index 3), batchSize = batch 1}) $ \handle -> do + awaitLive handle + checkpoint store "group" index `shouldReturn` Just 50 + delivered <- concat <$> mapM positions members + sort delivered `shouldBe` [2, 4 .. 50] + + it "retries catch-up and live fetch failures without skipping matching rows" $ + withTestStore $ \store -> do + append store "pm-1" + remaining <- newIORef True + seen <- newIORef [] + let inject _ _ _ = do + failNow <- atomicModifyIORef' remaining (\b -> (False, b)) + pure (if failNow then Just (Left Pool.AcquisitionTimeoutUsageError) else Nothing) + withNamespaceWindowHookForTest inject $ + withSubscription store (cfg "fetch-fault" "pm" (record seen)) $ \handle -> do + awaitLive handle + writeIORef remaining True + append store "pm:new-1" + await (positions seen) (== [1, 2]) + await (checkpoint store "fetch-fault" 0) (== Just 2) + + it "replays after ordinary save failure and never persists an unfinished atomic dead letter" $ + withTestStore $ \store -> do + append store "pm-1" + append store "noise-1" + -- A database trigger injects actual ordinary/atomic SQL failures, rather + -- than throwing from a seam before attempting a save. + sql store "CREATE FUNCTION fail_namespace_save() RETURNS trigger LANGUAGE plpgsql AS $$ BEGIN IF NEW.last_seen > 0 THEN RAISE EXCEPTION 'injected save failure'; END IF; RETURN NEW; END $$; CREATE TRIGGER fail_namespace_save BEFORE UPDATE ON subscriptions FOR EACH ROW EXECUTE FUNCTION fail_namespace_save()" + withSubscription store (cfg "save-fault" "pm" (\_ -> pure Continue)) awaitLive + checkpoint store "save-fault" 0 `shouldReturn` Just 0 + failed <- subscribe store (cfg "atomic-fault" "pm" (\_ -> pure (DeadLetter (DeadLetterPoison "fail")))) + waitWithTimeout 5_000_000 failed >>= \case + Right (Left _) -> pure () + other -> expectationFailure (show other) + checkpoint store "atomic-fault" 0 `shouldReturn` Just 0 + sql store "DROP TRIGGER fail_namespace_save ON subscriptions" + seen <- newIORef [] + withSubscription store (cfg "save-fault" "pm" (record seen)) awaitLive + positions seen `shouldReturn` [1] + checkpoint store "save-fault" 0 `shouldReturn` Just 2 + + it "preserves namespace identity through rebind, resize, adoption and strict startup" $ + withTestStore $ \store -> do + withSubscription store (cfg "binding" "pm" (\_ -> pure Continue)) awaitLive + mismatch <- subscribe store (defaultSubscriptionConfig (SubscriptionName "binding") (Category (CategoryName "pm")) (\_ -> pure Stop)) + waitWithTimeout 5_000_000 mismatch >>= \case + Right (Left e) -> (fromException e :: Maybe SubscriptionTargetMismatch) `shouldSatisfy` maybe False (const True) + other -> expectationFailure (show other) + let tx :: Transaction.Transaction a -> IO a + tx action = Pool.use (store ^. #pool) (Tx.transaction Tx.ReadCommitted Tx.Write action) >>= either (fail . show) pure + report <- tx (rebindSubscriptionTargetTx (SubscriptionName "binding") (CategoryNamespace "pm:a") (GlobalPosition 0)) + previousBindings report `shouldBe` V.singleton (Just (CategoryNamespace "pm")) + _ <- tx (resizeConsumerGroupTx (SubscriptionName "binding") (either (error . show) Prelude.id (mkConsumerGroupSize 2))) + withSubscription store ((cfg "binding" "pm:a" (\_ -> pure Continue)) {consumerGroup = Just (validConsumerGroup 1 2), targetBindingPolicy = RequireBound}) awaitLive + _ <- tx (resizeConsumerGroupTx (SubscriptionName "adopt") (either (error . show) Prelude.id (mkConsumerGroupSize 2))) + withSubscription store ((cfg "adopt" "pm" (\_ -> pure Continue)) {consumerGroup = Just (validConsumerGroup 0 2)}) awaitLive + withSubscription store ((cfg "adopt" "pm" (\_ -> pure Continue)) {consumerGroup = Just (validConsumerGroup 1 2), targetBindingPolicy = RequireBound}) awaitLive + + it "routes only exact/ancestor namespace cells and releases shared registrations idempotently" $ do + registry <- newTVarIO Map.empty + (pm, release1) <- atomically (Notify.registerNamespace registry "pm") + (same, release2) <- atomically (Notify.registerNamespace registry "pm") + (nested, release3) <- atomically (Notify.registerNamespace registry "pm:a") + (empty, release4) <- atomically (Notify.registerNamespace registry "") + (colon, release5) <- atomically (Notify.registerNamespace registry "pm:") + (pm == same) `shouldBe` True + atomically (Notify.notifyNamespace registry "pm:a:b") + mapM readTVarIO [pm, nested, empty, colon] `shouldReturn` [1, 1, 0, 0] + atomically (Notify.notifyNamespace registry "pm::child" >> Notify.notifyNamespace registry ":child") + mapM readTVarIO [pm, nested, empty, colon] `shouldReturn` [2, 1, 1, 1] + atomically (release1 >> release1) + Map.size <$> readTVarIO registry `shouldReturn` 4 + atomically (release2 >> release3 >> release4 >> release5) + Map.null <$> readTVarIO registry `shouldReturn` True + (replacement, release6) <- atomically (Notify.registerNamespace registry "pm") + atomically (release2 >> Notify.notifyNamespace registry "pm") + readTVarIO replacement `shouldReturn` 1 + atomically release6 + -- Empty registry path must not even evaluate a category. + atomically (Notify.notifyNamespace registry (error "empty registry evaluated category")) + + it "suppresses unrelated live fetches and recovers a lost notification at the safety tick" $ + withNamespaceSafetyPollForTest 200_000 $ + withTestStore $ \store -> do + fetches <- newIORef (0 :: Int) + seen <- newIORef [] + withNamespaceWindowHookForTest (\_ _ _ -> atomicModifyIORef' fetches (\n -> (n + 1, Nothing))) $ + withSubscription store (cfg "idle" "pm" (record seen)) $ \handle -> do + awaitLive handle + append store "noise-1" + -- Wait for the actual listener to process the unrelated notification. + await (readTVarIO (Notify.categoryGenerations (store ^. #notifier))) (Map.member "noise") + readIORef fetches `shouldReturn` 0 + await (readIORef fetches) (> 0) + -- Temporarily remove the sole registry entry to simulate a lost wake. + sql store "ALTER TABLE streams DISABLE TRIGGER stream_events_notify_insert; ALTER TABLE streams DISABLE TRIGGER stream_events_notify_update" + append store "pm:new-1" + sql store "ALTER TABLE streams ENABLE TRIGGER stream_events_notify_insert; ALTER TABLE streams ENABLE TRIGGER stream_events_notify_update" + await (positions seen) (== [2]) + + it "keeps a captured head finite and does not lose a notification during its drain" $ + withTestStore $ \store -> do + append store "pm-1" + captured <- newIORef False + seen <- newIORef [] + let inject _ _ headPosition = do + first <- atomicModifyIORef' captured (\done -> (True, not done)) + when first $ do + headPosition `shouldBe` GlobalPosition 1 + append store "pm:new-1" + await (readTVarIO (Notify.categoryGenerations (store ^. #notifier))) (Map.member "pm:new") + pure Nothing + withNamespaceWindowHookForTest inject $ + withSubscription store ((cfg "race" "pm" (record seen)) {batchSize = batch 1}) $ \handle -> do + awaitLive handle + await (positions seen) (== [1, 2]) + await (checkpoint store "race" 0) (== Just 2) + + it "never advances past an unhandled decode failure, and ignores unrelated decode failures" $ do + let reject event = pure (Left (DecodeFailure (event ^. #eventId) "test refusal")) + broken :: ConnectionSettings -> ConnectionSettings + broken settings = settings {storeSettings = defaultStoreSettings {decodeHook = Just reject}} + withTestStoreSettings broken $ \store -> do + append store "noise-1" + withSubscription store (cfg "unrelated-decode" "pm" (\_ -> expectationFailure "unrelated handler" >> pure Stop)) awaitLive + checkpoint store "unrelated-decode" 0 `shouldReturn` Just 1 + append store "pm-1" + append store "noise-1" + handle <- subscribe store ((cfg "decode" "pm" (\_ -> expectationFailure "undecodable handler" >> pure Stop)) {retryPolicy = RetryPolicy 1}) + waitWithTimeout 5_000_000 handle >>= \case + Right (Left err) -> (fromException err :: Maybe SubscriptionUndecodable) `shouldSatisfy` maybe False (const True) + other -> expectationFailure (show other) + checkpoint store "decode" 0 `shouldReturn` Just 0 + -- The alternate callback resolves only matching undecodable events. + withSubscription store ((cfg "decode" "pm" (\_ -> pure Stop)) {undecodableHandler = Just (\_ _ -> pure Continue)}) awaitLive + checkpoint store "decode" 0 `shouldReturn` Just 3 + + it "shares live namespace wakes across grouped members and reconnects the listener" $ + withNamespaceSafetyPollForTest 100_000 $ + withTestStore $ \store -> do + members <- mapM (const (newIORef [])) [0 .. 2 :: Int32] + let configs = [(cfg "live-group" "pm" (record seen)) {consumerGroup = Just (validConsumerGroup index 3), batchSize = batch 1} | (index, seen) <- zip [0 ..] members] + bracket (mapM (subscribe store) configs) (mapM_ cancel) $ \handles -> do + mapM_ awaitLive handles + forM_ [1 .. 6 :: Int] $ \n -> append store ("pm:new:" <> T.pack (show n) <> "-1") + await (concat <$> mapM positions members) ((== [1 .. 6]) . sort) + pid <- waitForListenerPid (store ^. #pool) 5_000_000 + terminateBackend (store ^. #pool) pid + append store "pm:reconnect-1" + await (concat <$> mapM positions members) ((== [1 .. 7]) . sort) + _ <- waitForListenerPidNotEqual (store ^. #pool) pid 5_000_000 + pure () + Map.null <$> readTVarIO (Notify.namespaceRegistry (store ^. #notifier)) `shouldReturn` True + + it "retains a failed empty frontier and retries its flush without another append" $ + withNamespaceSafetyPollForTest 50_000 $ + withTestStore $ \store -> do + append store "noise-1" + sql store "CREATE FUNCTION fail_empty_save() RETURNS trigger LANGUAGE plpgsql AS $$ BEGIN RAISE EXCEPTION 'injected flush failure'; END $$; CREATE TRIGGER fail_empty_save BEFORE UPDATE ON subscriptions FOR EACH ROW EXECUTE FUNCTION fail_empty_save()" + withSubscription store (cfg "flush-fault" "pm" (\_ -> pure Continue)) $ \handle -> do + awaitLive handle + checkpoint store "flush-fault" 0 `shouldReturn` Just 0 + sql store "DROP TRIGGER fail_empty_save ON subscriptions" + await (checkpoint store "flush-fault" 0) (== Just 1) + + it "releases namespace registrations when startup fails" $ + withTestStore $ \store -> do + handle <- subscribe store ((cfg "missing" "pm" (\_ -> pure Continue)) {missingCheckpointPolicy = FailIfMissing}) + waitWithTimeout 5_000_000 handle >>= \case + Right (Left _) -> pure () + other -> expectationFailure (show other) + Map.null <$> readTVarIO (Notify.namespaceRegistry (store ^. #notifier)) `shouldReturn` True + +cfg :: Text -> Text -> (RecordedEvent -> IO SubscriptionResult) -> SubscriptionConfig +cfg name namespace = defaultSubscriptionConfig (SubscriptionName name) (CategoryNamespace namespace) + +batch :: Int32 -> BatchSize +batch = either (error . show) Prelude.id . mkBatchSize + +record :: IORef [Int64] -> RecordedEvent -> IO SubscriptionResult +record ref event = do + let GlobalPosition pos = event ^. #globalPosition + atomicModifyIORef' ref (\xs -> (xs <> [pos], ())) + pure Continue + +positions :: IORef [Int64] -> IO [Int64] +positions = readIORef + +append :: KirokuStore -> Text -> IO () +append store stream = do + Right _ <- runStoreIO store (appendToStream (StreamName stream) AnyVersion [makeEvent "E" (Aeson.object [])]) + pure () + +await :: IO a -> (a -> Bool) -> IO () +await action predicate = bounded go + where + go = action >>= \value -> if predicate value then pure () else threadDelay 1000 >> go + +bounded :: IO a -> IO a +bounded action = timeout 5_000_000 action >>= maybe (fail "namespace test timed out") pure + +awaitLive :: SubscriptionHandle -> IO () +awaitLive handle = await (currentState handle) (\case Just Fsm.Live {} -> True; _ -> False) + +clean :: SubscriptionHandle -> IO () +clean handle = + waitWithTimeout 5_000_000 handle >>= \case + Right (Right ()) -> pure () + other -> expectationFailure (show other) + +checkpoint :: KirokuStore -> Text -> Int32 -> IO (Maybe Int64) +checkpoint store name index = session store (Session.statement (name, index) SQL.getCheckpointMemberStmt) + +binding :: KirokuStore -> Text -> IO (Text, Maybe Text) +binding store name = session store (Session.statement name (preparable "SELECT target_kind,target_category FROM subscriptions WHERE subscription_name=$1 AND consumer_group_member=0" (E.param (E.nonNullable E.text)) (D.singleRow ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nullable D.text))))) + +sql :: KirokuStore -> Text -> IO () +sql store = session store . Session.script + +session :: KirokuStore -> Session.Session a -> IO a +session store action = Pool.use (store ^. #pool) action >>= either (fail . show) pure diff --git a/test/Test/SubscriptionPauseResume.hs b/test/Test/SubscriptionPauseResume.hs --- a/test/Test/SubscriptionPauseResume.hs +++ b/test/Test/SubscriptionPauseResume.hs @@ -1,33 +1,32 @@ {-# 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 ()@. --} +-- | 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 (threadDelay) @@ -53,148 +52,148 @@ -- 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) + 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]) - -- Publisher and worker callbacks can arrive concurrently. - let evtHandler e = atomicModifyIORef' evtRef (\events -> (e : events, ())) - 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 = defaultBatchSize - , queueCapacity = 1 - , overflowPolicy = PauseAndResume - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , retryPolicy = defaultRetryPolicy - , eventTypeFilter = AllEventTypes - , selector = Nothing - } - handle <- subscribe store cfg - waitForLive handle - -- 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 "pauses a slow AllStreams consumer and resumes, delivering all events" $ do + evtRef <- newIORef ([] :: [KirokuEvent]) + -- Publisher and worker callbacks can arrive concurrently. + let evtHandler e = atomicModifyIORef' evtRef (\events -> (e : events, ())) + 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 = defaultBatchSize, + queueCapacity = 1, + overflowPolicy = PauseAndResume, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + retryPolicy = defaultRetryPolicy, + eventTypeFilter = AllEventTypes, + selector = Nothing + } + handle <- subscribe store cfg + waitForLive handle + -- 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 = defaultBatchSize - , queueCapacity = 1 - , overflowPolicy = DropSubscription - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , retryPolicy = defaultRetryPolicy - , eventTypeFilter = AllEventTypes - , selector = Nothing - } - handle <- subscribe store cfg - waitForLive handle - 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) + 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 = defaultBatchSize, + queueCapacity = 1, + overflowPolicy = DropSubscription, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + retryPolicy = defaultRetryPolicy, + eventTypeFilter = AllEventTypes, + selector = Nothing + } + handle <- subscribe store cfg + waitForLive handle + 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) -- These fixtures must block live delivery, not the initial catch-up read. waitForLive :: SubscriptionHandle -> IO () waitForLive handle = do - let go = do - st <- currentState handle - case st of - Just Fsm.Live{} -> pure () - _ -> threadDelay 1_000 >> go - Timeout.timeout 5_000_000 go >>= (`shouldBe` Just ()) + let go = do + st <- currentState handle + case st of + Just Fsm.Live {} -> pure () + _ -> threadDelay 1_000 >> go + Timeout.timeout 5_000_000 go >>= (`shouldBe` Just ()) diff --git a/test/Test/SubscriptionReconnect.hs b/test/Test/SubscriptionReconnect.hs --- a/test/Test/SubscriptionReconnect.hs +++ b/test/Test/SubscriptionReconnect.hs @@ -1,29 +1,28 @@ {-# 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. --} +-- | 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) @@ -44,149 +43,149 @@ 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) + 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) + 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = PauseAndResume - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , retryPolicy = defaultRetryPolicy - , eventTypeFilter = AllEventTypes - , selector = Nothing - } + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = PauseAndResume, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 () + 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 + 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 - it "resumes a database-driven live worker from processed progress" $ do - delivered <- newIORef [] - caughtUp <- newTVarIO False - processed <- newTVarIO False - failed <- newTVarIO False - recoveryCursor <- newIORef Nothing - let subName = SubscriptionName "mid-live-progress" - observe = \case - KirokuEventSubscriptionCaughtUp n _ _ | n == subName -> atomically (writeTVar caughtUp True) - _ -> pure () - inject config cursor - | SubTypes.name config /= subName = pure Nothing - | otherwise = do - live <- readTVarIO caughtUp - done <- readTVarIO processed - alreadyFailed <- readTVarIO failed - if live && done && not alreadyFailed - then do - cursor `shouldBe` GlobalPosition 1 - atomically (writeTVar failed True) - pure (Just (Left Pool.AcquisitionTimeoutUsageError)) - else do - if alreadyFailed - then do - previous <- readIORef recoveryCursor - case previous of - Nothing -> modifyIORef' recoveryCursor (const (Just cursor)) - Just _ -> pure () - else pure () - pure Nothing - handler event = do - modifyIORef' delivered ((event ^. #globalPosition) :) - if event ^. #globalPosition == GlobalPosition 1 - then atomically (writeTVar processed True) >> pure Continue - else pure Stop - cfg = defaultSubscriptionConfig subName (Category (CategoryName "midlive")) handler - withTestStoreSettings (& #eventHandler .~ Just observe) $ \store -> - withFetchBatchHookForTest inject $ do - handle <- subscribe store cfg - atomically (readTVar caughtUp >>= check) - Right _ <- runStoreIO store $ appendToStream (StreamName "midlive-1") NoStream [makeEvent "A" (Aeson.object [])] - atomically (readTVar processed >>= check) - -- Wake the live fetch once more after its first successful batch. - Right _ <- runStoreIO store $ appendToStream (StreamName "midlive-2") NoStream [makeEvent "B" (Aeson.object [])] - result <- waitWithTimeout 10_000_000 handle - case result of - Right (Right ()) -> pure () - other -> expectationFailure (show other) - readTVarIO failed `shouldReturn` True - readIORef recoveryCursor `shouldReturn` Just (GlobalPosition 1) - reverse <$> readIORef delivered `shouldReturn` [GlobalPosition 1, GlobalPosition 2] - readCheckpoint store "mid-live-progress" `shouldReturn` Just 2 + it "resumes a database-driven live worker from processed progress" $ do + delivered <- newIORef [] + caughtUp <- newTVarIO False + processed <- newTVarIO False + failed <- newTVarIO False + recoveryCursor <- newIORef Nothing + let subName = SubscriptionName "mid-live-progress" + observe = \case + KirokuEventSubscriptionCaughtUp n _ _ | n == subName -> atomically (writeTVar caughtUp True) + _ -> pure () + inject config cursor + | SubTypes.name config /= subName = pure Nothing + | otherwise = do + live <- readTVarIO caughtUp + done <- readTVarIO processed + alreadyFailed <- readTVarIO failed + if live && done && not alreadyFailed + then do + cursor `shouldBe` GlobalPosition 1 + atomically (writeTVar failed True) + pure (Just (Left Pool.AcquisitionTimeoutUsageError)) + else do + if alreadyFailed + then do + previous <- readIORef recoveryCursor + case previous of + Nothing -> modifyIORef' recoveryCursor (const (Just cursor)) + Just _ -> pure () + else pure () + pure Nothing + handler event = do + modifyIORef' delivered ((event ^. #globalPosition) :) + if event ^. #globalPosition == GlobalPosition 1 + then atomically (writeTVar processed True) >> pure Continue + else pure Stop + cfg = defaultSubscriptionConfig subName (Category (CategoryName "midlive")) handler + withTestStoreSettings (& #eventHandler .~ Just observe) $ \store -> + withFetchBatchHookForTest inject $ do + handle <- subscribe store cfg + atomically (readTVar caughtUp >>= check) + Right _ <- runStoreIO store $ appendToStream (StreamName "midlive-1") NoStream [makeEvent "A" (Aeson.object [])] + atomically (readTVar processed >>= check) + -- Wake the live fetch once more after its first successful batch. + Right _ <- runStoreIO store $ appendToStream (StreamName "midlive-2") NoStream [makeEvent "B" (Aeson.object [])] + result <- waitWithTimeout 10_000_000 handle + case result of + Right (Right ()) -> pure () + other -> expectationFailure (show other) + readTVarIO failed `shouldReturn` True + readIORef recoveryCursor `shouldReturn` Just (GlobalPosition 1) + reverse <$> readIORef delivered `shouldReturn` [GlobalPosition 1, GlobalPosition 2] + readCheckpoint store "mid-live-progress" `shouldReturn` Just 2 diff --git a/test/Test/SubscriptionRegistry.hs b/test/Test/SubscriptionRegistry.hs --- a/test/Test/SubscriptionRegistry.hs +++ b/test/Test/SubscriptionRegistry.hs @@ -1,23 +1,22 @@ {-# 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). --} +-- | 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) @@ -44,174 +43,174 @@ -- | 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 (validConsumerGroup m n) - } + (defaultSubscriptionConfig (SubscriptionName nm) (Category (CategoryName cat)) (\_ -> pure Continue)) + { consumerGroup = Just (validConsumerGroup m n) + } -- | A size-@n@ @$all@ group config for member @m@ whose handler never stops. groupAllCont :: Text -> Int32 -> Int32 -> SubscriptionConfig groupAllCont nm m n = - (defaultSubscriptionConfig (SubscriptionName nm) AllStreams (\_ -> pure Continue)) - { consumerGroup = Just (validConsumerGroup m n) - } + (defaultSubscriptionConfig (SubscriptionName nm) AllStreams (\_ -> pure Continue)) + { consumerGroup = Just (validConsumerGroup m n) + } publisherSubscriberCount :: KirokuStore -> IO Int publisherSubscriberCount store = - IntMap.size <$> readTVarIO (Pub.subscribers (store ^. #publisher)) + IntMap.size <$> readTVarIO (Pub.subscribers (store ^. #publisher)) -- | 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 + | 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 + | 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 + | 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 "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 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 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 "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 + 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 - describe "publisher queue registration" $ do - it "registers publisher queues only for non-group AllStreams subscriptions" $ - withTestStore $ \store -> do - initial <- publisherSubscriberCount store - initial `shouldBe` 0 + describe "publisher queue registration" $ do + it "registers publisher queues only for non-group AllStreams subscriptions" $ + withTestStore $ \store -> do + initial <- publisherSubscriberCount store + initial `shouldBe` 0 - hCategory <- subscribe store (defaultSubscriptionConfig (SubscriptionName "reg-cat-no-queue") (Category (CategoryName "regcat")) (\_ -> pure Continue)) - publisherSubscriberCount store `shouldReturn` 0 + hCategory <- subscribe store (defaultSubscriptionConfig (SubscriptionName "reg-cat-no-queue") (Category (CategoryName "regcat")) (\_ -> pure Continue)) + publisherSubscriberCount store `shouldReturn` 0 - hGroupCategory <- subscribe store (groupCont "reg-group-cat-no-queue" "regcat" 0 2) - publisherSubscriberCount store `shouldReturn` 0 + hGroupCategory <- subscribe store (groupCont "reg-group-cat-no-queue" "regcat" 0 2) + publisherSubscriberCount store `shouldReturn` 0 - hGroupAll <- subscribe store (groupAllCont "reg-group-all-no-queue" 0 2) - publisherSubscriberCount store `shouldReturn` 0 + hGroupAll <- subscribe store (groupAllCont "reg-group-all-no-queue" 0 2) + publisherSubscriberCount store `shouldReturn` 0 - hAll <- subscribe store (plainCont "reg-all-has-queue") - publisherSubscriberCount store `shouldReturn` 1 + hAll <- subscribe store (plainCont "reg-all-has-queue") + publisherSubscriberCount store `shouldReturn` 1 - cancel hAll - _ <- wait hAll - publisherSubscriberCount store `shouldReturn` 0 + cancel hAll + _ <- wait hAll + publisherSubscriberCount store `shouldReturn` 0 - cancel hCategory - _ <- wait hCategory - publisherSubscriberCount store `shouldReturn` 0 + cancel hCategory + _ <- wait hCategory + publisherSubscriberCount store `shouldReturn` 0 - cancel hGroupCategory - _ <- wait hGroupCategory - publisherSubscriberCount store `shouldReturn` 0 + cancel hGroupCategory + _ <- wait hGroupCategory + publisherSubscriberCount store `shouldReturn` 0 - cancel hGroupAll - _ <- wait hGroupAll - publisherSubscriberCount store `shouldReturn` 0 + cancel hGroupAll + _ <- wait hGroupAll + publisherSubscriberCount store `shouldReturn` 0 diff --git a/test/Test/SubscriptionRetryDeadLetter.hs b/test/Test/SubscriptionRetryDeadLetter.hs --- a/test/Test/SubscriptionRetryDeadLetter.hs +++ b/test/Test/SubscriptionRetryDeadLetter.hs @@ -1,25 +1,24 @@ {-# 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. --} +-- | 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 ((^.)) @@ -42,125 +41,125 @@ 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 + 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) + 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] + 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 = defaultBatchSize} - 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 "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 = defaultBatchSize} + 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 = defaultBatchSize} - 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 "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 = defaultBatchSize} + 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 = defaultBatchSize - , 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 + 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 = defaultBatchSize, + 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 --- a/test/Test/SubscriptionState.hs +++ b/test/Test/SubscriptionState.hs @@ -1,20 +1,19 @@ {-# 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). --} +-- | 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) @@ -35,11 +34,11 @@ import Test.Hspec isCatchingUp :: SubscriptionState -> Bool -isCatchingUp CatchingUp{} = True +isCatchingUp CatchingUp {} = True isCatchingUp _ = False isLive :: SubscriptionState -> Bool -isLive Live{} = True +isLive Live {} = True isLive _ = False -- Poll an FSM-state read until the predicate holds or the budget runs out. @@ -47,118 +46,118 @@ -- @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 + | 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) + 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = PauseAndResume - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 "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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = PauseAndResume, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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 = defaultBatchSize - , queueCapacity = 16 - , overflowPolicy = PauseAndResume - , consumerGroup = Nothing - , consumerGroupGuard = False - , missingCheckpointPolicy = FromBeginning - , targetBindingPolicy = AdoptUnbound - , undecodableHandler = Nothing - , handlerStallWarnAfter = Nothing - , 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 + 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 = defaultBatchSize, + queueCapacity = 16, + overflowPolicy = PauseAndResume, + consumerGroup = Nothing, + consumerGroupGuard = False, + missingCheckpointPolicy = FromBeginning, + targetBindingPolicy = AdoptUnbound, + undecodableHandler = Nothing, + handlerStallWarnAfter = Nothing, + 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/SubscriptionTarget.hs b/test/Test/SubscriptionTarget.hs --- a/test/Test/SubscriptionTarget.hs +++ b/test/Test/SubscriptionTarget.hs @@ -9,7 +9,7 @@ import Control.Monad (void) import Data.Aeson qualified as Aeson import Data.Generics.Labels () -import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) +import Data.IORef (atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) import Data.Int (Int32, Int64) import Data.Text (Text) import Data.Vector qualified as V @@ -28,160 +28,189 @@ spec :: Spec spec = do - describe "subscription configuration" $ do - it "validates batch and bridge buffer boundaries as values" $ do - mkBatchSize 0 `shouldBe` Left (InvalidBatchSize 0) - mkBatchSize (-1) `shouldBe` Left (InvalidBatchSize (-1)) - fmap batchSizeValue (mkBatchSize 1) `shouldBe` Right 1 - batchSizeValue defaultBatchSize `shouldBe` 100 - Buffer.mkStreamBufferSize 0 `shouldBe` Left (Buffer.InvalidStreamBufferSize 0) - fmap Buffer.streamBufferSizeValue (Buffer.mkStreamBufferSize 1) `shouldBe` Right 1 - it "exposes every runtime startup refusal through the parent and concrete catches" $ do - let name = SubscriptionName "hierarchy" - key = SubscriptionCheckpointKey name 0 - assertHierarchy (SubscriptionCheckpointMissing key) - assertHierarchy (ConsumerGroupGuardConflict name 0) - assertHierarchy (ConsumerGroupSizeMismatch name 2 (V.singleton 1)) - assertHierarchy (SubscriptionTargetMismatch name AllStreams (V.singleton Nothing)) - describe "checkpoint target" $ do - it "refuses accidental target reuse before delivery, then resumes after explicit rebind" $ - withTestStore $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "target-1") NoStream [makeEvent "E" (Aeson.object [])] - first <- subscribe store (cfg "retarget" AllStreams (\_ -> pure Stop)) - clean first - called <- newIORef False - let newTarget = Category (CategoryName "target") - refused <- subscribe store (cfg "retarget" newTarget (\_ -> writeIORef called True >> pure Stop)) - mismatch refused - readIORef called `shouldReturn` False - report <- rebind store "retarget" newTarget 0 - reboundMemberCount report `shouldBe` 1 - previousBindings report `shouldBe` V.singleton (Just AllStreams) - accepted <- subscribe store (cfg "retarget" newTarget (\_ -> writeIORef called True >> pure Stop)) - clean accepted - readIORef called `shouldReturn` True - rows store "retarget" `shouldReturn` [(0, "category", Just "target", 1)] - it "adopts every legacy member once and emits one bound event for the name" $ do - events <- newIORef [] - let observe e = modifyIORef' events (e :) - withTestStoreSettings (\s -> s{eventHandler = Just observe}) $ \store -> do - void $ resize store "adopt" 2 - startLive store ((cfg "adopt" AllStreams (\_ -> pure Continue)){consumerGroup = Just (validConsumerGroup 0 2)}) - startLive store ((cfg "adopt" AllStreams (\_ -> pure Continue)){consumerGroup = Just (validConsumerGroup 1 2), targetBindingPolicy = RequireBound}) - rows store "adopt" `shouldReturn` [(0, "all", Nothing, 0), (1, "all", Nothing, 0)] - seen <- readIORef events - length [() | KirokuEventSubscriptionTargetBound (SubscriptionName "adopt") AllStreams _ <- seen] `shouldBe` 1 - it "refuses unbound rows under RequireBound without changing rows or invoking the handler" $ - withTestStore $ \store -> do - void $ resize store "strict" 1 - called <- newIORef False - handle <- subscribe store ((cfg "strict" AllStreams (\_ -> writeIORef called True >> pure Continue)){targetBindingPolicy = RequireBound}) - mismatch handle - readIORef called `shouldReturn` False - rows store "strict" `shouldReturn` [(0, "unbound", Nothing, 0)] - it "refuses mixed bound/unbound siblings before inserting a missing member" $ - withTestStore $ \store -> do - void $ resize store "mixed-target" 3 - runSession store (Session.script "UPDATE subscriptions SET target_kind = 'all' WHERE subscription_name = 'mixed-target' AND consumer_group_member = 0; DELETE FROM subscriptions WHERE subscription_name = 'mixed-target' AND consumer_group_member = 2") - handle <- subscribe store ((cfg "mixed-target" AllStreams (\_ -> expectationFailure "handler ran" >> pure Stop)){consumerGroup = Just (validConsumerGroup 2 3)}) - mismatch handle - rows store "mixed-target" `shouldReturn` [(0, "all", Nothing, 0), (1, "unbound", Nothing, 0)] - it "does not adopt siblings when FailIfMissing refuses an absent member" $ - withTestStore $ \store -> do - void $ resize store "missing-member" 2 - runSession store (Session.script "DELETE FROM subscriptions WHERE subscription_name = 'missing-member' AND consumer_group_member = 1") - handle <- subscribe store ((cfg "missing-member" AllStreams (\_ -> pure Stop)){consumerGroup = Just (validConsumerGroup 1 2), missingCheckpointPolicy = FailIfMissing}) - waitWithTimeout 5_000_000 handle >>= \case - Right (Left e) -> (fromException e :: Maybe SubscriptionCheckpointMissing) `shouldSatisfy` maybe False (const True) - other -> expectationFailure (show other) - rows store "missing-member" `shouldReturn` [(0, "unbound", Nothing, 0)] - it "serializes conflicting targets on an initially absent name" $ - withTestStore $ \store -> do - [a, b] <- Async.mapConcurrently (\target -> subscribe store (cfg "competing-targets" target (\_ -> pure Continue))) [AllStreams, Category (CategoryName "other")] - outcome <- timeout 5_000_000 (Async.race (wait a) (wait b)) - case outcome of - Just (Left (Left e)) -> assertMismatch e - Just (Right (Left e)) -> assertMismatch e - other -> expectationFailure (show other) - mapM_ cancel [a, b] - length <$> rows store "competing-targets" `shouldReturn` 1 - it "preserves category binding on resize and initializes fresh names under RequireBound" $ - withTestStore $ \store -> do - let target = Category (CategoryName "preserved") - startLive store ((cfg "bound-resize" target (\_ -> pure Continue)){targetBindingPolicy = RequireBound}) - void $ resize store "bound-resize" 3 - rows store "bound-resize" `shouldReturn` [(m, "category", Just "preserved", 0) | m <- [0 .. 2]] - startLive store ((cfg "bound-resize" target (\_ -> pure Continue)){consumerGroup = Just (validConsumerGroup 2 3), targetBindingPolicy = RequireBound}) - it "rebinds all members atomically, repeats idempotently, and rolls back with the caller" $ - withTestStore $ \store -> do - void $ resize store "rebind-group" 3 - report <- rebind store "rebind-group" AllStreams 7 - reboundMemberCount report `shouldBe` 3 - previousBindings report `shouldBe` V.singleton Nothing - rows store "rebind-group" `shouldReturn` [(m, "all", Nothing, 7) | m <- [0 .. 2]] - again <- rebind store "rebind-group" AllStreams 7 - previousBindings again `shouldBe` V.singleton (Just AllStreams) - void $ runSession store $ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do - result <- rebindSubscriptionTargetTx (SubscriptionName "rebind-group") (Category (CategoryName "rollback")) (GlobalPosition 0) - Tx.condemn - pure result - rows store "rebind-group" `shouldReturn` [(m, "all", Nothing, 7) | m <- [0 .. 2]] - absent <- Pool.use (store ^. #pool) $ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write (rebindSubscriptionTargetTx (SubscriptionName "absent") AllStreams (GlobalPosition 0)) - absent `shouldSatisfy` either (const True) (const False) - it "persists target binding through an atomic dead-letter save" $ - withTestStore $ \store -> do - Right _ <- runStoreIO store $ appendToStream (StreamName "poison-target-1") NoStream [makeEvent "E" (Aeson.object [])] - withSubscription store (cfg "target-dead-letter" (Category (CategoryName "poison")) (\_ -> pure (DeadLetter (DeadLetterPoison "chosen by consumer")))) $ \_ -> do - let awaitDurable = do - persisted <- rows store "target-dead-letter" - if persisted == [(0, "category", Just "poison", 1)] - then pure () - else threadDelay 1_000 >> awaitDurable - timeout 5_000_000 awaitDurable `shouldReturn` Just () - rows store "target-dead-letter" `shouldReturn` [(0, "category", Just "poison", 1)] + describe "subscription configuration" $ do + it "validates batch and bridge buffer boundaries as values" $ do + mkBatchSize 0 `shouldBe` Left (InvalidBatchSize 0) + mkBatchSize (-1) `shouldBe` Left (InvalidBatchSize (-1)) + fmap batchSizeValue (mkBatchSize 1) `shouldBe` Right 1 + batchSizeValue defaultBatchSize `shouldBe` 100 + Buffer.mkStreamBufferSize 0 `shouldBe` Left (Buffer.InvalidStreamBufferSize 0) + fmap Buffer.streamBufferSizeValue (Buffer.mkStreamBufferSize 1) `shouldBe` Right 1 + it "exposes every runtime startup refusal through the parent and concrete catches" $ do + let name = SubscriptionName "hierarchy" + key = SubscriptionCheckpointKey name 0 + assertHierarchy (SubscriptionCheckpointMissing key) + assertHierarchy (ConsumerGroupGuardConflict name 0) + assertHierarchy (ConsumerGroupSizeMismatch name 2 (V.singleton 1)) + assertHierarchy (SubscriptionTargetMismatch name AllStreams (V.singleton Nothing)) + describe "checkpoint target" $ do + it "refuses accidental target reuse before delivery, then resumes after explicit rebind" $ + withTestStore $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "target-1") NoStream [makeEvent "E" (Aeson.object [])] + first <- subscribe store (cfg "retarget" AllStreams (\_ -> pure Stop)) + clean first + called <- newIORef False + let newTarget = Category (CategoryName "target") + refused <- subscribe store (cfg "retarget" newTarget (\_ -> writeIORef called True >> pure Stop)) + mismatch refused + readIORef called `shouldReturn` False + report <- rebind store "retarget" newTarget 0 + reboundMemberCount report `shouldBe` 1 + previousBindings report `shouldBe` V.singleton (Just AllStreams) + accepted <- subscribe store (cfg "retarget" newTarget (\_ -> writeIORef called True >> pure Stop)) + clean accepted + readIORef called `shouldReturn` True + rows store "retarget" `shouldReturn` [(0, "category", Just "target", 1)] + it "emits a target mismatch followed by exactly one crashed stop before wait returns" $ do + events <- newIORef [] + let observe e = atomicModifyIORef' events (\seen -> (e : seen, ())) + subName = SubscriptionName "observe-target" + config = (cfg "observe-target" AllStreams (\_ -> pure Continue)) {consumerGroup = Just (validConsumerGroup 1 2), targetBindingPolicy = RequireBound} + refusal = SubscriptionTargetMismatch subName AllStreams (V.singleton Nothing) + withTestStoreSettings (\s -> s {eventHandler = Just observe}) $ \store -> do + void $ resize store "observe-target" 2 + handle <- subscribe store config + mismatch handle + seen <- reverse <$> readIORef events + let lifecycle = + [ e + | e <- seen, + case e of + KirokuEventSubscriptionTargetMismatch {} -> True + KirokuEventSubscriptionStopped {} -> True + _ -> False + ] + case lifecycle of + [KirokuEventSubscriptionTargetMismatch actual grp, KirokuEventSubscriptionStopped n pos (StopWorkerCrashed err) stopGrp] -> do + actual `shouldBe` refusal + grp `shouldBe` GroupMember 1 2 + n `shouldBe` subName + pos `shouldBe` GlobalPosition 0 + stopGrp `shouldBe` grp + fromException err `shouldBe` Just refusal + _ -> expectationFailure ("unexpected refusal lifecycle: " <> show lifecycle) + it "adopts every legacy member once and emits one bound event for the name" $ do + events <- newIORef [] + let observe e = modifyIORef' events (e :) + withTestStoreSettings (\s -> s {eventHandler = Just observe}) $ \store -> do + void $ resize store "adopt" 2 + startLive store ((cfg "adopt" AllStreams (\_ -> pure Continue)) {consumerGroup = Just (validConsumerGroup 0 2)}) + startLive store ((cfg "adopt" AllStreams (\_ -> pure Continue)) {consumerGroup = Just (validConsumerGroup 1 2), targetBindingPolicy = RequireBound}) + rows store "adopt" `shouldReturn` [(0, "all", Nothing, 0), (1, "all", Nothing, 0)] + seen <- readIORef events + length [() | KirokuEventSubscriptionTargetBound (SubscriptionName "adopt") AllStreams _ <- seen] `shouldBe` 1 + it "refuses unbound rows under RequireBound without changing rows or invoking the handler" $ + withTestStore $ \store -> do + void $ resize store "strict" 1 + called <- newIORef False + handle <- subscribe store ((cfg "strict" AllStreams (\_ -> writeIORef called True >> pure Continue)) {targetBindingPolicy = RequireBound}) + mismatch handle + readIORef called `shouldReturn` False + rows store "strict" `shouldReturn` [(0, "unbound", Nothing, 0)] + it "refuses mixed bound/unbound siblings before inserting a missing member" $ + withTestStore $ \store -> do + void $ resize store "mixed-target" 3 + runSession store (Session.script "UPDATE subscriptions SET target_kind = 'all' WHERE subscription_name = 'mixed-target' AND consumer_group_member = 0; DELETE FROM subscriptions WHERE subscription_name = 'mixed-target' AND consumer_group_member = 2") + handle <- subscribe store ((cfg "mixed-target" AllStreams (\_ -> expectationFailure "handler ran" >> pure Stop)) {consumerGroup = Just (validConsumerGroup 2 3)}) + mismatch handle + rows store "mixed-target" `shouldReturn` [(0, "all", Nothing, 0), (1, "unbound", Nothing, 0)] + it "does not adopt siblings when FailIfMissing refuses an absent member" $ + withTestStore $ \store -> do + void $ resize store "missing-member" 2 + runSession store (Session.script "DELETE FROM subscriptions WHERE subscription_name = 'missing-member' AND consumer_group_member = 1") + handle <- subscribe store ((cfg "missing-member" AllStreams (\_ -> pure Stop)) {consumerGroup = Just (validConsumerGroup 1 2), missingCheckpointPolicy = FailIfMissing}) + waitWithTimeout 5_000_000 handle >>= \case + Right (Left e) -> (fromException e :: Maybe SubscriptionCheckpointMissing) `shouldSatisfy` maybe False (const True) + other -> expectationFailure (show other) + rows store "missing-member" `shouldReturn` [(0, "unbound", Nothing, 0)] + it "serializes conflicting targets on an initially absent name" $ + withTestStore $ \store -> do + [a, b] <- Async.mapConcurrently (\target -> subscribe store (cfg "competing-targets" target (\_ -> pure Continue))) [AllStreams, Category (CategoryName "other")] + outcome <- timeout 5_000_000 (Async.race (wait a) (wait b)) + case outcome of + Just (Left (Left e)) -> assertMismatch e + Just (Right (Left e)) -> assertMismatch e + other -> expectationFailure (show other) + mapM_ cancel [a, b] + length <$> rows store "competing-targets" `shouldReturn` 1 + it "preserves category binding on resize and initializes fresh names under RequireBound" $ + withTestStore $ \store -> do + let target = Category (CategoryName "preserved") + startLive store ((cfg "bound-resize" target (\_ -> pure Continue)) {targetBindingPolicy = RequireBound}) + void $ resize store "bound-resize" 3 + rows store "bound-resize" `shouldReturn` [(m, "category", Just "preserved", 0) | m <- [0 .. 2]] + startLive store ((cfg "bound-resize" target (\_ -> pure Continue)) {consumerGroup = Just (validConsumerGroup 2 3), targetBindingPolicy = RequireBound}) + it "rebinds all members atomically, repeats idempotently, and rolls back with the caller" $ + withTestStore $ \store -> do + void $ resize store "rebind-group" 3 + report <- rebind store "rebind-group" AllStreams 7 + reboundMemberCount report `shouldBe` 3 + previousBindings report `shouldBe` V.singleton Nothing + rows store "rebind-group" `shouldReturn` [(m, "all", Nothing, 7) | m <- [0 .. 2]] + again <- rebind store "rebind-group" AllStreams 7 + previousBindings again `shouldBe` V.singleton (Just AllStreams) + void $ runSession store $ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write $ do + result <- rebindSubscriptionTargetTx (SubscriptionName "rebind-group") (Category (CategoryName "rollback")) (GlobalPosition 0) + Tx.condemn + pure result + rows store "rebind-group" `shouldReturn` [(m, "all", Nothing, 7) | m <- [0 .. 2]] + absent <- Pool.use (store ^. #pool) $ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write (rebindSubscriptionTargetTx (SubscriptionName "absent") AllStreams (GlobalPosition 0)) + absent `shouldSatisfy` either (const True) (const False) + it "persists target binding through an atomic dead-letter save" $ + withTestStore $ \store -> do + Right _ <- runStoreIO store $ appendToStream (StreamName "poison-target-1") NoStream [makeEvent "E" (Aeson.object [])] + withSubscription store (cfg "target-dead-letter" (Category (CategoryName "poison")) (\_ -> pure (DeadLetter (DeadLetterPoison "chosen by consumer")))) $ \_ -> do + let awaitDurable = do + persisted <- rows store "target-dead-letter" + if persisted == [(0, "category", Just "poison", 1)] + then pure () + else threadDelay 1_000 >> awaitDurable + timeout 5_000_000 awaitDurable `shouldReturn` Just () + rows store "target-dead-letter" `shouldReturn` [(0, "category", Just "poison", 1)] assertHierarchy :: (Exception e, Eq e) => e -> IO () assertHierarchy refusal = do - parent <- try (throwIO refusal) :: IO (Either SomeSubscriptionStartupFailure ()) - case parent of - Left caught -> fromException (toException caught) `shouldBe` Just refusal - Right () -> expectationFailure "parent catch did not match" + parent <- try (throwIO refusal) :: IO (Either SomeSubscriptionStartupFailure ()) + case parent of + Left caught -> fromException (toException caught) `shouldBe` Just refusal + Right () -> expectationFailure "parent catch did not match" cfg :: Text -> SubscriptionTarget -> EventHandler -> SubscriptionConfig cfg name = defaultSubscriptionConfig (SubscriptionName name) clean :: SubscriptionHandle -> IO () clean handle = - waitWithTimeout 5_000_000 handle >>= \case - Right (Right ()) -> pure () - other -> expectationFailure (show other) + waitWithTimeout 5_000_000 handle >>= \case + Right (Right ()) -> pure () + other -> expectationFailure (show other) assertMismatch :: SomeException -> IO () assertMismatch e = do - (fromException e :: Maybe SubscriptionTargetMismatch) `shouldSatisfy` maybe False (const True) - (fromException e :: Maybe SomeSubscriptionStartupFailure) `shouldSatisfy` maybe False (const True) + (fromException e :: Maybe SubscriptionTargetMismatch) `shouldSatisfy` maybe False (const True) + (fromException e :: Maybe SomeSubscriptionStartupFailure) `shouldSatisfy` maybe False (const True) mismatch :: SubscriptionHandle -> IO () mismatch handle = - waitWithTimeout 5_000_000 handle >>= \case - Right (Left e) -> assertMismatch e - other -> expectationFailure (show other) + waitWithTimeout 5_000_000 handle >>= \case + Right (Left e) -> assertMismatch e + other -> expectationFailure (show other) startLive :: KirokuStore -> SubscriptionConfig -> IO () startLive store config = withSubscription store config $ \handle -> do - result <- timeout 5_000_000 (awaitLive handle) - result `shouldBe` Just () + result <- timeout 5_000_000 (awaitLive handle) + result `shouldBe` Just () where awaitLive handle = - currentState handle >>= \case - Just state | stateName state == "live" -> pure () - _ -> threadDelay 1_000 >> awaitLive handle + currentState handle >>= \case + Just state | stateName state == "live" -> pure () + _ -> threadDelay 1_000 >> awaitLive handle runSession :: KirokuStore -> Session.Session a -> IO a runSession store session = Pool.use (store ^. #pool) session >>= either (fail . show) pure resize :: KirokuStore -> Text -> Int32 -> IO ConsumerGroupResizeReport resize store name n = let Right size = mkConsumerGroupSize n in runSession store $ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write (resizeConsumerGroupTx (SubscriptionName name) size) + rebind :: KirokuStore -> Text -> SubscriptionTarget -> Int64 -> IO SubscriptionTargetRebindReport rebind store name target position = runSession store $ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write (rebindSubscriptionTargetTx (SubscriptionName name) target (GlobalPosition position)) @@ -189,7 +218,7 @@ rows store name = V.toList <$> runSession store (Session.statement name stmt) where stmt = - preparable - "SELECT consumer_group_member, target_kind, target_category, last_seen FROM subscriptions WHERE subscription_name = $1 ORDER BY consumer_group_member" - (E.param (E.nonNullable E.text)) - (D.rowVector ((,,,) <$> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.text) <*> D.column (D.nullable D.text) <*> D.column (D.nonNullable D.int8))) + preparable + "SELECT consumer_group_member, target_kind, target_category, last_seen FROM subscriptions WHERE subscription_name = $1 ORDER BY consumer_group_member" + (E.param (E.nonNullable E.text)) + (D.rowVector ((,,,) <$> D.column (D.nonNullable D.int4) <*> D.column (D.nonNullable D.text) <*> D.column (D.nullable D.text) <*> D.column (D.nonNullable D.int8))) diff --git a/test/Test/Transaction.hs b/test/Test/Transaction.hs --- a/test/Test/Transaction.hs +++ b/test/Test/Transaction.hs @@ -1,8 +1,7 @@ -{- | 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. --} +-- | 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) @@ -28,400 +27,398 @@ 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 "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) - it "preserves SQLSTATE and message for an opaque foreign-key failure" $ \store -> do - createForeignKeyTables (store ^. #pool) - result <- - runStoreIO store $ - runTransaction $ - Tx.statement () insertMissingForeignKeyStmt - case result of - Left (UnexpectedServerError code message) -> do - code `shouldBe` "23503" - T.toLower message `shouldSatisfy` T.isInfixOf "foreign key" - Left (StreamNotFound (StreamName "")) -> - expectationFailure "foreign-key failure was misclassified as a missing stream" - other -> - expectationFailure ("Expected UnexpectedServerError 23503, got: " <> show other) + it "preserves SQLSTATE and message for an opaque foreign-key failure" $ \store -> do + createForeignKeyTables (store ^. #pool) + result <- + runStoreIO store $ + runTransaction $ + Tx.statement () insertMissingForeignKeyStmt + case result of + Left (UnexpectedServerError code message) -> do + code `shouldBe` "23503" + T.toLower message `shouldSatisfy` T.isInfixOf "foreign key" + Left (StreamNotFound (StreamName "")) -> + expectationFailure "foreign-key failure was misclassified as a missing stream" + other -> + expectationFailure ("Expected UnexpectedServerError 23503, got: " <> show other) - 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) + 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 "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 + 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 - it "surfaces duplicate caller-supplied event ids as DuplicateEvent" $ \store -> do - eid <- EventId <$> V7.genUUID - let evt = eventWithId eid - prepared <- prepareEventsIO [evt] - now <- getCurrentTime - first <- - runStoreIO store $ - runTransaction $ - appendToStreamTx (StreamName "txn-duplicate-source-1") NoStream prepared now - first `shouldSatisfy` either (const False) isRight + it "surfaces duplicate caller-supplied event ids as DuplicateEvent" $ \store -> do + eid <- EventId <$> V7.genUUID + let evt = eventWithId eid + prepared <- prepareEventsIO [evt] + now <- getCurrentTime + first <- + runStoreIO store $ + runTransaction $ + appendToStreamTx (StreamName "txn-duplicate-source-1") NoStream prepared now + first `shouldSatisfy` either (const False) isRight - duplicate <- - runStoreIO store $ - runTransaction $ - appendToStreamTx (StreamName "txn-duplicate-target-1") NoStream prepared now - duplicate `shouldSatisfy` isDuplicateEvent + duplicate <- + runStoreIO store $ + runTransaction $ + appendToStreamTx (StreamName "txn-duplicate-target-1") NoStream prepared now + duplicate `shouldSatisfy` isDuplicateEvent - 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) + 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 "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 "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 + 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 - it "rejects oversized stream names before opening any transaction" $ \store -> do - createSideTable (store ^. #pool) - let over = StreamName (T.replicate 513 "t") - result <- - runStoreIO store $ - runTransactionAppending - over - AnyVersion - [makeEvent "Should" (Aeson.object [])] - ( \ar -> do - let StreamId sid = ar ^. #streamId - Tx.statement (sid, "should-never-run") insertSideRowStmt - pure ar - ) - result `shouldBe` Right (Left (StreamNameTooLong over 513)) - runStoreIO store (getStream over) `shouldReturn` Right Nothing - rows <- countSideTable (store ^. #pool) - rows `shouldBe` 0 + it "rejects oversized stream names before opening any transaction" $ \store -> do + createSideTable (store ^. #pool) + let over = StreamName (T.replicate 513 "t") + result <- + runStoreIO store $ + runTransactionAppending + over + AnyVersion + [makeEvent "Should" (Aeson.object [])] + ( \ar -> do + let StreamId sid = ar ^. #streamId + Tx.statement (sid, "should-never-run") insertSideRowStmt + pure ar + ) + result `shouldBe` Right (Left (StreamNameTooLong over 513)) + runStoreIO store (getStream over) `shouldReturn` Right Nothing + rows <- countSideTable (store ^. #pool) + rows `shouldBe` 0 - it "rejects empty event batches before opening a transaction" $ \store -> do - createSideTable (store ^. #pool) - result <- - runStoreIO store $ - runTransactionAppending - (StreamName "txn-wrapper-empty-1") - NoStream - [] - ( \ar -> do - let StreamId sid = ar ^. #streamId - Tx.statement (sid, "should-never-run") insertSideRowStmt - pure ar - ) - result `shouldBe` Right (Left (EmptyAppendBatch (StreamName "txn-wrapper-empty-1"))) - runStoreIO store (getStream (StreamName "txn-wrapper-empty-1")) `shouldReturn` Right Nothing - rows <- countSideTable (store ^. #pool) - rows `shouldBe` 0 + it "rejects empty event batches before opening a transaction" $ \store -> do + createSideTable (store ^. #pool) + result <- + runStoreIO store $ + runTransactionAppending + (StreamName "txn-wrapper-empty-1") + NoStream + [] + ( \ar -> do + let StreamId sid = ar ^. #streamId + Tx.statement (sid, "should-never-run") insertSideRowStmt + pure ar + ) + result `shouldBe` Right (Left (EmptyAppendBatch (StreamName "txn-wrapper-empty-1"))) + runStoreIO store (getStream (StreamName "txn-wrapper-empty-1")) `shouldReturn` Right Nothing + rows <- countSideTable (store ^. #pool) + rows `shouldBe` 0 - it "surfaces duplicate caller-supplied event ids as DuplicateEvent" $ \store -> do - eid <- EventId <$> V7.genUUID - let evt = eventWithId eid - first <- - runStoreIO store $ - runTransactionAppending - (StreamName "txn-wrapper-duplicate-source-1") - NoStream - [evt] - pure - first `shouldSatisfy` either (const False) isRight + it "surfaces duplicate caller-supplied event ids as DuplicateEvent" $ \store -> do + eid <- EventId <$> V7.genUUID + let evt = eventWithId eid + first <- + runStoreIO store $ + runTransactionAppending + (StreamName "txn-wrapper-duplicate-source-1") + NoStream + [evt] + pure + first `shouldSatisfy` either (const False) isRight - duplicate <- - runStoreIO store $ - runTransactionAppending - (StreamName "txn-wrapper-duplicate-target-1") - NoStream - [evt] - pure - duplicate `shouldSatisfy` isDuplicateEvent + duplicate <- + runStoreIO store $ + runTransactionAppending + (StreamName "txn-wrapper-duplicate-target-1") + NoStream + [evt] + pure + duplicate `shouldSatisfy` isDuplicateEvent -- --------------------------------------------------------------------------- -- Local statements and pool-side helpers -- --------------------------------------------------------------------------- -{- | Trivial @SELECT 1@ used to verify 'runTransaction' wiring without -depending on any schema state. --} +-- | 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))) + 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 + unpreparable + "CREATE TABLE IF NOT EXISTS test_side_table \ + \(id BIGINT PRIMARY KEY, payload TEXT NOT NULL)" + E.noParams + D.noResult createForeignKeyParentStmt :: Statement () () createForeignKeyParentStmt = - unpreparable - "CREATE TABLE IF NOT EXISTS test_tx_parent (id BIGINT PRIMARY KEY)" - E.noParams - D.noResult + unpreparable + "CREATE TABLE IF NOT EXISTS test_tx_parent (id BIGINT PRIMARY KEY)" + E.noParams + D.noResult createForeignKeyChildStmt :: Statement () () createForeignKeyChildStmt = - unpreparable - "CREATE TABLE IF NOT EXISTS test_tx_child (parent_id BIGINT NOT NULL REFERENCES test_tx_parent(id))" - E.noParams - D.noResult + unpreparable + "CREATE TABLE IF NOT EXISTS test_tx_child (parent_id BIGINT NOT NULL REFERENCES test_tx_parent(id))" + E.noParams + D.noResult insertMissingForeignKeyStmt :: Statement () () insertMissingForeignKeyStmt = - preparable - "INSERT INTO test_tx_child (parent_id) VALUES (999999)" - E.noParams - D.noResult + preparable + "INSERT INTO test_tx_child (parent_id) VALUES (999999)" + 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. --} +-- | 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 + 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))) + 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 () + r <- Pool.use pool (Session.statement () createSideTableStmt) + case r of + Left err -> error ("createSideTable failed: " <> show err) + Right () -> pure () createForeignKeyTables :: Pool -> IO () createForeignKeyTables pool = do - parent <- Pool.use pool (Session.statement () createForeignKeyParentStmt) - child <- Pool.use pool (Session.statement () createForeignKeyChildStmt) - case (parent, child) of - (Right (), Right ()) -> pure () - other -> error ("createForeignKeyTables failed: " <> show other) + parent <- Pool.use pool (Session.statement () createForeignKeyParentStmt) + child <- Pool.use pool (Session.statement () createForeignKeyChildStmt) + case (parent, child) of + (Right (), Right ()) -> pure () + other -> error ("createForeignKeyTables failed: " <> show other) 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 + r <- Pool.use pool (Session.statement () countSideTableStmt) + case r of + Left err -> error ("countSideTable failed: " <> show err) + Right n -> pure n isRight :: Either a b -> Bool isRight = \case - Right _ -> True - Left _ -> False + Right _ -> True + Left _ -> False isDuplicateEvent :: Either StoreError a -> Bool isDuplicateEvent = \case - Left (DuplicateEvent _) -> True - _ -> False + Left (DuplicateEvent _) -> True + _ -> False eventWithId :: EventId -> EventData eventWithId eid = - EventData - { eventId = Just eid - , eventType = EventType "Created" - , payload = Aeson.object [] - , metadata = Nothing - , causationId = Nothing - , correlationId = Nothing - } + EventData + { eventId = Just eid, + eventType = EventType "Created", + payload = Aeson.object [], + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } diff --git a/test/Test/TruncateBefore.hs b/test/Test/TruncateBefore.hs --- a/test/Test/TruncateBefore.hs +++ b/test/Test/TruncateBefore.hs @@ -1,15 +1,14 @@ -{- | Tests for the logical truncate-before marker (close-the-book -compaction, ExecPlan docs/plans/65). - -The marker is a per-stream cursor that hides a prefix from the /ordered -per-stream/ reads ('readStreamForward' / 'readStreamBackward' and the paged -'readStreamForwardStream') while leaving the global @$all@ log, category -reads, and the physical row count untouched. The distinguishing property — -and the single most important assertion here — is that after a truncate the -@$all@ log and 'readCategory' still return the full history and -'countEvents' is unchanged: nothing is deleted, only hidden, and the -operation is fully reversible. --} +-- | Tests for the logical truncate-before marker (close-the-book +-- compaction, ExecPlan docs/plans/65). +-- +-- The marker is a per-stream cursor that hides a prefix from the /ordered +-- per-stream/ reads ('readStreamForward' / 'readStreamBackward' and the paged +-- 'readStreamForwardStream') while leaving the global @$all@ log, category +-- reads, and the physical row count untouched. The distinguishing property — +-- and the single most important assertion here — is that after a truncate the +-- @$all@ log and 'readCategory' still return the full history and +-- 'countEvents' is unchanged: nothing is deleted, only hidden, and the +-- operation is fully reversible. module Test.TruncateBefore (spec) where import Control.Lens ((^.)) @@ -25,101 +24,101 @@ -- | Append @n@ events @E1 .. En@ to a fresh stream and return its name. seedStream :: KirokuStore -> StreamName -> Int -> IO () seedStream store name n = do - let events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. n]] - Right _ <- runStoreIO store $ appendToStream name NoStream events - pure () + let events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. n]] + Right _ <- runStoreIO store $ appendToStream name NoStream events + pure () -- | The per-stream versions returned by a forward read, in order. forwardVersions :: KirokuStore -> StreamName -> IO [StreamVersion] forwardVersions store name = do - Right v <- runStoreIO store $ readStreamForward name (StreamVersion 0) 100 - pure (map (^. #streamVersion) (V.toList v)) + Right v <- runStoreIO store $ readStreamForward name (StreamVersion 0) 100 + pure (map (^. #streamVersion) (V.toList v)) spec :: Spec spec = describe "TruncateBefore" $ - around withTestStore $ do - it "bounds per-stream reads to the kept suffix" $ \store -> do - let name = StreamName "preference-abc" - seedStream store name 6 -- versions 1..6; treat v6 as the snapshot - Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 6) + around withTestStore $ do + it "bounds per-stream reads to the kept suffix" $ \store -> do + let name = StreamName "preference-abc" + seedStream store name 6 -- versions 1..6; treat v6 as the snapshot + Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 6) - forwardVersions store name `shouldReturn` [StreamVersion 6] + forwardVersions store name `shouldReturn` [StreamVersion 6] - Right back <- runStoreIO store $ readStreamBackward name (StreamVersion 0) 100 - map (^. #streamVersion) (V.toList back) `shouldBe` [StreamVersion 6] + Right back <- runStoreIO store $ readStreamBackward name (StreamVersion 0) 100 + map (^. #streamVersion) (V.toList back) `shouldBe` [StreamVersion 6] - it "leaves the $all global log and category reads intact" $ \store -> do - let name = StreamName "preference-abc" - seedStream store name 6 - countBefore <- countEvents store - Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 6) + it "leaves the $all global log and category reads intact" $ \store -> do + let name = StreamName "preference-abc" + seedStream store name 6 + countBefore <- countEvents store + Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 6) - -- \$all global log still returns the full history. - Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 1000 - length (V.toList allEvents) `shouldBe` 6 + -- \$all global log still returns the full history. + Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 1000 + length (V.toList allEvents) `shouldBe` 6 - -- Category read still returns the full history. - Right catEvents <- runStoreIO store $ readCategory (CategoryName "preference") (GlobalPosition 0) 1000 - length (V.toList catEvents) `shouldBe` 6 + -- Category read still returns the full history. + Right catEvents <- runStoreIO store $ readCategory (CategoryName "preference") (GlobalPosition 0) 1000 + length (V.toList catEvents) `shouldBe` 6 - -- Nothing was physically deleted. - countAfter <- countEvents store - countAfter `shouldBe` countBefore + -- Nothing was physically deleted. + countAfter <- countEvents store + countAfter `shouldBe` countBefore - it "is reversible via clearStreamTruncateBefore" $ \store -> do - let name = StreamName "preference-abc" - seedStream store name 6 - Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 6) - forwardVersions store name `shouldReturn` [StreamVersion 6] + it "is reversible via clearStreamTruncateBefore" $ \store -> do + let name = StreamName "preference-abc" + seedStream store name 6 + Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 6) + forwardVersions store name `shouldReturn` [StreamVersion 6] - Right (Just _) <- runStoreIO store $ clearStreamTruncateBefore name - forwardVersions store name - `shouldReturn` map StreamVersion [1 .. 6] + Right (Just _) <- runStoreIO store $ clearStreamTruncateBefore name + forwardVersions store name + `shouldReturn` map StreamVersion [1 .. 6] - it "is idempotent" $ \store -> do - let name = StreamName "preference-abc" - seedStream store name 6 - Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 4) - first <- forwardVersions store name - Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 4) - second <- forwardVersions store name - first `shouldBe` [StreamVersion 4, StreamVersion 5, StreamVersion 6] - second `shouldBe` first + it "is idempotent" $ \store -> do + let name = StreamName "preference-abc" + seedStream store name 6 + Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 4) + first <- forwardVersions store name + Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 4) + second <- forwardVersions store name + first `shouldBe` [StreamVersion 4, StreamVersion 5, StreamVersion 6] + second `shouldBe` first - it "applies across paged reads" $ \store -> do - let name = StreamName "preference-abc" - seedStream store name 6 - Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 4) - -- Page size 2 forces multiple pages across the kept suffix. - Right streamed <- - runStoreIO store $ - Stream.toList $ - fmap (^. #streamVersion) (readStreamForwardStream name (StreamVersion 0) 2) - streamed `shouldBe` [StreamVersion 4, StreamVersion 5, StreamVersion 6] + it "applies across paged reads" $ \store -> do + let name = StreamName "preference-abc" + seedStream store name 6 + Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 4) + -- Page size 2 forces multiple pages across the kept suffix. + Right streamed <- + runStoreIO store $ + Stream.toList $ + fmap (^. #streamVersion) (readStreamForwardStream name (StreamVersion 0) 2) + streamed `shouldBe` [StreamVersion 4, StreamVersion 5, StreamVersion 6] - it "reflects the marker in getStream" $ \store -> do - let name = StreamName "preference-abc" - seedStream store name 6 - Right (Just info0) <- runStoreIO store $ getStream name - (info0 ^. #truncateBefore) `shouldBe` StreamVersion 0 - Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 3) - Right (Just info1) <- runStoreIO store $ getStream name - (info1 ^. #truncateBefore) `shouldBe` StreamVersion 3 + it "reflects the marker in getStream" $ \store -> do + let name = StreamName "preference-abc" + seedStream store name 6 + Right (Just info0) <- runStoreIO store $ getStream name + (info0 ^. #truncateBefore) `shouldBe` StreamVersion 0 + Right (Just _) <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 3) + Right (Just info1) <- runStoreIO store $ getStream name + (info1 ^. #truncateBefore) `shouldBe` StreamVersion 3 - it "returns Nothing for missing or soft-deleted streams" $ \store -> do - Right missing <- runStoreIO store $ setStreamTruncateBefore (StreamName "does-not-exist") (StreamVersion 1) - missing `shouldBe` Nothing + it "returns Nothing for missing or soft-deleted streams" $ \store -> do + Right missing <- runStoreIO store $ setStreamTruncateBefore (StreamName "does-not-exist") (StreamVersion 1) + missing `shouldBe` Nothing - let name = StreamName "preference-abc" - seedStream store name 3 - Right (Just _) <- runStoreIO store $ softDeleteStream name - Right deleted <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 1) - deleted `shouldBe` Nothing + let name = StreamName "preference-abc" + seedStream store name 3 + Right (Just _) <- runStoreIO store $ softDeleteStream name + Right deleted <- runStoreIO store $ setStreamTruncateBefore name (StreamVersion 1) + deleted `shouldBe` Nothing - it "rejects $all with ReservedStreamName" $ \store -> do - result <- runStoreIO store $ setStreamTruncateBefore (StreamName "$all") (StreamVersion 1) - case result of - Left (ReservedStreamName (StreamName "$all")) -> pure () - other -> - expectationFailure - ("Expected Left (ReservedStreamName \"$all\"), got: " <> show other) + it "rejects $all with ReservedStreamName" $ \store -> do + result <- runStoreIO store $ setStreamTruncateBefore (StreamName "$all") (StreamVersion 1) + case result of + Left (ReservedStreamName (StreamName "$all")) -> pure () + other -> + expectationFailure + ("Expected Left (ReservedStreamName \"$all\"), got: " <> show other) diff --git a/test/Test/UniqueViolationMapping.hs b/test/Test/UniqueViolationMapping.hs --- a/test/Test/UniqueViolationMapping.hs +++ b/test/Test/UniqueViolationMapping.hs @@ -11,83 +11,83 @@ spec :: Spec spec = describe "unique violation mapping" $ do - let eid = EventId (UUID.fromWords 0x01234567 0x89ab7def 0x80123456 0x7890abcd) - scalar = "Key (event_id)=(01234567-89ab-7def-8012-34567890abcd) already exists." - composite = "Key (event_id, stream_id)=(01234567-89ab-7def-8012-34567890abcd, 42) already exists." - fallback = WrongExpectedVersion (StreamName "orders-1") AnyVersion (StreamVersion 0) - mapAppend = mapUsageError "orders-1" AnyVersion - cases = - [ ("events_pkey", scalar, DuplicateEvent (Just eid)) - , ("stream_events_pkey", composite, DuplicateEvent (Just eid)) - , ("ix_streams_stream_name", "Key (stream_name)=(orders-1) already exists.", StreamAlreadyExists (StreamName "orders-1")) - , ("ux_stream_events_stream_version", "Key (stream_id, stream_version)=(42, 1) already exists.", UnexpectedServerError "23505" "detail-only error") - , ("unknown_constraint", scalar, fallback) - ] - forM_ cases $ \(name, detail, expected) -> do - it ("classifies the exact message constraint " <> show name) $ do - let message = constraintMessage name - outcome = case expected of - UnexpectedServerError code _ -> UnexpectedServerError code message - other -> other - mapAppend (serverUsage message (Just detail)) `shouldBe` outcome - it ("classifies a detail-only constraint " <> show name) $ - mapAppend (serverUsage "detail-only error" (Just ("constraint: " <> name <> "; " <> detail))) - `shouldBe` expected + let eid = EventId (UUID.fromWords 0x01234567 0x89ab7def 0x80123456 0x7890abcd) + scalar = "Key (event_id)=(01234567-89ab-7def-8012-34567890abcd) already exists." + composite = "Key (event_id, stream_id)=(01234567-89ab-7def-8012-34567890abcd, 42) already exists." + fallback = WrongExpectedVersion (StreamName "orders-1") AnyVersion (StreamVersion 0) + mapAppend = mapUsageError "orders-1" AnyVersion + cases = + [ ("events_pkey", scalar, DuplicateEvent (Just eid)), + ("stream_events_pkey", composite, DuplicateEvent (Just eid)), + ("ix_streams_stream_name", "Key (stream_name)=(orders-1) already exists.", StreamAlreadyExists (StreamName "orders-1")), + ("ux_stream_events_stream_version", "Key (stream_id, stream_version)=(42, 1) already exists.", UnexpectedServerError "23505" "detail-only error"), + ("unknown_constraint", scalar, fallback) + ] + forM_ cases $ \(name, detail, expected) -> do + it ("classifies the exact message constraint " <> show name) $ do + let message = constraintMessage name + outcome = case expected of + UnexpectedServerError code _ -> UnexpectedServerError code message + other -> other + mapAppend (serverUsage message (Just detail)) `shouldBe` outcome + it ("classifies a detail-only constraint " <> show name) $ + mapAppend (serverUsage "detail-only error" (Just ("constraint: " <> name <> "; " <> detail))) + `shouldBe` expected - it "does not match stream_events_pkey as events_pkey" $ - mapAppend (serverUsage (constraintMessage "stream_events_pkey") (Just composite)) - `shouldBe` DuplicateEvent (Just eid) - forM_ ["events_pkey", "stream_events_pkey", "ix_streams_stream_name", "ux_stream_events_stream_version"] $ \name -> - forM_ ["prefix_" <> name, name <> "_suffix", name <> "$suffix"] $ \other -> do - it ("rejects the message lookalike " <> show other) $ - mapAppend (serverUsage (constraintMessage other) (Just scalar)) `shouldBe` fallback - it ("rejects the detail lookalike " <> show other) $ - mapAppend (serverUsage "detail-only error" (Just (other <> "; " <> scalar))) `shouldBe` fallback + it "does not match stream_events_pkey as events_pkey" $ + mapAppend (serverUsage (constraintMessage "stream_events_pkey") (Just composite)) + `shouldBe` DuplicateEvent (Just eid) + forM_ ["events_pkey", "stream_events_pkey", "ix_streams_stream_name", "ux_stream_events_stream_version"] $ \name -> + forM_ ["prefix_" <> name, name <> "_suffix", name <> "$suffix"] $ \other -> do + it ("rejects the message lookalike " <> show other) $ + mapAppend (serverUsage (constraintMessage other) (Just scalar)) `shouldBe` fallback + it ("rejects the detail lookalike " <> show other) $ + mapAppend (serverUsage "detail-only error" (Just (other <> "; " <> scalar))) `shouldBe` fallback - it "uses the message constraint ahead of misleading detail tokens" $ - mapAppend (serverUsage (constraintMessage "ux_stream_events_stream_version") (Just ("events_pkey " <> scalar))) - `shouldBe` UnexpectedServerError "23505" (constraintMessage "ux_stream_events_stream_version") - it "retains an unknown message constraint even when detail names a known constraint" $ - mapAppend (serverUsage (constraintMessage "unknown_constraint") (Just ("events_pkey " <> scalar))) - `shouldBe` fallback - forM_ ["events_pkey", "stream_events_pkey"] $ \name -> - forM_ [Nothing, Just "unparseable localized detail"] $ \detail -> - it ("does not fabricate an event id for " <> show (name, detail)) $ - mapAppend (serverUsage (constraintMessage name) detail) `shouldBe` DuplicateEvent Nothing - it "maps a composite duplicate inside a transaction with its event id" $ - mapTransactionUsageError (serverUsage (constraintMessage "stream_events_pkey") (Just composite)) - `shouldBe` DuplicateEvent (Just eid) - it "preserves the link-specific duplicate classification" $ - mapLinkUsageError (StreamName "orders-1") (serverUsage (constraintMessage "stream_events_pkey") (Just composite)) - `shouldBe` EventAlreadyLinked (StreamName "orders-1") (Just eid) - it "accepts a quoted constraint in legacy detail" $ - mapAppend (serverUsage "detail-only error" (Just (constraintMessage "stream_events_pkey" <> "; " <> composite))) - `shouldBe` DuplicateEvent (Just eid) - it "keeps an unnamed unique violation on the conservative fallback" $ - mapAppend (serverUsage "localized message" Nothing) `shouldBe` fallback - it "does not classify a transaction constraint lookalike as a duplicate" $ - mapTransactionUsageError (serverUsage (constraintMessage "other_events_pkey") (Just scalar)) - `shouldBe` UnexpectedServerError "23505" (constraintMessage "other_events_pkey") - it "does not classify a link constraint lookalike as already linked" $ - mapLinkUsageError (StreamName "orders-1") (serverUsage (constraintMessage "stream_events_pkey_backup") (Just composite)) - `shouldBe` UnexpectedServerError "23505" (constraintMessage "stream_events_pkey_backup") - it "attributes a multi-stream name violation to the named operation" $ - attributeMultiStreamError - [(StreamName "orders-1", AnyVersion), (StreamName "orders-2", NoStream)] - (serverUsage (constraintMessage "ix_streams_stream_name") (Just "Key (stream_name)=(orders-2) already exists.")) - `shouldBe` StreamAlreadyExists (StreamName "orders-2") - it "does not attribute a multi-stream constraint lookalike to a later operation" $ - attributeMultiStreamError - [(StreamName "orders-1", AnyVersion), (StreamName "orders-2", NoStream)] - (serverUsage (constraintMessage "ix_streams_stream_name_backup") (Just "Key (stream_name)=(orders-2) already exists.")) - `shouldBe` fallback + it "uses the message constraint ahead of misleading detail tokens" $ + mapAppend (serverUsage (constraintMessage "ux_stream_events_stream_version") (Just ("events_pkey " <> scalar))) + `shouldBe` UnexpectedServerError "23505" (constraintMessage "ux_stream_events_stream_version") + it "retains an unknown message constraint even when detail names a known constraint" $ + mapAppend (serverUsage (constraintMessage "unknown_constraint") (Just ("events_pkey " <> scalar))) + `shouldBe` fallback + forM_ ["events_pkey", "stream_events_pkey"] $ \name -> + forM_ [Nothing, Just "unparseable localized detail"] $ \detail -> + it ("does not fabricate an event id for " <> show (name, detail)) $ + mapAppend (serverUsage (constraintMessage name) detail) `shouldBe` DuplicateEvent Nothing + it "maps a composite duplicate inside a transaction with its event id" $ + mapTransactionUsageError (serverUsage (constraintMessage "stream_events_pkey") (Just composite)) + `shouldBe` DuplicateEvent (Just eid) + it "preserves the link-specific duplicate classification" $ + mapLinkUsageError (StreamName "orders-1") (serverUsage (constraintMessage "stream_events_pkey") (Just composite)) + `shouldBe` EventAlreadyLinked (StreamName "orders-1") (Just eid) + it "accepts a quoted constraint in legacy detail" $ + mapAppend (serverUsage "detail-only error" (Just (constraintMessage "stream_events_pkey" <> "; " <> composite))) + `shouldBe` DuplicateEvent (Just eid) + it "keeps an unnamed unique violation on the conservative fallback" $ + mapAppend (serverUsage "localized message" Nothing) `shouldBe` fallback + it "does not classify a transaction constraint lookalike as a duplicate" $ + mapTransactionUsageError (serverUsage (constraintMessage "other_events_pkey") (Just scalar)) + `shouldBe` UnexpectedServerError "23505" (constraintMessage "other_events_pkey") + it "does not classify a link constraint lookalike as already linked" $ + mapLinkUsageError (StreamName "orders-1") (serverUsage (constraintMessage "stream_events_pkey_backup") (Just composite)) + `shouldBe` UnexpectedServerError "23505" (constraintMessage "stream_events_pkey_backup") + it "attributes a multi-stream name violation to the named operation" $ + attributeMultiStreamError + [(StreamName "orders-1", AnyVersion), (StreamName "orders-2", NoStream)] + (serverUsage (constraintMessage "ix_streams_stream_name") (Just "Key (stream_name)=(orders-2) already exists.")) + `shouldBe` StreamAlreadyExists (StreamName "orders-2") + it "does not attribute a multi-stream constraint lookalike to a later operation" $ + attributeMultiStreamError + [(StreamName "orders-1", AnyVersion), (StreamName "orders-2", NoStream)] + (serverUsage (constraintMessage "ix_streams_stream_name_backup") (Just "Key (stream_name)=(orders-2) already exists.")) + `shouldBe` fallback constraintMessage :: Text -> Text constraintMessage name = "duplicate key value violates unique constraint \"" <> name <> "\"" serverUsage :: Text -> Maybe Text -> UsageError serverUsage message detail = - SessionUsageError $ - Errors.StatementSessionError 1 0 "" [] True $ - Errors.ServerStatementError $ - Errors.ServerError "23505" message detail Nothing Nothing + SessionUsageError $ + Errors.StatementSessionError 1 0 "" [] True $ + Errors.ServerStatementError $ + Errors.ServerError "23505" message detail Nothing Nothing diff --git a/test/Test/VisibleGlobalHeadPosition.hs b/test/Test/VisibleGlobalHeadPosition.hs --- a/test/Test/VisibleGlobalHeadPosition.hs +++ b/test/Test/VisibleGlobalHeadPosition.hs @@ -14,92 +14,92 @@ spec :: Spec spec = describe "visible global head position" $ do - it "returns zero for an empty migrated store through both public runners" $ - withTestStore $ \store -> do - runStoreIO store visibleGlobalHeadPosition - `shouldReturn` Right (GlobalPosition 0) + it "returns zero for an empty migrated store through both public runners" $ + withTestStore $ \store -> do + runStoreIO store visibleGlobalHeadPosition + `shouldReturn` Right (GlobalPosition 0) - resourceResult <- - runEff - . runErrorNoCallStack @StoreError - . runKirokuStoreWith store - . runStoreResource - $ visibleGlobalHeadPosition - resourceResult `shouldBe` Right (GlobalPosition 0) + resourceResult <- + runEff + . runErrorNoCallStack @StoreError + . runKirokuStoreWith store + . runStoreResource + $ visibleGlobalHeadPosition + resourceResult `shouldBe` Right (GlobalPosition 0) - it "returns the greatest appended position" $ - withTestStore $ \store -> do - appendEvents store (StreamName "visible-head-populated") 3 - runStoreIO store visibleGlobalHeadPosition - `shouldReturn` Right (GlobalPosition 3) + it "returns the greatest appended position" $ + withTestStore $ \store -> do + appendEvents store (StreamName "visible-head-populated") 3 + runStoreIO store visibleGlobalHeadPosition + `shouldReturn` Right (GlobalPosition 3) - it "falls back across hard-deleted tails while the append frontier stays monotonic" $ - withTestStore $ \store -> do - let first = StreamName "visible-head-first" - middle = StreamName "visible-head-middle" - lastStream = StreamName "visible-head-last" - appendEvents store first 1 - appendEvents store middle 1 - appendEvents store lastStream 1 + it "falls back across hard-deleted tails while the append frontier stays monotonic" $ + withTestStore $ \store -> do + let first = StreamName "visible-head-first" + middle = StreamName "visible-head-middle" + lastStream = StreamName "visible-head-last" + appendEvents store first 1 + appendEvents store middle 1 + appendEvents store lastStream 1 - Right (Just _) <- runStoreIO store $ hardDeleteStream middle - assertHeadAndFrontier store 3 3 + Right (Just _) <- runStoreIO store $ hardDeleteStream middle + assertHeadAndFrontier store 3 3 - Right (Just _) <- runStoreIO store $ hardDeleteStream lastStream - assertHeadAndFrontier store 1 3 + Right (Just _) <- runStoreIO store $ hardDeleteStream lastStream + assertHeadAndFrontier store 1 3 - Right (Just _) <- runStoreIO store $ hardDeleteStream first - assertHeadAndFrontier store 0 3 + Right (Just _) <- runStoreIO store $ hardDeleteStream first + assertHeadAndFrontier store 0 3 - it "keeps logically truncated and soft-deleted events visible in $all" $ - withTestStore $ \store -> do - let name = StreamName "visible-head-logical-lifecycle" - appendEvents store name 3 + it "keeps logically truncated and soft-deleted events visible in $all" $ + withTestStore $ \store -> do + let name = StreamName "visible-head-logical-lifecycle" + appendEvents store name 3 - Right (Just _) <- - runStoreIO store $ - setStreamTruncateBefore name (StreamVersion 3) - runStoreIO store visibleGlobalHeadPosition - `shouldReturn` Right (GlobalPosition 3) + Right (Just _) <- + runStoreIO store $ + setStreamTruncateBefore name (StreamVersion 3) + runStoreIO store visibleGlobalHeadPosition + `shouldReturn` Right (GlobalPosition 3) - Right (Just _) <- runStoreIO store $ softDeleteStream name - runStoreIO store visibleGlobalHeadPosition - `shouldReturn` Right (GlobalPosition 3) + Right (Just _) <- runStoreIO store $ softDeleteStream name + runStoreIO store visibleGlobalHeadPosition + `shouldReturn` Right (GlobalPosition 3) - it "does not invoke the event decode hook" $ do - decodeCalls <- newIORef (0 :: Int) - let failingHook event = do - modifyIORef' decodeCalls (+ 1) - ioError (userError ("unexpected decode of " <> show (event ^. #eventId))) - tweak settings = - settings - & #storeSettings - .~ defaultStoreSettings{decodeHook = Just failingHook} - withTestStoreSettings tweak $ \store -> do - appendEvents store (StreamName "visible-head-no-decode") 1 + it "does not invoke the event decode hook" $ do + decodeCalls <- newIORef (0 :: Int) + let failingHook event = do + modifyIORef' decodeCalls (+ 1) + ioError (userError ("unexpected decode of " <> show (event ^. #eventId))) + tweak settings = + settings + & #storeSettings + .~ defaultStoreSettings {decodeHook = Just failingHook} + withTestStoreSettings tweak $ \store -> do + appendEvents store (StreamName "visible-head-no-decode") 1 - runStoreIO store visibleGlobalHeadPosition - `shouldReturn` Right (GlobalPosition 1) - readIORef decodeCalls `shouldReturn` 0 + runStoreIO store visibleGlobalHeadPosition + `shouldReturn` Right (GlobalPosition 1) + readIORef decodeCalls `shouldReturn` 0 appendEvents :: KirokuStore -> StreamName -> Int -> IO () appendEvents store name count = do - let events = - [ makeEvent "VisibleHeadEvent" (Aeson.object [("ordinal", Aeson.Number (fromIntegral ordinal))]) - | ordinal <- [1 .. count] - ] - result <- runStoreIO store $ appendToStream name NoStream events - case result of - Left err -> expectationFailure ("append failed: " <> show err) - Right _ -> pure () + let events = + [ makeEvent "VisibleHeadEvent" (Aeson.object [("ordinal", Aeson.Number (fromIntegral ordinal))]) + | ordinal <- [1 .. count] + ] + result <- runStoreIO store $ appendToStream name NoStream events + case result of + Left err -> expectationFailure ("append failed: " <> show err) + Right _ -> pure () assertHeadAndFrontier :: KirokuStore -> Integer -> Integer -> IO () assertHeadAndFrontier store expectedHead expectedFrontier = do - runStoreIO store visibleGlobalHeadPosition - `shouldReturn` Right (GlobalPosition (fromIntegral expectedHead)) - result <- runStoreIO store subscriptionCheckpointInventory - case result of - Left err -> expectationFailure ("inventory read failed: " <> show err) - Right inventory -> - inventory ^. #storePosition - `shouldBe` GlobalPosition (fromIntegral expectedFrontier) + runStoreIO store visibleGlobalHeadPosition + `shouldReturn` Right (GlobalPosition (fromIntegral expectedHead)) + result <- runStoreIO store subscriptionCheckpointInventory + case result of + Left err -> expectationFailure ("inventory read failed: " <> show err) + Right inventory -> + inventory ^. #storePosition + `shouldBe` GlobalPosition (fromIntegral expectedFrontier) diff --git a/test/Test/VisibleGlobalHeadPositionMock.hs b/test/Test/VisibleGlobalHeadPositionMock.hs --- a/test/Test/VisibleGlobalHeadPositionMock.hs +++ b/test/Test/VisibleGlobalHeadPositionMock.hs @@ -11,21 +11,21 @@ spec :: Spec spec = describe "visible global head position mock" $ - it "returns the configured position through one Store effect call" $ do - calls <- newIORef (0 :: Int) - let expected = GlobalPosition 23 - actual <- runEff $ runVisibleHeadMock calls expected visibleGlobalHeadPosition - actual `shouldBe` expected - readIORef calls `shouldReturn` 1 + it "returns the configured position through one Store effect call" $ do + calls <- newIORef (0 :: Int) + let expected = GlobalPosition 23 + actual <- runEff $ runVisibleHeadMock calls expected visibleGlobalHeadPosition + actual `shouldBe` expected + readIORef calls `shouldReturn` 1 runVisibleHeadMock :: - (IOE :> es) => - IORef Int -> - GlobalPosition -> - Eff (Store : es) a -> - Eff es a + (IOE :> es) => + IORef Int -> + GlobalPosition -> + Eff (Store : es) a -> + Eff es a runVisibleHeadMock calls expected = interpret_ $ \case - GetVisibleGlobalHeadPosition -> do - liftIO $ modifyIORef' calls (+ 1) - pure expected - _ -> error "unexpected Store operation in visible-head mock" + GetVisibleGlobalHeadPosition -> do + liftIO $ modifyIORef' calls (+ 1) + pure expected + _ -> error "unexpected Store operation in visible-head mock"