kiroku-store 0.11.0.1 → 0.12.0.0

raw patch · 98 files changed

+20869/−19736 lines, 98 filesdep ~shibuya-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: shibuya-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +91/−0
• bench/CheckpointTargetCost.hs +63/−64
• bench/Explain.hs +295/−304
• bench/Main.hs +982/−989
• bench/RegressionGate.hs +622/−316
• bench/ShibuyaOverhead.hs +227/−227
• bench/StreamHeadCost.hs +71/−71
• bench/StreamHeadPaired.hs +91/−91
• kiroku-store.cabal +4/−2
• src/Kiroku/Store.hs +12/−12
• src/Kiroku/Store/Append.hs +97/−98
• src/Kiroku/Store/Causation.hs +44/−47
• src/Kiroku/Store/Connection.hs +209/−219
• src/Kiroku/Store/Effect.hs +694/−707
• src/Kiroku/Store/Effect/Resource.hs +38/−39
• src/Kiroku/Store/Error.hs +407/−436
• src/Kiroku/Store/HistoryRetention.hs +74/−80
• src/Kiroku/Store/HistoryRetention/Internal.hs +54/−53
• src/Kiroku/Store/HistoryRetention/SQL.hs +210/−209
• src/Kiroku/Store/HistoryRetention/Types.hs +77/−76
• src/Kiroku/Store/Lifecycle.hs +135/−139
• src/Kiroku/Store/Link.hs +47/−47
• src/Kiroku/Store/Notification.hs +210/−167
• src/Kiroku/Store/Observability.hs +248/−272
• src/Kiroku/Store/Read.hs +203/−216
• src/Kiroku/Store/SQL.hs +1653/−1572
• src/Kiroku/Store/Settings.hs +104/−110
• src/Kiroku/Store/Subscription.hs +295/−293
• src/Kiroku/Store/Subscription/Checkpoint.hs +97/−102
• src/Kiroku/Store/Subscription/Checkpoint/SQL.hs +233/−221
• src/Kiroku/Store/Subscription/CheckpointInventory/SQL.hs +81/−80
• src/Kiroku/Store/Subscription/DeadLetter/SQL.hs +97/−94
• src/Kiroku/Store/Subscription/Effect.hs +90/−93
• src/Kiroku/Store/Subscription/EventPublisher.hs +248/−256
• src/Kiroku/Store/Subscription/Fsm.hs +285/−291
• src/Kiroku/Store/Subscription/Stream.hs +168/−174
• src/Kiroku/Store/Subscription/Types.hs +448/−474
• src/Kiroku/Store/Subscription/Worker.hs +1083/−944
• src/Kiroku/Store/Transaction.hs +289/−299
• src/Kiroku/Store/Types.hs +247/−282
• test/Main.hs +2190/−2186
• test/Test/BrowseQueryPlans.hs +53/−51
• test/Test/BrowseReads.hs +66/−66
• test/Test/BrowseReadsMock.hs +21/−21
• test/Test/CatchupDbErrorNoPrematureSwitch.hs +74/−74
• test/Test/Category.hs +33/−36
• test/Test/CategoryIdleNoSpin.hs +176/−177
• test/Test/Causation.hs +118/−121
• test/Test/Concurrency.hs +277/−278
• test/Test/ConsumerGroup.hs +246/−249
• test/Test/ConsumerGroupEffect.hs +150/−153
• test/Test/ConsumerGroupResize.hs +176/−176
• test/Test/ConsumerGroupSql.hs +183/−186
• test/Test/DeadLetterQueryPlans.hs +46/−40
• test/Test/EventTypeFilter.hs +230/−231
• test/Test/FailureInjection.hs +98/−99
• test/Test/HandlerStall.hs +227/−215
• test/Test/Helpers.hs +216/−228
• test/Test/HistoryRetention.hs +282/−282
• test/Test/HistoryRetentionMock.hs +52/−52
• test/Test/InterpreterHooks.hs +146/−147
• test/Test/NamespaceQueryPlans.hs +98/−0
• test/Test/NotifyGuard.hs +72/−72
• test/Test/PerformanceStructure.hs +613/−615
• test/Test/Properties.hs +158/−163
• test/Test/PublisherCallbackResilience.hs +491/−425
• test/Test/PublisherDropCounter.hs +32/−32
• test/Test/PublisherIdleAdvance.hs +127/−127
• test/Test/PublisherRestartNoRebroadcast.hs +180/−180
• test/Test/ReadStream.hs +123/−124
• test/Test/ScriptSessionErrors.hs +83/−83
• test/Test/StartupFailureSurfacing.hs +82/−82
• test/Test/StreamBridgeTermination.hs +73/−73
• test/Test/StreamHead.hs +77/−77
• test/Test/StreamHeadIsolation.hs +21/−21
• test/Test/StreamHeadMock.hs +13/−13
• test/Test/StreamHistoryGuard.hs +147/−147
• test/Test/StreamNameLookup.hs +58/−59
• test/Test/SubscriptionCheckpointInitialization.hs +228/−97
• test/Test/SubscriptionCheckpointInitializationMock.hs +27/−27
• test/Test/SubscriptionCheckpointInventory.hs +165/−165
• test/Test/SubscriptionCheckpointInventoryMock.hs +25/−25
• test/Test/SubscriptionCheckpointReset.hs +144/−144
• test/Test/SubscriptionCheckpointWorker.hs +191/−191
• test/Test/SubscriptionDeadLetters.hs +96/−93
• test/Test/SubscriptionDeadLettersMock.hs +11/−11
• test/Test/SubscriptionNamespace.hs +375/−0
• test/Test/SubscriptionPauseResume.hs +163/−164
• test/Test/SubscriptionReconnect.hs +161/−162
• test/Test/SubscriptionRegistry.hs +152/−153
• test/Test/SubscriptionRetryDeadLetter.hs +128/−129
• test/Test/SubscriptionState.hs +123/−124
• test/Test/SubscriptionTarget.hs +162/−133
• test/Test/Transaction.hs +340/−343
• test/Test/TruncateBefore.hs +88/−89
• test/Test/UniqueViolationMapping.hs +72/−72
• test/Test/VisibleGlobalHeadPosition.hs +72/−72
• test/Test/VisibleGlobalHeadPositionMock.hs +15/−15

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

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

@@ -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 (...) <CTE>@ with @FORMAT TEXT@.-Each row of the result is one indented plan line. Uses 'unpreparable'-because the EXPLAIN runs once and the statement-cache cost would be wasted.--}+-- | Wrap @appendAnyVersionSQL@ in @EXPLAIN (...) <CTE>@ with @FORMAT TEXT@.+-- Each row of the result is one indented plan line. Uses 'unpreparable'+-- because the EXPLAIN runs once and the statement-cache cost would be wasted. explainStatementText :: Statement AppendParams [Text] explainStatementText =-    unpreparable-        sql-        appendParamsEncoder-        (D.rowList (D.column (D.nonNullable D.text)))+  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 (...) <CTE>@ with @FORMAT JSON@.-PostgreSQL returns one row whose single column is of type @json@; we use-'D.jsonBytes' with an identity parser to preserve the original-byte-for-byte output.--}+-- | Wrap @appendAnyVersionSQL@ in @EXPLAIN (...) <CTE>@ with @FORMAT JSON@.+-- PostgreSQL returns one row whose single column is of type @json@; we use+-- 'D.jsonBytes' with an identity parser to preserve the original+-- byte-for-byte output. explainStatementJson :: Statement AppendParams BS.ByteString explainStatementJson =-    unpreparable-        sql-        appendParamsEncoder-        (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right))))+  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

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

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

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

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

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

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

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

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

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

@@ -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 \<schema\>, pg_catalog@ before any statement,-      so the unqualified names in "Kiroku.Store.SQL" resolve to this-      schema.-    * __Notification channel.__ The-      'Kiroku.Store.Notification.Notifier' issues-      @LISTEN \<schema\>.events@ on its dedicated connection, matching the-      channel published by the migration-created @notify_events()@-      trigger.--    To run more than one isolated 'KirokuStore' against the same database-    (for example schema-per-tenant), migrate each schema and give each-    store a distinct 'schema'; each gets its own set of Kiroku tables and-    its own notification channel.-    -}-    , extraSearchPath :: ![Text]-    {- ^ Additional schemas appended to every pooled connection's-    @search_path@, after 'schema' and before @pg_catalog@ (default: @[]@).--    The store's own unqualified names always resolve to 'schema' first.-    This is for consumers whose /application/ objects — typically inline-    projections' read-model tables, queried on the same pool as the event-    store — live in another schema (commonly @public@). Without it those-    unqualified application tables are unreachable on the store pool, since-    'schema' replaces the default @search_path@. Entries are quoted as-    identifiers; like 'schema' they are not validated at connection time-    (PostgreSQL does not validate @search_path@ entries).-    -}-    , idleInTransactionTimeout :: !Int-    -- ^ idle_in_transaction_session_timeout in seconds (default: 30)-    , statementTimeout :: !(Maybe Int)-    {- ^ When @Just s@, set @statement_timeout = 's'@ (in seconds) on-    every pooled connection via @initSession@. Bounds the wall-clock-    runtime of any single statement; protects against pathological-    queries holding pool slots indefinitely. Default 'Nothing'-    (PostgreSQL's session default applies — typically @0@,-    meaning no timeout).--    A reasonable starting value for typical workloads is @Just 30@-    (30 seconds) — long enough to absorb GC pauses and transient-    slow disks, short enough to free the pool slot under genuine-    pathology. See @docs\/PRODUCTION-TUNING.md@ for sizing-    guidance.-    -}-    , observationHandler :: !(Maybe (Observation -> m ()))-    -- ^ Optional callback for pool connection lifecycle events-    , eventHandler :: !(Maybe (KirokuEvent -> m ()))-    {- ^ Optional callback for store-emitted operational events. See-    "Kiroku.Store.Observability" for the event taxonomy. Covers-    notifier reconnection, publisher pool errors, subscription-    lifecycle and per-phase database errors, and hard-delete-    issuance — events that 'observationHandler' (which surfaces-    @hasql-pool@'s connection-lifecycle observations) does not-    cover.--    Invoked synchronously from the originating thread (notifier-    loop, publisher loop, worker loop, store interpreter); slow-    callbacks stall those loops. For callbacks that may block, fan-    out asynchronously (e.g., write to a 'TBQueue' and drain in a-    separate thread).-    -}-    , storeSettings :: !StoreSettings-    {- ^ Interpreter-level hooks applied to 'EventData' on the append-    path and to 'RecordedEvent' on the read and subscription paths.-    Defaults to 'defaultStoreSettings' (no-op).--    See "Kiroku.Store.Settings" for the hook semantics and the-    OpenTelemetry trace-context use case that motivates this seam.-    -}-    }-    deriving stock (Generic)+  { -- | 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 \<schema\>, pg_catalog@ before any statement,+    --       so the unqualified names in "Kiroku.Store.SQL" resolve to this+    --       schema.+    --     * __Notification channel.__ The+    --       'Kiroku.Store.Notification.Notifier' issues+    --       @LISTEN \<schema\>.events@ on its dedicated connection, matching the+    --       channel published by the migration-created @notify_events()@+    --       trigger.+    --+    --     To run more than one isolated 'KirokuStore' against the same database+    --     (for example schema-per-tenant), migrate each schema and give each+    --     store a distinct 'schema'; each gets its own set of Kiroku tables and+    --     its own notification channel.+    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 \<schema\>.events@.-3. Start the 'Kiroku.Store.Subscription.EventPublisher' which consumes-   notifier ticks and broadcasts new events to subscribers.--Release phase, in reverse order:--1. Cancel the 'Kiroku.Store.Subscription.EventPublisher' worker.-2. Stop the 'Kiroku.Store.Notification.Notifier' (cancel listener,-   release connection).-3. Release the pool.+  { 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 \<schema\>.events@.+-- 3. Start the 'Kiroku.Store.Subscription.EventPublisher' which consumes+--    notifier ticks and broadcasts new events to subscribers.+--+-- Release phase, in reverse order:+--+-- 1. Cancel the 'Kiroku.Store.Subscription.EventPublisher' worker.+-- 2. Stop the 'Kiroku.Store.Notification.Notifier' (cancel listener,+--    release connection).+-- 3. Release the pool.+--+-- The @bracket@ semantics guarantee release runs on either normal exit+-- or an exception in the body. The 'MonadUnliftIO' constraint matches+-- 'Control.Exception.bracket'; consumers in pure 'IO' get an exact match,+-- consumers in effectful monads with an unlift in scope (e.g., a+-- 'ReaderT'-like stack) get the same guarantee transparently. withStore :: (MonadUnliftIO m) => ConnectionSettings -> (KirokuStore -> m a) -> m a withStore settings action = withRunInIO $ \runInIO ->-    bracket acquire release (runInIO . action)+  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 <> "\""

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

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

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