kiroku-store (empty) → 0.1.0.0
raw patch · 41 files changed
+11566/−0 lines, 41 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, bytestring, containers, contravariant-extras, deepseq, directory, effectful, effectful-core, ephemeral-pg, filepath, generic-lens, hasql, hasql-notifications, hasql-pool, hasql-transaction, hedgehog, hspec, hspec-hedgehog, kiroku-store, kiroku-test-support, lens, mmzk-typeid, shibuya-core, stm, streamly, streamly-core, tasty-bench, text, time, unliftio, unliftio-core, unordered-containers, uuid, vector
Files
- CHANGELOG.md +212/−0
- bench/Explain.hs +433/−0
- bench/Main.hs +889/−0
- bench/ShibuyaOverhead.hs +304/−0
- example/Main.hs +144/−0
- kiroku-store.cabal +214/−0
- src/Kiroku/Store.hs +62/−0
- src/Kiroku/Store/Append.hs +110/−0
- src/Kiroku/Store/Causation.hs +66/−0
- src/Kiroku/Store/Connection.hs +226/−0
- src/Kiroku/Store/Effect.hs +447/−0
- src/Kiroku/Store/Effect/Resource.hs +54/−0
- src/Kiroku/Store/Error.hs +347/−0
- src/Kiroku/Store/Lifecycle.hs +110/−0
- src/Kiroku/Store/Link.hs +47/−0
- src/Kiroku/Store/Notification.hs +224/−0
- src/Kiroku/Store/Observability.hs +171/−0
- src/Kiroku/Store/Read.hs +209/−0
- src/Kiroku/Store/SQL.hs +1103/−0
- src/Kiroku/Store/Settings.hs +97/−0
- src/Kiroku/Store/Subscription.hs +146/−0
- src/Kiroku/Store/Subscription/Effect.hs +138/−0
- src/Kiroku/Store/Subscription/EventPublisher.hs +251/−0
- src/Kiroku/Store/Subscription/Stream.hs +67/−0
- src/Kiroku/Store/Subscription/Types.hs +201/−0
- src/Kiroku/Store/Subscription/Worker.hs +378/−0
- src/Kiroku/Store/Transaction.hs +320/−0
- src/Kiroku/Store/Types.hs +290/−0
- test/Main.hs +1795/−0
- test/Test/Causation.hs +168/−0
- test/Test/Concurrency.hs +280/−0
- test/Test/ConsumerGroup.hs +334/−0
- test/Test/ConsumerGroupEffect.hs +208/−0
- test/Test/ConsumerGroupSql.hs +287/−0
- test/Test/FailureInjection.hs +98/−0
- test/Test/Helpers.hs +301/−0
- test/Test/InterpreterHooks.hs +178/−0
- test/Test/Properties.hs +226/−0
- test/Test/ReadStream.hs +94/−0
- test/Test/StreamNameLookup.hs +52/−0
- test/Test/Transaction.hs +285/−0
+ CHANGELOG.md view
@@ -0,0 +1,212 @@+# Changelog++## 0.1.0.0 — 2026-05-23++### Changed — migrations own schema lifecycle++* `kiroku-store` no longer embeds schema SQL or runs DDL during `withStore`.+ Apply `kiroku-store-migrations` before opening the store. This removes the+ duplicated bootstrap path between the runtime package and the migration+ package.+* Removed `Kiroku.Store.Schema`, `SchemaInitialization`,+ `InitializeSchemaOnAcquire`, `SkipSchemaInitialization`, and+ `ConnectionSettingsM.schemaInitialization`.++### Added — `lookupStreamNames` / `lookupStreamName` (plan 36)++* `Kiroku.Store.Read.lookupStreamNames :: [StreamId] -> Eff es (Map StreamId+ StreamName)` resolves a batch of surrogate stream ids to their names in a+ single round trip (and `lookupStreamName :: StreamId -> Eff es (Maybe+ StreamName)` for one). This is the inverse of `lookupStreamId` and the+ supported way to recover the source stream name from a `RecordedEvent`'s+ `originalStreamId` on fan-in reads — `$all`, categories,+ causation/correlation queries, and subscriptions — which carry only the+ surrogate id.+* Chosen over carrying a `originalStreamName` field on every `RecordedEvent`:+ benchmarking showed returning the name on every read row costs ~13% on+ `$all` 100-event pages (decoding ~100 extra `text` values per page), whether+ the name came from a join or a denormalized column. The lookup API keeps the+ read hot path at its prior latency and makes consumers pay only when, and+ only as much as, they actually need names (one round trip per batch for the+ distinct ids). See `docs/plans/36-add-originalstreamname-to-recordedevent.md`.++* A fresh installation now creates and uses a dedicated `kiroku` PostgreSQL+ schema instead of installing into `public`. The+ `kiroku-store-migrations` bootstrap creates the schema and sets+ `search_path` first, and every pooled connection runs+ `SET search_path TO "<schema>", pg_catalog` before any statement.+* `defaultConnectionSettings` now defaults `schema = "kiroku"` (was `"public"`).+ The `schema` field is now authoritative for object location, table+ resolution, and the `LISTEN <schema>.events` channel — previously it only+ named the notification channel while table resolution depended on the+ connection-string `search_path`.+* The `kiroku-store-migrations` codd bootstrap installs into `kiroku`; run it+ with `CODD_SCHEMAS=kiroku`. The runtime role needs privileges on the+ `kiroku` schema rather than on `public`.++### Added — consumer groups for partitioned subscriptions (MasterPlan 4, plans 28–31)++* Static, hash-partitioned consumer groups: a named subscription can be split+ across `N` members, each processing a disjoint, per-stream-ordered slice in+ parallel, with per-member checkpoints. Works for `Category` and `$all`+ targets.+* `Kiroku.Store.Subscription.Types` (re-exported from `Kiroku.Store`):+ * `ConsumerGroup { member :: Int32, size :: Int32 }` — static membership+ descriptor. A stream is assigned to member+ `(((hashtextextended(stream_id::text, 0) % size) + size) % size)`.+ * Two new fields on `SubscriptionConfigM m`: `consumerGroup :: Maybe+ ConsumerGroup` (default `Nothing`) and `consumerGroupGuard :: Bool`+ (default `False`, an opt-in startup advisory-lock conflict probe).+ `defaultSubscriptionConfig` sets both defaults, so existing callers compile+ unchanged.+ * Exceptions `InvalidConsumerGroup` (thrown by `subscribe` when `size < 1` or+ `member` is out of range) and `ConsumerGroupGuardConflict` (thrown at+ startup when the guard detects a duplicate member).+* `subscriptions` table gains `consumer_group_member` and `consumer_group_size`+ columns; the checkpoint key becomes the composite unique+ `(subscription_name, consumer_group_member)` (index+ `ix_subscriptions_name_member`). The change is applied by the migration+ package.+* The four `KirokuEventSubscription*` observability events carry a trailing+ `SubscriptionGroupContext` (`NonGroup` | `GroupMember member size`),+ re-exported from `Kiroku.Store`.+* Surfaced through every subscription entry point: the `MonadIO`+ `subscribe`/`withSubscription`, the effectful `Subscription` effect, the+ Streamly `subscriptionStream` bridge, and the Shibuya adapter+ (`KirokuAdapterConfig` gains `consumerGroup :: Maybe ConsumerGroup`).+* New user guide `docs/user/consumer-groups.md` and a runnable example,+ `cabal run kiroku-store:kiroku-consumer-group-example`.++### Added — causation chain and correlation walkers (plan 14)++* `Kiroku.Store.Causation` (new module, re-exported from `Kiroku.Store`):+ * `findCausationDescendants :: EventId -> Eff es (Vector RecordedEvent)`+ — walk the causation graph forward from a seed event. Returns the+ seed plus every event whose `causation_id` chain leads back to it,+ in ascending `global_position` order. Backed by the existing partial+ index `ix_events_causation_id`, so cost scales as O(depth · log n)+ against the total event count.+ * `findCausationAncestors :: EventId -> Eff es (Vector RecordedEvent)`+ — symmetric walk in the other direction: returns the seed plus+ every ancestor reachable by following `causation_id` upward, in+ leaf-first depth order. Uses the same index.+ * `findByCorrelation :: UUID -> Eff es (Vector RecordedEvent)` — return+ every event whose `correlation_id` equals the input, in ascending+ `global_position` order. Backed by `ix_events_correlation_id`.+* `Kiroku.Store.Effect.Store` gains a single new constructor+ `FindEvents :: EventFilter -> Store m (Vector RecordedEvent)` whose+ argument is a closed sum (`Kiroku.Store.Types.EventFilter` —+ `FilterCorrelation`, `FilterCausationDescendants`, `FilterCausationAncestors`).+ The closed-sum shape preserves exhaustiveness checking for downstream+ mock interpreters.+* The new reads honor `StoreSettings.decodeHook`, so any interpreter-level+ decode customization wired through `ConnectionSettings` applies on+ parity with `readStreamForward` / `readAllForward` / `readCategory`.++### Added — interpreter-level event-data hooks (plan 13)++* `Kiroku.Store.Settings` (new module, re-exported from `Kiroku.Store`):+ * `StoreSettings { enrichEvent :: Maybe (EventData -> IO EventData),+ decodeHook :: Maybe (RecordedEvent -> IO RecordedEvent) }` — optional+ interpreter-level hooks. `enrichEvent` runs on the append path before+ encoding (on the typed `EventData` the caller supplied); `decodeHook`+ runs on the read and subscription paths after decoding (on the typed+ `RecordedEvent` about to be surfaced). Both default to `Nothing`,+ taking a `pure` fast path that adds no traversal or allocation when+ the hook is absent.+ * `defaultStoreSettings` — both fields `Nothing` (no-op).+ * `enrichEvents :: StoreSettings -> [EventData] -> IO [EventData]` and+ `decodeEvents :: StoreSettings -> Vector RecordedEvent -> IO (Vector+ RecordedEvent)` — internal helpers reused by the interpreter, the+ subscription publisher, the subscription worker, and the new+ `enrichEventsIO` convenience.+* `Kiroku.Store.Connection.ConnectionSettings` and+ `Kiroku.Store.Connection.KirokuStore` gain a `storeSettings ::+ StoreSettings` field. `defaultConnectionSettings` seeds it with+ `defaultStoreSettings` so existing callers see no behaviour change.+ `withStore` copies the value onto the runtime handle for the+ interpreter, the publisher, and the worker to read.+* `Kiroku.Store.Transaction`:+ * `runTransactionAppendingResource` /+ `runTransactionAppendingResourceNoRetry` — hook-aware variants of+ `runTransactionAppending` / `runTransactionAppendingNoRetry` for+ callers running under a `KirokuStoreResource` effect. They apply+ `enrichEvent` to every `EventData` before opening the transaction.+ * `enrichEventsIO :: KirokuStore -> [EventData] -> IO [EventData]` —+ public convenience for direct callers of `appendToStreamTx`, who+ bypass the interpreter.++A typical use case is enriching every appended event with an+OpenTelemetry trace context:++```haskell+storeSettings = defaultStoreSettings+ { enrichEvent = Just $ \ed -> do+ ctx <- captureCurrentSpan+ pure (ed & #metadata %~ injectTraceContext ctx)+ }+```++Wired through `ConnectionSettings`'s `storeSettings` field, the hook+fires uniformly across `appendToStream`, `appendMultiStream`,+`runTransactionAppendingResource`, every read path, and the+subscription pipeline (live + catch-up).++### Added — streaming single-stream forward read++* `Kiroku.Store.Read.readStreamForwardStream` (re-exported from+ `Kiroku.Store`): a Streamly `Stream (Eff es) RecordedEvent` companion to+ `readStreamForward`. Internally paginates `readStreamForward` at a+ caller-supplied page size and yields events one at a time, enabling+ constant-memory folds over long streams. Shares SQL path and error+ semantics with `readStreamForward`.++### Added — single-stream `RunTransaction` combinator (plan 11)++* `Kiroku.Store.Transaction` (new module, re-exported from+ `Kiroku.Store`):+ * `runTransaction` / `runTransactionNoRetry` — bare escape hatch for+ running an arbitrary `Hasql.Transaction.Transaction a` against the+ store's connection pool. The default variant retries the body on+ PostgreSQL serialization conflicts; the `-NoRetry` variant runs+ exactly once. Both execute at `ReadCommitted` isolation in `Write`+ mode.+ * `appendToStreamTx :: StreamName -> ExpectedVersion ->+ [PreparedEvent] -> UTCTime -> Tx.Transaction (Either AppendConflict+ AppendResult)` — the `Tx`-flavored single-stream append building+ block. Useful inside a `runTransaction` block when the caller needs+ full control over conflict handling. Does not enforce reserved-stream+ rejection; pair with `prepareEventsIO` for UUIDv7 / `createdAt`+ prep.+ * `runTransactionAppending` /+ `runTransactionAppendingNoRetry` — recommended high-level wrapper+ for the `keiro` use case. Atomically composes a single-stream append+ with a caller-supplied `Tx.Transaction` continuation. Rejects `$all`+ up front, `Tx.condemn`s on append conflicts (the continuation never+ runs), and surfaces both conflict and connection failures through+ the `Either StoreError` return type. Carries `IOE :> es` in addition+ to `Store :> es`.+* `Kiroku.Store.Effect`:+ * New `Store` constructors `RunTransaction` and+ `RunTransactionNoRetry`. Mock interpreters are expected to reject+ these.+ * Internal building blocks `PreparedEvent`, `prepareEvents`,+ `buildAppendParams`, and `appendDispatchTx` are now exported (under+ the `$internal` haddock group) to support+ `Kiroku.Store.Transaction`. Not part of the supported public+ surface.+* `Kiroku.Store.Error`:+ * `AppendConflict` — sum of append-precondition failures observable+ inside a `Tx.Transaction` body+ (`WrongExpectedVersionConflict` / `StreamNotFoundConflict` /+ `StreamAlreadyExistsConflict`). 1:1 with the corresponding+ `StoreError` constructors.+ * `appendConflictToStoreError`, `emptyResultConflict` — supporting+ pure helpers.++### Changed++* `appendMultiStream`'s interpreter now dispatches per-stream appends+ through the shared `appendDispatchTx` helper. Behavior is unchanged.+* `appendToStream`'s haddock now describes when to reach for+ `runTransactionAppending` instead.
+ bench/Explain.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE MultilineStrings #-}++{- | PostgreSQL-side append profiling harness.++Two modes:++ * default — boots a cached ephemeral PostgreSQL via 'Pg.withCached', runs+ the production @AnyVersion@ CTE under+ @EXPLAIN (ANALYZE, BUFFERS, TIMING, FORMAT TEXT)@ wrapped in+ @BEGIN ... ROLLBACK@, prints the result to stdout, then runs the same+ query under @FORMAT JSON@ and writes the result to+ @kiroku-store/bench/explain-results/anyversion-singleton.json@.++ * @--auto-explain@ — boots an ephemeral PostgreSQL with the @auto_explain@+ contrib loaded via 'Pg.autoExplainConfig', redirects the server's stderr+ to @kiroku-store/bench/explain-results/auto-explain.log@, opens a+ 'KirokuStore' (which migrates the schema), runs a small workload (one+ @AnyVersion@ append, one @ExactVersion@ append against the same stream,+ one @ReadStreamForward@, one @ReadAllForward@), and exits. PostgreSQL+ flushes the @auto_explain@ output to the captured log on shutdown.++Belongs to ExecPlan+@docs/plans/26-postgresql-side-append-profiling-with-explain-analyze-and-auto-explain.md@.+-}+module Main where++import Control.Concurrent (threadDelay)+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.ByteString qualified as BS+import Data.Functor.Contravariant ((>$<))+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.UUID (UUID)+import Data.UUID.V4 qualified as V4+import Data.Vector qualified as V+import EphemeralPg qualified as Pg+import EphemeralPg.Config qualified as PgC+import GHC.Generics (Generic)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, unpreparable)+import Kiroku.Store+import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory, listDirectory, removePathForcibly)+import System.Environment (getArgs)+import System.FilePath (takeDirectory, (</>))+import System.IO (BufferMode (..), hSetBuffering, stdout)++-- ---------------------------------------------------------------------------+-- Local copies of AppendParams + encoder + appendAnyVersionSQL+-- ---------------------------------------------------------------------------+-- Duplicated from Kiroku.Store.SQL (an other-modules module not exposed by+-- the kiroku-store library). EP-2 deliberately inlines these rather than+-- expose the SQL module; see the Decision Log of plan 26.+-- ---------------------------------------------------------------------------++data AppendParams = AppendParams+ { eventIds :: !(V.Vector UUID)+ , eventTypes :: !(V.Vector Text)+ , causationIds :: !(V.Vector (Maybe UUID))+ , correlationIds :: !(V.Vector (Maybe UUID))+ , payloads :: !(V.Vector Aeson.Value)+ , metadatas :: !(V.Vector (Maybe Aeson.Value))+ , createdAts :: !(V.Vector UTCTime)+ , streamName :: !Text+ }+ deriving stock (Generic)++appendParamsEncoder :: E.Params AppendParams+appendParamsEncoder =+ ((^. #eventIds) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+ <> ((^. #eventTypes) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+ <> ((^. #causationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+ <> ((^. #correlationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+ <> ((^. #payloads) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.jsonb))))+ <> ((^. #metadatas) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.jsonb))))+ <> ((^. #createdAts) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.timestamptz))))+ <> ((^. #streamName) >$< E.param (E.nonNullable E.text))++appendAnyVersionSQL :: Text+appendAnyVersionSQL =+ """+ WITH+ new_events AS (+ SELECT *+ FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+ WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+ ),+ stream_upsert AS (+ INSERT INTO streams (stream_name, stream_version)+ VALUES ($8, (SELECT count(*) FROM new_events))+ ON CONFLICT (stream_name)+ DO UPDATE SET stream_version = streams.stream_version + (SELECT count(*) FROM new_events)+ WHERE streams.deleted_at IS NULL+ RETURNING stream_id, stream_version - (SELECT count(*) FROM new_events) AS initial_version+ ),+ inserted_events AS (+ INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+ SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+ FROM new_events+ WHERE EXISTS (SELECT 1 FROM stream_upsert)+ ORDER BY idx+ ),+ source_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, su.stream_id, su.initial_version + ne.idx, su.stream_id, su.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN stream_upsert su+ ),+ all_update AS (+ UPDATE streams+ SET stream_version = stream_version + (SELECT count(*) FROM new_events)+ WHERE stream_id = 0+ AND EXISTS (SELECT 1 FROM stream_upsert)+ RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+ ),+ all_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN all_update au+ CROSS JOIN stream_upsert su+ )+ SELECT su.stream_id,+ su.initial_version + (SELECT count(*) FROM new_events),+ au.initial_global_version + (SELECT count(*) FROM new_events)+ FROM stream_upsert su+ CROSS JOIN all_update au+ """++-- ---------------------------------------------------------------------------+-- EXPLAIN wrappers + sample params+-- ---------------------------------------------------------------------------++{- | Wrap @appendAnyVersionSQL@ in @EXPLAIN (...) <CTE>@ with @FORMAT TEXT@.+Each row of the result is one indented plan line. Uses 'unpreparable'+because the EXPLAIN runs once and the statement-cache cost would be wasted.+-}+explainStatementText :: Statement AppendParams [Text]+explainStatementText =+ unpreparable+ sql+ appendParamsEncoder+ (D.rowList (D.column (D.nonNullable D.text)))+ where+ sql =+ "EXPLAIN (ANALYZE, BUFFERS, TIMING, FORMAT TEXT)\n"+ <> appendAnyVersionSQL++{- | Wrap @appendAnyVersionSQL@ in @EXPLAIN (...) <CTE>@ with @FORMAT JSON@.+PostgreSQL returns one row whose single column is of type @json@; we use+'D.jsonBytes' with an identity parser to preserve the original+byte-for-byte output.+-}+explainStatementJson :: Statement AppendParams BS.ByteString+explainStatementJson =+ unpreparable+ sql+ appendParamsEncoder+ (D.singleRow (D.column (D.nonNullable (D.jsonBytes Right))))+ where+ sql =+ "EXPLAIN (ANALYZE, BUFFERS, TIMING, FORMAT JSON)\n"+ <> appendAnyVersionSQL++{- | One-event 'AppendParams' for an @AnyVersion@ append against a fresh+stream name.+-}+mkSampleParams :: IO AppendParams+mkSampleParams = do+ eid <- V4.nextRandom+ now <- getCurrentTime+ let nowMicros = show now+ pure+ AppendParams+ { eventIds = V.singleton eid+ , eventTypes = V.singleton "ExplainEvent"+ , causationIds = V.singleton Nothing+ , correlationIds = V.singleton Nothing+ , payloads = V.singleton (Aeson.object ["explain" Aeson..= Aeson.String "anyversion"])+ , metadatas = V.singleton Nothing+ , createdAts = V.singleton now+ , streamName = T.pack ("explain-" <> nowMicros)+ }++{- | Run a single TEXT-format EXPLAIN session inside @BEGIN ... ROLLBACK@+so the inserted rows do not persist.+-}+explainSessionText :: AppendParams -> Session.Session [Text]+explainSessionText params = do+ Session.script "BEGIN"+ rows <- Session.statement params explainStatementText+ Session.script "ROLLBACK"+ pure rows++{- | JSON-format counterpart of 'explainSessionText'. The result is the+@json@ column's raw bytes.+-}+explainSessionJson :: AppendParams -> Session.Session BS.ByteString+explainSessionJson params = do+ Session.script "BEGIN"+ bs <- Session.statement params explainStatementJson+ Session.script "ROLLBACK"+ pure bs++-- ---------------------------------------------------------------------------+-- Output paths+-- ---------------------------------------------------------------------------++{- | Walk up from the current working directory until a @cabal.project@ file+is found, then return that directory. Falls back to the CWD if no marker+is found. This makes the harness work whether invoked from the repo root+('cabal run', direct binary invocation) or from the package directory+('cabal bench', which sets CWD to @kiroku-store\/@).+-}+locateRepoRoot :: IO FilePath+locateRepoRoot = do+ cwd <- getCurrentDirectory+ go cwd+ where+ go dir = do+ let marker = dir </> "cabal.project"+ present <- doesFileExist marker+ if present+ then pure dir+ else+ let parent = takeDirectory dir+ in if parent == dir+ then getCurrentDirectory+ else go parent++explainResultsDir :: FilePath -> FilePath+explainResultsDir repoRoot = repoRoot </> "kiroku-store" </> "bench" </> "explain-results"++jsonOutputPath :: FilePath -> FilePath+jsonOutputPath repoRoot = explainResultsDir repoRoot </> "anyversion-singleton.json"++textOutputPath :: FilePath -> FilePath+textOutputPath repoRoot = explainResultsDir repoRoot </> "anyversion-singleton.txt"++autoExplainLogPath :: FilePath -> FilePath+autoExplainLogPath repoRoot = explainResultsDir repoRoot </> "auto-explain.log"++autoExplainCsvPath :: FilePath -> FilePath+autoExplainCsvPath repoRoot = explainResultsDir repoRoot </> "auto-explain.csv"++-- ---------------------------------------------------------------------------+-- Milestone 1: targeted EXPLAIN ANALYZE+-- ---------------------------------------------------------------------------++runExplainAnalyze :: IO ()+runExplainAnalyze = do+ repoRoot <- locateRepoRoot+ let dir = explainResultsDir repoRoot+ jsonPath = jsonOutputPath repoRoot+ textPath = textOutputPath repoRoot+ createDirectoryIfMissing True dir+ putStrLn ("=== Output directory: " <> dir <> " ===")+ putStrLn "=== Booting cached ephemeral PostgreSQL for EXPLAIN ANALYZE ==="+ result <- Pg.withCached $ \db -> do+ let settings = defaultConnectionSettings (Pg.connectionString db)+ withStore settings $ \store -> do+ paramsText <- mkSampleParams+ paramsJson <- mkSampleParams++ putStrLn ""+ putStrLn "=== EXPLAIN (ANALYZE, BUFFERS, TIMING, FORMAT TEXT) of appendAnyVersionSQL ==="+ putStrLn ""+ textRows <- runSession store (explainSessionText paramsText)+ let textOut = T.intercalate "\n" textRows+ TIO.putStrLn textOut+ TIO.writeFile textPath textOut++ putStrLn ""+ putStrLn ("=== Writing FORMAT JSON output to " <> jsonPath <> " ===")+ jsonBytes <- runSession store (explainSessionJson paramsJson)+ BS.writeFile jsonPath jsonBytes++ putStrLn ""+ putStrLn ("=== TEXT output also archived at " <> textPath <> " ===")+ case result of+ Left err ->+ error ("EphemeralPg failed to start: " <> show err)+ Right () ->+ pure ()++-- ---------------------------------------------------------------------------+-- Milestone 2: auto_explain capture of a small workload+-- ---------------------------------------------------------------------------++{- | A representative slice of the production read+write paths so the+@auto_explain@ log captures one of each kind. Kept tiny so the resulting+log is human-readable.+-}+runSmallWorkload :: KirokuStore -> IO ()+runSmallWorkload store = do+ let sn = StreamName "explain-auto"+ -- AnyVersion append: hits the appendAnyVersionSQL CTE.+ r1 <- runStoreIO store $ appendToStream sn AnyVersion [mkEvent "Created"]+ forceOk "AnyVersion" r1+ let Right res1 = r1+ -- ExactVersion append against the same stream: hits the+ -- appendExpectedVersionSQL CTE with a non-trivial conflict check.+ r2 <-+ runStoreIO store $+ appendToStream sn (ExactVersion (res1 ^. #streamVersion)) [mkEvent "Updated"]+ forceOk "ExactVersion" r2+ -- One read forward from the same stream (limit 100 events).+ r3 <- runStoreIO store $ readStreamForward sn (StreamVersion 0) 100+ forceOk "readStreamForward" r3+ -- One read forward from the $all stream (limit 100 events).+ r4 <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ forceOk "readAllForward" r4+ where+ mkEvent :: Text -> EventData+ mkEvent ty =+ EventData+ Nothing+ (EventType ty)+ (Aeson.object ["t" Aeson..= ty])+ Nothing+ Nothing+ Nothing++ forceOk :: (Show a) => Text -> Either StoreError a -> IO ()+ forceOk label = \case+ Left e -> error (T.unpack label <> " failed: " <> show e)+ Right _ -> pure ()++runAutoExplain :: IO ()+runAutoExplain = do+ repoRoot <- locateRepoRoot+ let dir = explainResultsDir repoRoot+ logPath = autoExplainLogPath repoRoot+ csvPath = autoExplainCsvPath repoRoot+ createDirectoryIfMissing True dir+ putStrLn ("=== Output directory: " <> dir <> " ===")+ putStrLn "=== Booting ephemeral PostgreSQL with auto_explain enabled ==="+ -- ephemeral-pg unconditionally discards the postgres process's stderr+ -- (`setStderr nullStream` at EphemeralPg/Process/Postgres.hs:78), so+ -- plan 26's documented "override Config.stderr to a file handle"+ -- approach cannot work. Instead, configure PostgreSQL's own logging+ -- collector to write a CSV log directly to disk; auto_explain's output+ -- is captured as the message column of those CSV rows. See plan 26's+ -- Surprises & Discoveries for the full debrief.+ let logDir = dir </> "pglog"+ logFilename = "auto-explain.log"+ createDirectoryIfMissing True logDir+ let collectorSettings =+ [ ("logging_collector", "'on'")+ , ("log_destination", "'csvlog'")+ , ("log_directory", "'" <> T.pack logDir <> "'")+ , ("log_filename", "'" <> T.pack logFilename <> "'")+ , ("log_rotation_age", "'0'")+ , ("log_rotation_size", "'0'")+ , ("log_truncate_on_rotation", "'off'")+ , ("log_line_prefix", "'%t [%p] '")+ , -- Required to actually capture auto_explain output: empirical+ -- testing showed that with default log_min_messages (warning)+ -- the csvlog file stayed at 0 bytes, even though+ -- auto_explain.log_min_duration was 0. Forcing the threshold+ -- down to log_min_messages = 'log' lets the auto_explain+ -- ereport(LOG, ...) calls through. See plan 26's Surprises+ -- & Discoveries for the empirical evidence.+ ("log_min_messages", "'log'")+ ]+ let cfg =+ PgC.defaultConfig+ <> PgC.autoExplainConfig 0+ <> (mempty :: PgC.Config){PgC.postgresSettings = collectorSettings}+ result <- Pg.withConfig cfg $ \db -> do+ let settings = defaultConnectionSettings (Pg.connectionString db)+ withStore settings $ \store -> do+ putStrLn "=== Running small workload (1 AnyVersion + 1 ExactVersion + 2 reads) ==="+ runSmallWorkload store+ putStrLn "=== Waiting so the logging collector flushes ==="+ threadDelay 3_000_000 -- 3 seconds+ case result of+ Left err ->+ error ("EphemeralPg failed to start: " <> show err)+ Right () -> do+ files <- listDirectory logDir+ let collectorCsv = logDir </> "auto-explain.csv"+ let collectorStderrLog = logDir </> "auto-explain.log"+ hasCsv <- doesFileExist collectorCsv+ hasLog <- doesFileExist collectorStderrLog+ if hasCsv+ then do+ contents <- BS.readFile collectorCsv+ BS.writeFile csvPath contents+ putStrLn ("=== auto_explain csvlog: " <> csvPath <> " (" <> show (BS.length contents) <> " bytes) ===")+ else putStrLn ("=== WARNING: missing " <> collectorCsv <> "; emitted: " <> show files <> " ===")+ if hasLog+ then do+ contents <- BS.readFile collectorStderrLog+ BS.writeFile logPath contents+ putStrLn ("=== auto_explain stderr (small): " <> logPath <> " (" <> show (BS.length contents) <> " bytes) ===")+ else putStrLn ("=== NOTE: collector did not produce a stderr-format log (csvlog only) ===")+ -- Drop the intermediate pglog/ directory; we have copies in the+ -- documented output paths above.+ removePathForcibly logDir++-- ---------------------------------------------------------------------------+-- Shared helpers+-- ---------------------------------------------------------------------------++{- | Run a Hasql 'Session' directly against the store's pool, surfacing+pool errors via 'error'. Used by the EXPLAIN harness which bypasses the+Store effect layer.+-}+runSession :: KirokuStore -> Session.Session a -> IO a+runSession store session = do+ r <- Pool.use (store ^. #pool) session+ case r of+ Left e -> error ("Hasql.Pool.use failed: " <> show e)+ Right a -> pure a++-- ---------------------------------------------------------------------------+-- main+-- ---------------------------------------------------------------------------++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ args <- getArgs+ if "--auto-explain" `elem` args+ then runAutoExplain+ else runExplainAnalyze
+ bench/Main.hs view
@@ -0,0 +1,889 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultilineStrings #-}++module Main where++import Control.Concurrent.Async (mapConcurrently_)+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Functor.Contravariant ((>$<))+import Data.Generics.Labels ()+import Data.IORef+import Data.Int (Int64)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)+import Data.UUID (UUID)+import Data.UUID.V7 qualified as V7+import Data.Vector qualified as V+import EphemeralPg qualified as Pg+import GHC.Generics (Generic)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Hasql.Transaction qualified as Tx+import Hasql.Transaction.Sessions qualified as TxSessions+import Kiroku.Store+import Test.Tasty.Bench++data RawAppendParams = RawAppendParams+ { eventId :: !UUID+ , eventType :: !Text+ , causationId :: !(Maybe UUID)+ , correlationId :: !(Maybe UUID)+ , payload :: !Aeson.Value+ , metadata :: !(Maybe Aeson.Value)+ , createdAt :: !UTCTime+ , streamName :: !Text+ }+ deriving stock (Generic)++data RawProductionAppendParams = RawProductionAppendParams+ { productionEventIds :: !(V.Vector UUID)+ , productionEventTypes :: !(V.Vector Text)+ , productionCausationIds :: !(V.Vector (Maybe UUID))+ , productionCorrelationIds :: !(V.Vector (Maybe UUID))+ , productionPayloads :: !(V.Vector Aeson.Value)+ , productionMetadatas :: !(V.Vector (Maybe Aeson.Value))+ , productionCreatedAts :: !(V.Vector UTCTime)+ , productionStreamName :: !Text+ }+ deriving stock (Generic)++type RawAppendResult = (Int64, Int64, Int64)++rawAppendParamsEncoder :: E.Params RawAppendParams+rawAppendParamsEncoder =+ ((^. #eventId) >$< E.param (E.nonNullable E.uuid))+ <> ((^. #eventType) >$< E.param (E.nonNullable E.text))+ <> ((^. #causationId) >$< E.param (E.nullable E.uuid))+ <> ((^. #correlationId) >$< E.param (E.nullable E.uuid))+ <> ((^. #payload) >$< E.param (E.nonNullable E.jsonb))+ <> ((^. #metadata) >$< E.param (E.nullable E.jsonb))+ <> ((^. #createdAt) >$< E.param (E.nonNullable E.timestamptz))+ <> ((^. #streamName) >$< E.param (E.nonNullable E.text))++rawProductionAppendParamsEncoder :: E.Params RawProductionAppendParams+rawProductionAppendParamsEncoder =+ ((^. #productionEventIds) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+ <> ((^. #productionEventTypes) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+ <> ((^. #productionCausationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+ <> ((^. #productionCorrelationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+ <> ((^. #productionPayloads) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.jsonb))))+ <> ((^. #productionMetadatas) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.jsonb))))+ <> ((^. #productionCreatedAts) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.timestamptz))))+ <> ((^. #productionStreamName) >$< E.param (E.nonNullable E.text))++rawAppendResultDecoder :: D.Result (Maybe RawAppendResult)+rawAppendResultDecoder =+ D.rowMaybe $+ (,,)+ <$> D.column (D.nonNullable D.int8)+ <*> D.column (D.nonNullable D.int8)+ <*> D.column (D.nonNullable D.int8)++rawScalarAppendAnyVersion :: Statement RawAppendParams (Maybe RawAppendResult)+rawScalarAppendAnyVersion =+ preparable+ rawScalarAppendAnyVersionSQL+ rawAppendParamsEncoder+ rawAppendResultDecoder++rawProductionAppendAnyVersion :: Statement RawProductionAppendParams (Maybe RawAppendResult)+rawProductionAppendAnyVersion =+ preparable+ rawProductionAppendAnyVersionSQL+ rawProductionAppendParamsEncoder+ rawAppendResultDecoder++rawScalarAppendAnyVersionSQL :: Text+rawScalarAppendAnyVersionSQL =+ """+ WITH+ new_event AS (+ SELECT $1::uuid AS event_id,+ $2::text AS event_type,+ $3::uuid AS causation_id,+ $4::uuid AS correlation_id,+ $5::jsonb AS data,+ $6::jsonb AS metadata,+ $7::timestamptz AS created_at+ ),+ stream_upsert AS (+ INSERT INTO streams (stream_name, stream_version)+ VALUES ($8, 1)+ ON CONFLICT (stream_name)+ DO UPDATE SET stream_version = streams.stream_version + 1+ WHERE streams.deleted_at IS NULL+ RETURNING stream_id, stream_version - 1 AS initial_version+ ),+ inserted_events AS (+ INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+ SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+ FROM new_event+ WHERE EXISTS (SELECT 1 FROM stream_upsert)+ ),+ source_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, su.stream_id, su.initial_version + 1, su.stream_id, su.initial_version + 1+ FROM new_event ne+ CROSS JOIN stream_upsert su+ ),+ all_update AS (+ UPDATE streams+ SET stream_version = stream_version + 1+ WHERE stream_id = 0+ AND EXISTS (SELECT 1 FROM stream_upsert)+ RETURNING stream_version - 1 AS initial_global_version+ ),+ all_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, 0, au.initial_global_version + 1, su.stream_id, su.initial_version + 1+ FROM new_event ne+ CROSS JOIN all_update au+ CROSS JOIN stream_upsert su+ )+ SELECT su.stream_id,+ su.initial_version + 1,+ au.initial_global_version + 1+ FROM stream_upsert su+ CROSS JOIN all_update au+ """++rawProductionAppendAnyVersionSQL :: Text+rawProductionAppendAnyVersionSQL =+ """+ WITH+ new_events AS (+ SELECT *+ FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+ WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+ ),+ stream_upsert AS (+ INSERT INTO streams (stream_name, stream_version)+ VALUES ($8, (SELECT count(*) FROM new_events))+ ON CONFLICT (stream_name)+ DO UPDATE SET stream_version = streams.stream_version + (SELECT count(*) FROM new_events)+ WHERE streams.deleted_at IS NULL+ RETURNING stream_id, stream_version - (SELECT count(*) FROM new_events) AS initial_version+ ),+ inserted_events AS (+ INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+ SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+ FROM new_events+ WHERE EXISTS (SELECT 1 FROM stream_upsert)+ ORDER BY idx+ ),+ source_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, su.stream_id, su.initial_version + ne.idx, su.stream_id, su.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN stream_upsert su+ ),+ all_update AS (+ UPDATE streams+ SET stream_version = stream_version + (SELECT count(*) FROM new_events)+ WHERE stream_id = 0+ AND EXISTS (SELECT 1 FROM stream_upsert)+ RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+ ),+ all_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN all_update au+ CROSS JOIN stream_upsert su+ )+ SELECT su.stream_id,+ su.initial_version + (SELECT count(*) FROM new_events),+ au.initial_global_version + (SELECT count(*) FROM new_events)+ FROM stream_upsert su+ CROSS JOIN all_update au+ """++-- Two-round-trip variants: the proof-of-concept that the plan-23 restructure+-- is structurally faster than the production arrays/unnest CTE. The resolve+-- query reads (stream_id, stream_version, deleted_at) by stream_name; one of+-- two append CTEs then runs keyed on the resolved stream_id (existing) or on+-- the stream_name with no ON CONFLICT (new).++data RawResolution = RawResolution+ { resStreamId :: !Int64+ , resStreamVersion :: !Int64+ , resDeletedAt :: !(Maybe UTCTime)+ }+ deriving stock (Generic)++rawResolveStreamStmt :: Statement Text (Maybe RawResolution)+rawResolveStreamStmt =+ preparable+ rawResolveStreamSQL+ (E.param (E.nonNullable E.text))+ ( D.rowMaybe $+ RawResolution+ <$> D.column (D.nonNullable D.int8)+ <*> D.column (D.nonNullable D.int8)+ <*> D.column (D.nullable D.timestamptz)+ )++rawResolveStreamSQL :: Text+rawResolveStreamSQL =+ """+ SELECT stream_id, stream_version, deleted_at+ FROM streams+ WHERE stream_name = $1+ """++-- | Append params for the two-round-trip "existing" path: stream_id is known.+data RawAppendExistingParams = RawAppendExistingParams+ { existingStreamId :: !Int64+ , existingEventId :: !UUID+ , existingEventType :: !Text+ , existingCausationId :: !(Maybe UUID)+ , existingCorrelationId :: !(Maybe UUID)+ , existingPayload :: !Aeson.Value+ , existingMetadata :: !(Maybe Aeson.Value)+ , existingCreatedAt :: !UTCTime+ }+ deriving stock (Generic)++rawAppendExistingEncoder :: E.Params RawAppendExistingParams+rawAppendExistingEncoder =+ ((^. #existingStreamId) >$< E.param (E.nonNullable E.int8))+ <> ((^. #existingEventId) >$< E.param (E.nonNullable E.uuid))+ <> ((^. #existingEventType) >$< E.param (E.nonNullable E.text))+ <> ((^. #existingCausationId) >$< E.param (E.nullable E.uuid))+ <> ((^. #existingCorrelationId) >$< E.param (E.nullable E.uuid))+ <> ((^. #existingPayload) >$< E.param (E.nonNullable E.jsonb))+ <> ((^. #existingMetadata) >$< E.param (E.nullable E.jsonb))+ <> ((^. #existingCreatedAt) >$< E.param (E.nonNullable E.timestamptz))++rawAppendUpdateExisting :: Statement RawAppendExistingParams (Maybe RawAppendResult)+rawAppendUpdateExisting =+ preparable+ rawAppendUpdateExistingSQL+ rawAppendExistingEncoder+ rawAppendResultDecoder++{- | Update an existing stream keyed on integer stream_id. No version check,+no soft-delete check, no EXISTS gating, no count(*) — Haskell-side+validation has already done all of that.+-}+rawAppendUpdateExistingSQL :: Text+rawAppendUpdateExistingSQL =+ """+ WITH+ stream_update AS (+ UPDATE streams+ SET stream_version = stream_version + 1+ WHERE stream_id = $1::bigint+ RETURNING stream_id, stream_version - 1 AS initial_version+ ),+ inserted_event AS (+ INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+ VALUES ($2::uuid, $3::text, $4::uuid, $5::uuid, $6::jsonb, $7::jsonb, $8::timestamptz)+ ),+ source_link AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT $2::uuid, su.stream_id, su.initial_version + 1, su.stream_id, su.initial_version + 1+ FROM stream_update su+ ),+ all_update AS (+ UPDATE streams+ SET stream_version = stream_version + 1+ WHERE stream_id = 0+ RETURNING stream_version - 1 AS initial_global_version+ ),+ all_link AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT $2::uuid, 0, au.initial_global_version + 1, su.stream_id, su.initial_version + 1+ FROM all_update au+ CROSS JOIN stream_update su+ )+ SELECT su.stream_id,+ su.initial_version + 1,+ au.initial_global_version + 1+ FROM stream_update su+ CROSS JOIN all_update au+ """++-- | Append params for the two-round-trip "new stream" path: stream_name only.+data RawAppendNewParams = RawAppendNewParams+ { newStreamName :: !Text+ , newEventId :: !UUID+ , newEventType :: !Text+ , newCausationId :: !(Maybe UUID)+ , newCorrelationId :: !(Maybe UUID)+ , newPayload :: !Aeson.Value+ , newMetadata :: !(Maybe Aeson.Value)+ , newCreatedAt :: !UTCTime+ }+ deriving stock (Generic)++rawAppendNewEncoder :: E.Params RawAppendNewParams+rawAppendNewEncoder =+ ((^. #newStreamName) >$< E.param (E.nonNullable E.text))+ <> ((^. #newEventId) >$< E.param (E.nonNullable E.uuid))+ <> ((^. #newEventType) >$< E.param (E.nonNullable E.text))+ <> ((^. #newCausationId) >$< E.param (E.nullable E.uuid))+ <> ((^. #newCorrelationId) >$< E.param (E.nullable E.uuid))+ <> ((^. #newPayload) >$< E.param (E.nonNullable E.jsonb))+ <> ((^. #newMetadata) >$< E.param (E.nullable E.jsonb))+ <> ((^. #newCreatedAt) >$< E.param (E.nonNullable E.timestamptz))++rawAppendCreateNew :: Statement RawAppendNewParams (Maybe RawAppendResult)+rawAppendCreateNew =+ preparable+ rawAppendCreateNewSQL+ rawAppendNewEncoder+ rawAppendResultDecoder++{- | Create a new stream and append one event. No ON CONFLICT — Haskell-side+validation already proved the stream is absent; a race-loser hits the+ix_streams_stream_name unique constraint and surfaces as a usage error.+-}+rawAppendCreateNewSQL :: Text+rawAppendCreateNewSQL =+ """+ WITH+ stream_insert AS (+ INSERT INTO streams (stream_name, stream_version)+ VALUES ($1::text, 1)+ RETURNING stream_id, 0::bigint AS initial_version+ ),+ inserted_event AS (+ INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+ VALUES ($2::uuid, $3::text, $4::uuid, $5::uuid, $6::jsonb, $7::jsonb, $8::timestamptz)+ ),+ source_link AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT $2::uuid, si.stream_id, si.initial_version + 1, si.stream_id, si.initial_version + 1+ FROM stream_insert si+ ),+ all_update AS (+ UPDATE streams+ SET stream_version = stream_version + 1+ WHERE stream_id = 0+ RETURNING stream_version - 1 AS initial_global_version+ ),+ all_link AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT $2::uuid, 0, au.initial_global_version + 1, si.stream_id, si.initial_version + 1+ FROM all_update au+ CROSS JOIN stream_insert si+ )+ SELECT si.stream_id,+ si.initial_version + 1,+ au.initial_global_version + 1+ FROM stream_insert si+ CROSS JOIN all_update au+ """++mkRawAppendParams :: Text -> IO RawAppendParams+mkRawAppendParams name = do+ eventUuid <- oneUuid+ now <- getCurrentTime+ pure+ RawAppendParams+ { eventId = eventUuid+ , eventType = "RawBenchEvent"+ , causationId = Nothing+ , correlationId = Nothing+ , payload = Aeson.object [("benchmark", Aeson.Bool True)]+ , metadata = Nothing+ , createdAt = now+ , streamName = name+ }++mkRawProductionAppendParams :: RawAppendParams -> RawProductionAppendParams+mkRawProductionAppendParams params =+ RawProductionAppendParams+ { productionEventIds = V.singleton (params ^. #eventId)+ , productionEventTypes = V.singleton (params ^. #eventType)+ , productionCausationIds = V.singleton (params ^. #causationId)+ , productionCorrelationIds = V.singleton (params ^. #correlationId)+ , productionPayloads = V.singleton (params ^. #payload)+ , productionMetadatas = V.singleton (params ^. #metadata)+ , productionCreatedAts = V.singleton (params ^. #createdAt)+ , productionStreamName = params ^. #streamName+ }++oneUuid :: IO UUID+oneUuid = do+ generated <- V7.genUUIDs 1+ case generated of+ uuid : _ -> pure uuid+ [] -> error "oneUuid: UUID generator returned no IDs"++runRawScalarAppendAnyVersionNewStream :: KirokuStore -> IORef Int -> IO ()+runRawScalarAppendAnyVersionNewStream store counter = do+ streamId <- atomicModifyIORef' counter (\n -> (n + 1, n))+ params <- mkRawAppendParams ("raw-scalar-new-" <> T.pack (show streamId))+ result <- Pool.use (store ^. #pool) $ Session.statement params rawScalarAppendAnyVersion+ forceRawAppend result++runRawProductionAppendAnyVersionNewStream :: KirokuStore -> IORef Int -> IO ()+runRawProductionAppendAnyVersionNewStream store counter = do+ streamId <- atomicModifyIORef' counter (\n -> (n + 1, n))+ params <- mkRawProductionAppendParams <$> mkRawAppendParams ("raw-production-new-" <> T.pack (show streamId))+ result <- Pool.use (store ^. #pool) $ Session.statement params rawProductionAppendAnyVersion+ forceRawAppend result++runRawScalarAppendAnyVersionHotStream :: KirokuStore -> IO ()+runRawScalarAppendAnyVersionHotStream store = do+ params <- mkRawAppendParams "raw-scalar-hot"+ result <- Pool.use (store ^. #pool) $ Session.statement params rawScalarAppendAnyVersion+ forceRawAppend result++runRawProductionAppendAnyVersionHotStream :: KirokuStore -> IO ()+runRawProductionAppendAnyVersionHotStream store = do+ params <- mkRawProductionAppendParams <$> mkRawAppendParams "raw-production-hot"+ result <- Pool.use (store ^. #pool) $ Session.statement params rawProductionAppendAnyVersion+ forceRawAppend result++{- | Two-round-trip hot-stream variant: resolve stream by name, then UPDATE+the existing row keyed on integer stream_id. Both statements run on the+same pooled connection in a Session, each in its own implicit transaction+(no explicit BEGIN/COMMIT). This mirrors eventstore's small-batch path+(`EventStore.Streams.Stream.append_to_stream/5` at < 1000 events), which+runs two Postgrex.query calls without a transaction wrapper and relies on+the stream_events (stream_id, stream_version) unique constraint to detect+races. Wrapping in an explicit BEGIN/COMMIT adds two extra round-trips+and pessimises this path; that variant is measured separately below.+-}+runRawTwoRoundtripAppendExistingHotStream :: KirokuStore -> IO ()+runRawTwoRoundtripAppendExistingHotStream store = do+ base <- mkRawAppendParams "raw-two-roundtrip-hot"+ result <- Pool.use (store ^. #pool) $ do+ mRes <- Session.statement (base ^. #streamName) rawResolveStreamStmt+ case mRes of+ Nothing -> pure (Left "two-roundtrip hot bench: stream not pre-created")+ Just res -> do+ let params = mkRawAppendExistingParams (res ^. #resStreamId) base+ fmap Right (Session.statement params rawAppendUpdateExisting)+ forceTwoRoundtripResult result++{- | Two-round-trip new-stream variant. Same shape as the existing-stream+variant: two implicit-transaction round-trips on a pooled connection,+no explicit transaction wrapper.+-}+runRawTwoRoundtripAppendNewStream :: KirokuStore -> IORef Int -> IO ()+runRawTwoRoundtripAppendNewStream store counter = do+ streamId <- atomicModifyIORef' counter (\n -> (n + 1, n))+ base <- mkRawAppendParams ("raw-two-roundtrip-new-" <> T.pack (show streamId))+ result <- Pool.use (store ^. #pool) $ do+ mRes <- Session.statement (base ^. #streamName) rawResolveStreamStmt+ case mRes of+ Just _ -> pure (Left "two-roundtrip new bench: stream already exists")+ Nothing -> do+ let params = mkRawAppendNewParams base+ fmap Right (Session.statement params rawAppendCreateNew)+ forceTwoRoundtripResult result++{- | Two-round-trip hot-stream variant wrapped in an explicit+read-committed transaction. Provided as a separate benchmark to quantify+the BEGIN/COMMIT round-trip overhead so we can decide whether the live+append path can safely drop the transaction wrapper.+-}+runRawTwoRoundtripAppendExistingHotStreamTx :: KirokuStore -> IO ()+runRawTwoRoundtripAppendExistingHotStreamTx store = do+ base <- mkRawAppendParams "raw-two-roundtrip-hot"+ let txn = do+ mRes <- Tx.statement (base ^. #streamName) rawResolveStreamStmt+ case mRes of+ Nothing -> pure (Left "two-roundtrip hot tx bench: stream not pre-created")+ Just res -> do+ let params = mkRawAppendExistingParams (res ^. #resStreamId) base+ fmap Right (Tx.statement params rawAppendUpdateExisting)+ result <-+ Pool.use (store ^. #pool) $+ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write txn+ forceTwoRoundtripResult result++-- | Two-round-trip new-stream variant wrapped in an explicit transaction.+runRawTwoRoundtripAppendNewStreamTx :: KirokuStore -> IORef Int -> IO ()+runRawTwoRoundtripAppendNewStreamTx store counter = do+ streamId <- atomicModifyIORef' counter (\n -> (n + 1, n))+ base <- mkRawAppendParams ("raw-two-roundtrip-new-tx-" <> T.pack (show streamId))+ let txn = do+ mRes <- Tx.statement (base ^. #streamName) rawResolveStreamStmt+ case mRes of+ Just _ -> pure (Left "two-roundtrip new tx bench: stream already exists")+ Nothing -> do+ let params = mkRawAppendNewParams base+ fmap Right (Tx.statement params rawAppendCreateNew)+ result <-+ Pool.use (store ^. #pool) $+ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write txn+ forceTwoRoundtripResult result++mkRawAppendExistingParams :: Int64 -> RawAppendParams -> RawAppendExistingParams+mkRawAppendExistingParams sid base =+ RawAppendExistingParams+ { existingStreamId = sid+ , existingEventId = base ^. #eventId+ , existingEventType = base ^. #eventType+ , existingCausationId = base ^. #causationId+ , existingCorrelationId = base ^. #correlationId+ , existingPayload = base ^. #payload+ , existingMetadata = base ^. #metadata+ , existingCreatedAt = base ^. #createdAt+ }++mkRawAppendNewParams :: RawAppendParams -> RawAppendNewParams+mkRawAppendNewParams base =+ RawAppendNewParams+ { newStreamName = base ^. #streamName+ , newEventId = base ^. #eventId+ , newEventType = base ^. #eventType+ , newCausationId = base ^. #causationId+ , newCorrelationId = base ^. #correlationId+ , newPayload = base ^. #payload+ , newMetadata = base ^. #metadata+ , newCreatedAt = base ^. #createdAt+ }++forceTwoRoundtripResult ::+ Either Pool.UsageError (Either String (Maybe RawAppendResult)) -> IO ()+forceTwoRoundtripResult (Left e) =+ error ("Two-round-trip bench pool error: " <> show e)+forceTwoRoundtripResult (Right (Left msg)) =+ error ("Two-round-trip bench precondition failed: " <> msg)+forceTwoRoundtripResult (Right (Right inner)) =+ forceRawAppend (Right inner)++{- | Run @writers@ concurrent appenders, each performing @ops@ appends to+its own unique stream. Used by the structured concurrent-writer+benchmarks (EP-6 F19); replaces the wall-clock @mapConcurrently_@+measurement that previously lived inline in @main@.++The @runCounter@ ref is bumped once per call so stream names are unique+across the many iterations tasty-bench runs.+-}+runConcurrentWriters :: KirokuStore -> IORef Int -> Int -> Int -> IO ()+runConcurrentWriters store runCounter writers ops = do+ runId <- atomicModifyIORef' runCounter (\m -> (m + 1, m))+ mapConcurrently_+ (\tid -> mapM_ (appendOne tid runId) [1 .. ops])+ [1 .. writers]+ where+ appendOne :: Int -> Int -> Int -> IO ()+ appendOne tid runId i = do+ let sn = StreamName ("conc-" <> T.pack (show runId) <> "-" <> T.pack (show tid) <> "-" <> T.pack (show i))+ r <- runStoreIO store $ appendToStream sn AnyVersion [makeEvent "ConcEvent"]+ forceAppend r++-- | Exercise the hot stream named in the focused reliability audit.+runHotInvoicePayment :: KirokuStore -> Int -> IO ()+runHotInvoicePayment store ops =+ mapM_+ ( \i -> do+ r <- runStoreIO store $ appendToStream (StreamName "invoice-payment") AnyVersion [makeEvent ("InvoicePayment" <> T.pack (show i))]+ forceAppend r+ )+ [1 .. ops]++-- | Exercise appendMultiStream against existing streams.+runAppendMultiStream :: KirokuStore -> IO ()+runAppendMultiStream store = do+ r <-+ runStoreIO store $+ appendMultiStream+ [ (StreamName "bench-multi-a", AnyVersion, [makeEvent "MultiA"])+ , (StreamName "bench-multi-b", AnyVersion, [makeEvent "MultiB"])+ , (StreamName "bench-multi-c", AnyVersion, [makeEvent "MultiC"])+ ]+ forceAppendList r++-- | Exercise subscription catch-up over a compact category-local backlog.+runSubscriptionCatchup :: KirokuStore -> IORef Int -> IO ()+runSubscriptionCatchup store runCounter = do+ runId <- atomicModifyIORef' runCounter (\m -> (m + 1, m))+ let cat = "benchsub" <> T.pack (show runId)+ sn = StreamName (cat <> "-stream")+ subName = SubscriptionName ("bench-sub-" <> T.pack (show runId))+ events = map (\i -> makeEvent ("SubCatchup" <> T.pack (show i))) [1 .. 100 :: Int]+ r <- runStoreIO store $ appendToStream sn NoStream events+ forceAppend r+ seenRef <- newIORef (0 :: Int)+ let handler _ = do+ n <- atomicModifyIORef' seenRef (\m -> let m' = m + 1 in (m', m'))+ pure $ if n >= 100 then Stop else Continue+ cfg =+ SubscriptionConfig+ { name = subName+ , target = Category (CategoryName cat)+ , handler = handler+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ result <- wait handle+ case result of+ Right () -> pure ()+ Left e -> error ("Subscription catch-up benchmark failed: " <> show e)++-- | Force evaluation of an append result or fail the benchmark.+forceAppend :: Either StoreError AppendResult -> IO ()+forceAppend (Right r) = (r ^. #streamVersion) `seq` (r ^. #globalPosition) `seq` pure ()+forceAppend (Left e) = error ("Benchmark append failed: " <> show e)++-- | Force evaluation of multi-stream append results or fail the benchmark.+forceAppendList :: Either StoreError [AppendResult] -> IO ()+forceAppendList (Right rs) = mapM_ (\r -> (r ^. #streamVersion) `seq` (r ^. #globalPosition) `seq` pure ()) rs+forceAppendList (Left e) = error ("Benchmark appendMultiStream failed: " <> show e)++-- | Force evaluation of a raw append shape result or fail the benchmark.+forceRawAppend :: Either Pool.UsageError (Maybe RawAppendResult) -> IO ()+forceRawAppend (Right (Just (!streamId, !streamVersion, !globalPosition))) =+ streamId `seq` streamVersion `seq` globalPosition `seq` pure ()+forceRawAppend (Right Nothing) = error "Raw append benchmark produced no result"+forceRawAppend (Left e) = error ("Raw append benchmark failed: " <> show e)++-- | Force evaluation of a read result or fail the benchmark.+forceRead :: Either StoreError (V.Vector RecordedEvent) -> IO ()+forceRead (Right v) = V.length v `seq` pure ()+forceRead (Left e) = error ("Benchmark read failed: " <> show e)++main :: IO ()+main = do+ -- Start ephemeral PostgreSQL once for all benchmarks+ result <- Pg.withCached $ \db -> do+ let settings = defaultConnectionSettings (Pg.connectionString db)+ withStore settings $ \store -> do+ -- Counter for unique stream names across benchmarks+ counter <- newIORef (0 :: Int)+ let nextStream :: Text -> IO StreamName+ nextStream prefix = do+ n <- atomicModifyIORef' counter (\n -> (n + 1, n))+ pure (StreamName (prefix <> "-" <> T.pack (show n)))++ -- Pre-populate streams for category benchmarks (B10)+ -- 100 categories × 10 streams × 100 events = 100K events+ putStrLn "\n--- Pre-populating category data (100 cats × 10 streams × 100 events) ---"+ catT0 <- getCurrentTime+ mapM_+ ( \cat -> do+ mapM_+ ( \s -> do+ let sn = StreamName ("cat" <> T.pack (show cat) <> "-" <> T.pack (show s))+ let evts = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. 100 :: Int]+ r' <- runStoreIO store $ appendToStream sn NoStream evts+ forceAppend r'+ )+ [1 .. 10 :: Int]+ )+ [1 .. 100 :: Int]+ catT1 <- getCurrentTime+ let catElapsed = realToFrac (diffUTCTime catT1 catT0) :: Double+ putStrLn $ " Setup time: " <> show catElapsed <> "s (100K events)"++ -- Pre-populate streams for read benchmarks+ -- B4: Single stream with 1000 events+ let readStreamName = StreamName "bench-read-stream"+ let readEvents = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. 1000 :: Int]+ r <- runStoreIO store $ appendToStream readStreamName NoStream readEvents+ forceAppend r++ -- B5: 10 streams with 100 events each for $all reads (1000 total)+ mapM_+ ( \s -> do+ let sn = StreamName ("bench-all-" <> T.pack (show s))+ let evts = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. 100 :: Int]+ r' <- runStoreIO store $ appendToStream sn NoStream evts+ forceAppend r'+ )+ [1 .. 10 :: Int]++ -- Pre-create fixed streams for appendMultiStream benchmark iterations.+ mapM_+ ( \sn -> do+ r' <- runStoreIO store $ appendToStream sn NoStream [makeEvent "Init"]+ forceAppend r'+ )+ [StreamName "bench-multi-a", StreamName "bench-multi-b", StreamName "bench-multi-c"]++ -- Pre-create the hot stream targeted by the two-round-trip raw+ -- shape variant. rawAppendUpdateExisting requires the row to+ -- exist (no ON CONFLICT), so without this warmup the first+ -- iteration would fail. The scalar-singleton and production+ -- variants already create their hot stream on first iteration+ -- via ON CONFLICT — pre-creating them here would change the+ -- existing benchmark contract, so we only seed the two-round-trip+ -- target.+ do+ r' <- runStoreIO store $ appendToStream (StreamName "raw-two-roundtrip-hot") AnyVersion [makeEvent "Init"]+ forceAppend r'++ -- B9: Pool saturation benchmark (64 concurrent writers, 100 appends each)+ putStrLn "\n--- B9: Pool saturation (64 writers × 100 appends, pool size 10) ---"+ satCounter <- newIORef (0 :: Int)+ let nextSatStream :: Int -> Int -> StreamName+ nextSatStream tid i = StreamName ("sat-" <> T.pack (show tid) <> "-" <> T.pack (show i))+ t0 <- getCurrentTime+ mapConcurrently_+ ( \tid -> do+ mapM_+ ( \i -> do+ let sn = nextSatStream tid i+ r' <- runStoreIO store $ appendToStream sn AnyVersion [makeEvent "SatEvent"]+ forceAppend r'+ atomicModifyIORef' satCounter (\n -> (n + 1, ()))+ )+ [1 .. 100 :: Int]+ )+ [1 .. 64 :: Int]+ t1 <- getCurrentTime+ totalOps <- readIORef satCounter+ let elapsed = realToFrac (diffUTCTime t1 t0) :: Double+ let throughput = fromIntegral totalOps / elapsed+ let avgLatency = elapsed / fromIntegral totalOps * 1000 -- ms+ putStrLn $ " Total appends: " <> show totalOps+ putStrLn $ " Elapsed: " <> show elapsed <> "s"+ putStrLn $ " Throughput: " <> show (round throughput :: Int) <> " ops/s"+ putStrLn $ " Avg latency: " <> show avgLatency <> " ms"+ putStrLn "---"++ -- Counter shared by the concurrent-writer benchmarks so each+ -- iteration uses a fresh stream-name run-id.+ concCounter <- newIORef (0 :: Int)+ rawCounter <- newIORef (0 :: Int)+ subCounter <- newIORef (0 :: Int)++ defaultMain+ [ bgroup+ "append"+ [ bgroup+ "single-event"+ [ bench "NoStream (new stream)" $ whnfIO $ do+ sn <- nextStream "bench-single"+ r' <- runStoreIO store $ appendToStream sn NoStream [makeEvent "BenchEvent"]+ forceAppend r'+ , bench "AnyVersion (new stream)" $ whnfIO $ do+ sn <- nextStream "bench-any"+ r' <- runStoreIO store $ appendToStream sn AnyVersion [makeEvent "BenchEvent"]+ forceAppend r'+ ]+ , bgroup+ "batch-10"+ [ bench "NoStream" $ whnfIO $ do+ sn <- nextStream "bench-b10"+ let events = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. 10 :: Int]+ r' <- runStoreIO store $ appendToStream sn NoStream events+ forceAppend r'+ ]+ , bgroup+ "batch-100"+ [ bench "NoStream" $ whnfIO $ do+ sn <- nextStream "bench-b100"+ let events = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. 100 :: Int]+ r' <- runStoreIO store $ appendToStream sn NoStream events+ forceAppend r'+ ]+ , bgroup+ "sequential"+ [ bench "10 appends to same stream" $ whnfIO $ do+ sn <- nextStream "bench-seq"+ r0 <- runStoreIO store $ appendToStream sn NoStream [makeEvent "Init"]+ forceAppend r0+ let Right res0 = r0+ let go _ 0 = pure ()+ go v n = do+ r' <- runStoreIO store $ appendToStream sn (ExactVersion v) [makeEvent "Seq"]+ case r' of+ Right res -> go (res ^. #streamVersion) (n - 1 :: Int)+ Left e -> error ("Sequential append failed: " <> show e)+ go (res0 ^. #streamVersion) 9+ ]+ ]+ , bgroup+ "raw-append-shape"+ [ bgroup+ "AnyVersion"+ [ bench "scalar singleton (new stream)" $+ whnfIO $+ runRawScalarAppendAnyVersionNewStream store rawCounter+ , bench "production arrays/unnest (new stream)" $+ whnfIO $+ runRawProductionAppendAnyVersionNewStream store rawCounter+ , bench "two-roundtrip (new stream)" $+ whnfIO $+ runRawTwoRoundtripAppendNewStream store rawCounter+ , bench "two-roundtrip + BEGIN/COMMIT (new stream)" $+ whnfIO $+ runRawTwoRoundtripAppendNewStreamTx store rawCounter+ , bench "scalar singleton (hot stream)" $+ whnfIO $+ runRawScalarAppendAnyVersionHotStream store+ , bench "production arrays/unnest (hot stream)" $+ whnfIO $+ runRawProductionAppendAnyVersionHotStream store+ , bench "two-roundtrip (hot stream)" $+ whnfIO $+ runRawTwoRoundtripAppendExistingHotStream store+ , bench "two-roundtrip + BEGIN/COMMIT (hot stream)" $+ whnfIO $+ runRawTwoRoundtripAppendExistingHotStreamTx store+ ]+ ]+ , bgroup+ "read"+ [ bench "stream forward (100-event page)" $ whnfIO $ do+ r' <- runStoreIO store $ readStreamForward readStreamName (StreamVersion 0) 100+ forceRead r'+ , bench "$all forward (100-event page)" $ whnfIO $ do+ r' <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ forceRead r'+ ]+ , bgroup+ "category"+ [ bench "category forward (100-event page)" $ whnfIO $ do+ -- Read from cat1 category (has 10 streams × 100 events = 1000 events)+ r' <- runStoreIO store $ readCategory (CategoryName "cat1") (GlobalPosition 0) 100+ forceRead r'+ , bench "exhausted-category" $ whnfIO $ do+ -- cat1 events are inserted early in setup; a high cursor proves+ -- category reads do not scan the rest of $all looking for matches.+ r' <- runStoreIO store $ readCategory (CategoryName "cat1") (GlobalPosition 90_000) 100+ forceRead r'+ , bench "$all forward (100-event page, baseline)" $ whnfIO $ do+ r' <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ forceRead r'+ ]+ , -- F19 — Concurrent-writer stress as structured benchmarks.+ -- The legacy ad-hoc B9 measurement (still present above+ -- for historical comparability) prints throughput and+ -- latency once; these bgroup entries surface the same+ -- workload through tasty-bench so it participates in the+ -- baseline-regression workflow (Justfile bench-regression).+ bgroup+ "concurrent"+ [ bench "8 writers x 10 appends" $ whnfIO $ runConcurrentWriters store concCounter 8 10+ , bench "32 writers x 10 appends" $ whnfIO $ runConcurrentWriters store concCounter 32 10+ ]+ , bgroup+ "reliability-audit"+ [ bench "hot invoice-payment 10 AnyVersion appends" $ whnfIO $ runHotInvoicePayment store 10+ , bench "appendMultiStream 3 existing streams" $ whnfIO $ runAppendMultiStream store+ , bench "subscription category catch-up 100 events" $ whnfIO $ runSubscriptionCatchup store subCounter+ ]+ ]+ case result of+ Left err -> error ("Failed to start ephemeral PostgreSQL: " <> show err)+ Right () -> pure ()++makeEvent :: Text -> EventData+makeEvent typ =+ EventData+ { eventId = Nothing+ , eventType = EventType typ+ , payload = Aeson.object [("benchmark", Aeson.Bool True)]+ , metadata = Nothing+ , causationId = Nothing+ , correlationId = Nothing+ }
+ bench/ShibuyaOverhead.hs view
@@ -0,0 +1,304 @@+{- | Benchmark measuring the overhead of the Shibuya adapter layer+compared to bare kiroku subscriptions. Three layers are measured:++1. Bare subscribe: handler receives events directly from the subscription worker+2. subscriptionStream: events pass through a TBQueue bridge to a Streamly stream+3. Shibuya adapter: events flow through subscriptionStream → morphInner → Shibuya pipeline++The bare subscribe handler processes events synchronously (one at a time),+while the stream-based approaches decouple the producer from the consumer+via a TBQueue, allowing the subscription worker to batch-fetch ahead.+This means subscriptionStream and Shibuya can be *faster* for catch-up —+the relevant overhead comparison is shibuya vs subscriptionStream.+-}+module Main where++import Control.Concurrent (threadDelay)+import Control.Concurrent.STM (atomically, newTVarIO, readTVar, readTVarIO, registerDelay, writeTVar)+import Control.Concurrent.STM qualified as STM+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.HashMap.Strict qualified as HashMap+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import Data.List (sort)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time.Clock (diffUTCTime, getCurrentTime)+import Effectful (Eff, IOE, liftIO, runEff, (:>))+import EphemeralPg qualified as Pg+import Kiroku.Store+import Kiroku.Store.Subscription (subscribe)+import Kiroku.Store.Subscription.Stream (subscriptionStream)+import Kiroku.Store.Subscription.Types (OverflowPolicy (..), SubscriptionConfigM (..), SubscriptionHandleM (..))+import Shibuya.Adapter (Adapter (..))+import Shibuya.App (ProcessorId (..), SupervisionStrategy (..), mkProcessor, runApp, stopApp)+import Shibuya.Core.Ack (AckDecision (..))+import Shibuya.Core.AckHandle (AckHandle (..))+import Shibuya.Core.Ingested (Ingested (..))+import Shibuya.Core.Types (Cursor (..), Envelope (..), MessageId (..))+import Shibuya.Telemetry.Effect (runTracingNoop)+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Stream+import System.IO (hFlush, stdout)+import Text.Printf (printf)++iterations :: Int+iterations = 5++main :: IO ()+main = do+ result <- Pg.withCached $ \db -> do+ let settings = defaultConnectionSettings (Pg.connectionString db)+ withStore settings $ \store -> do+ putStrLn "=== Kiroku Shibuya Adapter Overhead Benchmark ==="+ printf " %d iterations per measurement\n\n" iterations++ mapM_ (runBenchmarkSuite store) [100, 1000, 5000]++ case result of+ Left err -> error ("Failed to start ephemeral PostgreSQL: " <> show err)+ Right () -> pure ()++runBenchmarkSuite :: KirokuStore -> Int -> IO ()+runBenchmarkSuite store n = do+ printf "--- %d events ---\n\n" n++ -- Pre-populate events+ counter <- newIORef (0 :: Int)+ let nextId = atomicModifyIORef' counter (\i -> (i + 1, i))++ let streamPrefix = "bench-" <> T.pack (show n) <> "-"+ let events = map (\i -> makeEvent ("E" <> T.pack (show i))) [1 .. n]+ let chunked = chunksOf 10 events+ mapM_+ ( \(idx, chunk) -> do+ let sn = StreamName (streamPrefix <> T.pack (show idx))+ Right _ <- runStoreIO store $ appendToStream sn AnyVersion chunk+ pure ()+ )+ (zip [(0 :: Int) ..] chunked)+ threadDelay 500_000++ -- Run each benchmark multiple times+ bareTimes <- sequence [benchBareSubscribe store n nextId | _ <- [1 .. iterations]]+ streamTimes <- sequence [benchSubscriptionStream store n nextId | _ <- [1 .. iterations]]+ shibuyaTimes <- sequence [benchShibuyaAdapter store n nextId | _ <- [1 .. iterations]]++ let bareMedian = median bareTimes+ streamMedian = median streamTimes+ shibuyaMedian = median shibuyaTimes++ putRow " bare subscribe" n bareTimes+ putRow " subscriptionStream" n streamTimes+ putRow " shibuya adapter" n shibuyaTimes++ putStrLn ""+ let streamVsBare = (streamMedian - bareMedian) / bareMedian * 100+ shibuyaVsBare = (shibuyaMedian - bareMedian) / bareMedian * 100+ shibuyaVsStream = (shibuyaMedian - streamMedian) / streamMedian * 100+ printf " stream vs bare: %s\n" (showPct streamVsBare)+ printf " shibuya vs bare: %s\n" (showPct shibuyaVsBare)+ printf " shibuya vs stream: %s (adapter + framework overhead)\n" (showPct shibuyaVsStream)+ putStrLn ""++-- | Benchmark: bare subscribe with IO handler+benchBareSubscribe :: KirokuStore -> Int -> IO Int -> IO Double+benchBareSubscribe store n nextId = do+ subId <- nextId+ let subName = SubscriptionName ("bare-bench-" <> T.pack (show subId))+ countVar <- newTVarIO (0 :: Int)++ t0 <- getCurrentTime+ let handler _evt = do+ atomically $ do+ c <- readTVar countVar+ writeTVar countVar (c + 1)+ pure Continue+ let cfg =+ SubscriptionConfig+ { name = subName+ , target = AllStreams+ , handler = handler+ , batchSize = 500+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ waitForCount countVar n 30_000_000+ cancel handle+ t1 <- getCurrentTime+ pure (realToFrac (diffUTCTime t1 t0))++-- | Benchmark: subscriptionStream consumed via Streamly fold+benchSubscriptionStream :: KirokuStore -> Int -> IO Int -> IO Double+benchSubscriptionStream store n nextId = do+ subId <- nextId+ let subName = SubscriptionName ("stream-bench-" <> T.pack (show subId))++ let cfg =+ SubscriptionConfig+ { name = subName+ , target = AllStreams+ , handler = \_ -> pure Continue+ , batchSize = 500+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }++ t0 <- getCurrentTime+ (stream, cancelStream) <- subscriptionStream store cfg 256+ Stream.fold Fold.drain (Stream.take n stream)+ cancelStream+ t1 <- getCurrentTime+ pure (realToFrac (diffUTCTime t1 t0))++-- | Benchmark: Shibuya adapter with runApp+benchShibuyaAdapter :: KirokuStore -> Int -> IO Int -> IO Double+benchShibuyaAdapter store n nextId = do+ subId <- nextId+ let subName = SubscriptionName ("shibuya-bench-" <> T.pack (show subId))+ countVar <- newTVarIO (0 :: Int)++ t0 <- getCurrentTime+ runEff $ runTracingNoop $ do+ let cfg =+ SubscriptionConfig+ { name = subName+ , target = AllStreams+ , handler = \_ -> pure Continue+ , batchSize = 500+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }++ (ioStream, cancelAction) <- liftIO $ subscriptionStream store cfg 256++ let effStream = Stream.morphInner liftIO ioStream+ ingestedStream = fmap (mkIngested cancelAction) effStream++ let adapter =+ Adapter+ { adapterName = "kiroku-bench"+ , source = ingestedStream+ , shutdown = liftIO cancelAction+ }++ let handler :: (IOE :> es) => Ingested es RecordedEvent -> Eff es AckDecision+ handler _ingested = do+ liftIO $ atomically $ do+ c <- readTVar countVar+ writeTVar countVar (c + 1)+ pure AckOk++ res <- runApp IgnoreFailures 100 [(ProcessorId "bench", mkProcessor adapter handler)]+ case res of+ Left err -> liftIO $ error ("runApp failed: " <> show err)+ Right appHandle -> do+ liftIO $ waitForCount countVar n 30_000_000+ stopApp appHandle++ t1 <- getCurrentTime+ pure (realToFrac (diffUTCTime t1 t0))++-- Helpers++mkIngested :: (IOE :> es) => IO () -> RecordedEvent -> Ingested es RecordedEvent+mkIngested cancelAction event =+ Ingested+ { envelope =+ Envelope+ { messageId = MessageId (T.pack (show (event ^. #globalPosition)))+ , cursor = let GlobalPosition pos = event ^. #globalPosition in Just (CursorInt (fromIntegral pos))+ , partition = Nothing+ , enqueuedAt = Just (event ^. #createdAt)+ , traceContext = Nothing+ , attempt = Nothing+ , attributes = HashMap.empty+ , payload = event+ }+ , ack =+ AckHandle+ { finalize = \case+ AckHalt _ -> liftIO cancelAction+ _ -> pure ()+ }+ , lease = Nothing+ }++waitForCount :: STM.TVar Int -> Int -> Int -> IO ()+waitForCount countVar target timeoutMicros = do+ timeoutVar <- registerDelay timeoutMicros+ ok <-+ atomically $+ (readTVar countVar >>= \c -> STM.check (c >= target) >> pure True)+ `STM.orElse` (readTVar timeoutVar >>= STM.check >> pure False)+ actual <- readTVarIO countVar+ if ok+ then pure ()+ else error ("Timed out: expected " <> show target <> " events, got " <> show actual)++median :: [Double] -> Double+median xs =+ let sorted = sort xs+ len = length sorted+ in if even len+ then (sorted !! (len `div` 2 - 1) + sorted !! (len `div` 2)) / 2+ else sorted !! (len `div` 2)++putRow :: String -> Int -> [Double] -> IO ()+putRow label n times = do+ let med = median times+ lo = minimum times+ hi = maximum times+ throughput = fromIntegral n / med :: Double+ perEvent = med / fromIntegral n * 1_000_000 :: Double+ printf+ "%s: median %s [%s .. %s] (%d events/s, %s/event)\n"+ label+ (showMs med)+ (showMs lo)+ (showMs hi)+ (round throughput :: Int)+ (showUs perEvent)+ hFlush stdout++showMs :: Double -> String+showMs s+ | ms < 1 = printf "%.1f ms" ms+ | ms < 100 = printf "%.0f ms" ms+ | otherwise = printf "%.0f ms" ms+ where+ ms = s * 1000++showUs :: Double -> String+showUs us+ | us >= 1000 = printf "%.1f ms" (us / 1000)+ | us >= 1 = printf "%.0f μs" us+ | otherwise = printf "%.1f μs" us++showPct :: Double -> String+showPct p+ | p >= 0 = printf "+%.0f%%" p+ | otherwise = printf "%.0f%%" p++chunksOf :: Int -> [a] -> [[a]]+chunksOf _ [] = []+chunksOf k xs = let (h, t) = splitAt k xs in h : chunksOf k t++makeEvent :: Text -> EventData+makeEvent typ =+ EventData+ { eventId = Nothing+ , eventType = EventType typ+ , payload = Aeson.object [("benchmark", Aeson.Bool True)]+ , metadata = Nothing+ , causationId = Nothing+ , correlationId = Nothing+ }
+ example/Main.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Runnable demonstration of consumer groups (MasterPlan 4 / EP-4).++This program starts its own ephemeral PostgreSQL (no external database needed),+appends 120 events across 40 streams in one category, then runs a size-4+consumer group. Each of the four members collects the global position of every+event it receives into its own 'IORef'. After the group has processed all 120+events, the program prints each member's count and verifies the two key+guarantees:++ * /complete/ — the four members' counts sum to 120.+ * /disjoint/ — the union of all positions is exactly @[1 .. 120]@, with no+ event delivered to two members and none dropped.++Run it from the repository root:++@cabal run kiroku-store:kiroku-consumer-group-example@++The per-member counts vary run to run (they depend on which streams hash to+which member via PostgreSQL's @hashtextextended@), but @complete: OK@ and+@disjoint: OK@ are deterministic. See @docs/user/consumer-groups.md@ for the+full explanation of the guarantees demonstrated here.+-}+module Main (main) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.STM (atomically, check)+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Foldable (for_)+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int32)+import Data.List (sort)+import Data.Text qualified as T+import EphemeralPg qualified as Pg+import Kiroku.Store+import Kiroku.Store.Subscription.EventPublisher (publisherPosition)+import Kiroku.Store.Subscription.Types (ConsumerGroup (..))++-- | Block until the publisher has ingested at least 'target' events.+waitForPublisher :: KirokuStore -> GlobalPosition -> IO ()+waitForPublisher store (GlobalPosition target) =+ atomically do+ GlobalPosition p <- publisherPosition (store ^. #publisher)+ check (p >= target)++-- | Poll 'act' every 20 ms until it returns 'True' or 'budget' microseconds elapse.+waitUntil :: Int -> IO Bool -> IO ()+waitUntil budget act+ | budget <= 0 = pure ()+ | otherwise = do+ ok <- act+ if ok+ then pure ()+ else do+ threadDelay 20_000+ waitUntil (budget - 20_000) act++main :: IO ()+main = do+ result <- Pg.withCached \db -> do+ let connStr = Pg.connectionString db+ withStore (defaultConnectionSettings connStr) \store -> do+ -- 1. Append 120 events across 40 streams in category "example".+ -- A stream's category is its name up to the first '-', so+ -- "example-0" .. "example-39" all live in category "example".+ let streamNames = ["example-" <> T.pack (show i) | i <- [0 .. 39 :: Int]]+ for_ streamNames \sn -> do+ let evs =+ [ EventData+ { eventId = Nothing+ , eventType = EventType "ExampleEvent"+ , payload = Aeson.object []+ , metadata = Nothing+ , causationId = Nothing+ , correlationId = Nothing+ }+ | _ <- [1 .. 3 :: Int]+ ]+ r <- runStoreIO store (appendToStream (StreamName sn) AnyVersion evs)+ case r of+ Left err -> error ("append failed for " <> T.unpack sn <> ": " <> show err)+ Right _ -> pure ()++ -- 2. Wait for the publisher to ingest all 120 events.+ waitForPublisher store (GlobalPosition 120)+ putStrLn "Appended 120 events across 40 streams. Starting 4-member consumer group..."++ -- 3. Start one collector per member. Each member records the global+ -- position of every event it receives into its own IORef.+ let groupSize = 4 :: Int32+ refs <- mapM (const (newIORef ([] :: [GlobalPosition]))) [0 .. groupSize - 1]+ handles <-+ mapM+ ( \m -> do+ let ref = refs !! fromIntegral m+ h evt = do+ modifyIORef' ref (evt ^. #globalPosition :)+ pure Continue+ cfg =+ ( defaultSubscriptionConfig+ (SubscriptionName "example-group")+ (Category (CategoryName "example"))+ h+ )+ { consumerGroup = Just (ConsumerGroup{member = m, size = groupSize})+ }+ subscribe store cfg+ )+ [0 .. groupSize - 1]++ -- 4. Wait until all 120 events are collected, then stop every member.+ let collectedCount = sum <$> mapM (fmap length . readIORef) refs+ waitUntil 30_000_000 (fmap (>= 120) collectedCount)+ for_ handles cancel++ -- 5. Compute and print the summary.+ collected <- mapM readIORef refs+ let memberCounts = map length collected+ totalCollected = sum memberCounts+ allPositions = sort (concat collected)+ expectedPositions = map GlobalPosition [1 .. 120]+ isComplete = totalCollected == 120+ isDisjoint = allPositions == expectedPositions++ putStrLn ""+ putStrLn "=== Consumer Group Partition Summary ==="+ for_ (zip [0 :: Int ..] memberCounts) \(m, cnt) ->+ putStrLn (" member " <> show m <> ": " <> show cnt <> " events")+ putStrLn (" total : " <> show totalCollected)+ putStrLn ""+ putStrLn ("complete: " <> if isComplete then "OK" else "FAIL (expected 120)")+ putStrLn ("disjoint: " <> if isDisjoint then "OK" else "FAIL (duplicate or missing positions)")+ putStrLn ""+ let sample = take 5 (reverse (collected !! 0))+ putStrLn ("member 0 first 5 positions (delivery order): " <> show sample)++ case result of+ Left err -> error ("EphemeralPg failed: " <> show err)+ Right () -> pure ()
+ kiroku-store.cabal view
@@ -0,0 +1,214 @@+cabal-version: 3.0+name: kiroku-store+version: 0.1.0.0+synopsis: High-performance PostgreSQL event store+description:+ Kiroku is a PostgreSQL-backed event store for Haskell applications. It+ provides append, read, link, lifecycle, transaction, subscription, consumer+ group, and observability primitives around immutable domain events.++homepage: https://github.com/shinzui/kiroku+bug-reports: https://github.com/shinzui/kiroku/issues+author: Nadeem Bitar+maintainer: nadeem@gmail.com+license: BSD-3-Clause+build-type: Simple+category: Database, Eventing+extra-doc-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/shinzui/kiroku.git++common common+ default-language: GHC2024+ default-extensions:+ DeriveAnyClass+ DuplicateRecordFields+ OverloadedLabels+ OverloadedStrings++library+ import: common+ exposed-modules:+ Kiroku.Store+ Kiroku.Store.Append+ Kiroku.Store.Causation+ Kiroku.Store.Connection+ Kiroku.Store.Effect+ Kiroku.Store.Effect.Resource+ Kiroku.Store.Error+ Kiroku.Store.Lifecycle+ Kiroku.Store.Link+ Kiroku.Store.Notification+ Kiroku.Store.Observability+ Kiroku.Store.Read+ Kiroku.Store.Settings+ Kiroku.Store.SQL+ Kiroku.Store.Subscription+ Kiroku.Store.Subscription.Effect+ Kiroku.Store.Subscription.EventPublisher+ Kiroku.Store.Subscription.Stream+ Kiroku.Store.Subscription.Types+ Kiroku.Store.Subscription.Worker+ Kiroku.Store.Transaction+ Kiroku.Store.Types++ build-depends:+ , aeson >=2.1 && <2.3+ , async >=2.2 && <2.3+ , base >=4.18 && <5+ , containers >=0.6 && <0.8+ , contravariant-extras >=0.3 && <0.4+ , effectful-core >=2.4 && <2.7+ , generic-lens >=2.2 && <2.4+ , hasql >=1.10 && <1.11+ , hasql-notifications >=0.2 && <0.3+ , hasql-pool >=1.2 && <1.5+ , hasql-transaction >=1.1 && <1.3+ , lens >=5.2 && <5.4+ , mmzk-typeid >=0.6 && <0.8+ , stm >=2.5 && <2.6+ , streamly-core >=0.3 && <0.4+ , text >=2.0 && <2.2+ , time >=1.12 && <1.15+ , unliftio-core >=0.2 && <0.3+ , uuid >=1.3 && <1.4+ , vector >=0.13 && <0.14++ hs-source-dirs: src++test-suite kiroku-store-test+ import: common+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ other-modules:+ Test.Causation+ Test.Concurrency+ Test.ConsumerGroup+ Test.ConsumerGroupEffect+ Test.ConsumerGroupSql+ Test.FailureInjection+ Test.Helpers+ Test.InterpreterHooks+ Test.Properties+ Test.ReadStream+ Test.StreamNameLookup+ Test.Transaction++ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ , aeson >=2.1 && <2.3+ , async >=2.2 && <2.3+ , base >=4.18 && <5+ , containers >=0.6 && <0.8+ , contravariant-extras >=0.3+ , directory+ , effectful-core >=2.4 && <2.7+ , ephemeral-pg >=0.2 && <0.3+ , generic-lens >=2.2 && <2.4+ , hasql >=1.10 && <1.11+ , hasql-pool >=1.2 && <1.5+ , hasql-transaction >=1.1 && <1.3+ , hedgehog >=1.4 && <1.8+ , hspec >=2.10 && <2.12+ , hspec-hedgehog >=0.0 && <0.4+ , kiroku-store+ , kiroku-test-support+ , lens >=5.2 && <5.4+ , stm >=2.5 && <2.6+ , streamly-core >=0.3 && <0.4+ , text >=2.0 && <2.2+ , time >=1.12 && <1.15+ , uuid >=1.3 && <1.4+ , vector >=0.13 && <0.14++benchmark kiroku-store-bench+ import: common+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A32m"+ build-depends:+ , aeson >=2.1 && <2.3+ , async >=2.2 && <2.3+ , base >=4.18 && <5+ , deepseq >=1.4+ , ephemeral-pg >=0.2 && <0.3+ , generic-lens >=2.2 && <2.4+ , hasql >=1.10 && <1.11+ , hasql-pool >=1.2 && <1.5+ , hasql-transaction >=1.1 && <1.3+ , kiroku-store+ , lens >=5.2 && <5.4+ , mmzk-typeid >=0.6+ , tasty-bench >=0.4+ , text >=2.0 && <2.2+ , time >=1.12 && <1.15+ , uuid >=1.3 && <1.4+ , vector >=0.13 && <0.14++benchmark kiroku-shibuya-overhead+ import: common+ type: exitcode-stdio-1.0+ main-is: ShibuyaOverhead.hs+ hs-source-dirs: bench+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A32m"+ build-depends:+ , aeson >=2.1 && <2.3+ , base >=4.18 && <5+ , containers >=0.6 && <0.8+ , effectful >=2.4 && <2.7+ , effectful-core >=2.4 && <2.7+ , ephemeral-pg >=0.2 && <0.3+ , generic-lens >=2.2 && <2.4+ , kiroku-store+ , lens >=5.2 && <5.4+ , shibuya-core >=0.5 && <0.6+ , stm >=2.5 && <2.6+ , streamly >=0.11+ , streamly-core >=0.3 && <0.4+ , text >=2.0 && <2.2+ , time >=1.12 && <1.15+ , unliftio >=0.2+ , unordered-containers >=0.2 && <0.3+ , uuid >=1.3 && <1.4++benchmark kiroku-store-bench-explain+ import: common+ type: exitcode-stdio-1.0+ main-is: Explain.hs+ hs-source-dirs: bench+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A32m"+ build-depends:+ , aeson >=2.1 && <2.3+ , base >=4.18 && <5+ , bytestring >=0.11 && <0.13+ , directory >=1.3+ , ephemeral-pg >=0.2 && <0.3+ , filepath >=1.4+ , generic-lens >=2.2 && <2.4+ , hasql >=1.10 && <1.11+ , hasql-pool >=1.2 && <1.5+ , kiroku-store+ , lens >=5.2 && <5.4+ , text >=2.0 && <2.2+ , time >=1.12 && <1.15+ , uuid >=1.3 && <1.4+ , vector >=0.13 && <0.14++executable kiroku-consumer-group-example+ import: common+ main-is: Main.hs+ hs-source-dirs: example+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ , aeson >=2.1 && <2.3+ , base >=4.18 && <5+ , ephemeral-pg >=0.2 && <0.3+ , generic-lens >=2.2 && <2.4+ , kiroku-store+ , lens >=5.2 && <5.4+ , stm >=2.5 && <2.6+ , text >=2.0 && <2.2
+ src/Kiroku/Store.hs view
@@ -0,0 +1,62 @@+{- | Kiroku Store — high-performance PostgreSQL event store.++Public API re-exports.++Note: The effectful @subscribe@ wrapper from "Kiroku.Store.Subscription.Effect"+is /not/ re-exported here to avoid a name clash with+"Kiroku.Store.Subscription.subscribe". Import @Kiroku.Store.Subscription.Effect@+explicitly to use the effectful version.+-}+module Kiroku.Store (+ module Kiroku.Store.Types,+ module Kiroku.Store.Connection,+ module Kiroku.Store.Effect,+ module Kiroku.Store.Effect.Resource,+ module Kiroku.Store.Error,+ module Kiroku.Store.Append,+ module Kiroku.Store.Causation,+ module Kiroku.Store.Lifecycle,+ module Kiroku.Store.Link,+ module Kiroku.Store.Read,+ module Kiroku.Store.Settings,+ module Kiroku.Store.Subscription,+ module Kiroku.Store.Transaction,++ -- * Subscription effect (interpreter only — import Effect module for @subscribe@)+ Subscription,+ runSubscription,+ runSubscriptionResource,++ -- * Notifier startup+ NotifierStartError (..),++ -- * Operational events emitted by the store itself+ KirokuEvent (..),+ SubscriptionDbPhase (..),+ SubscriptionStopReason (..),+ SubscriptionGroupContext (..),++ -- * Pool observation types (re-exported from hasql-pool)+ Observation (..),+ ConnectionStatus (..),+ ConnectionReadyForUseReason (..),+ ConnectionTerminationReason (..),+) where++import Hasql.Pool.Observation (ConnectionReadyForUseReason (..), ConnectionStatus (..), ConnectionTerminationReason (..), Observation (..))+import Kiroku.Store.Append+import Kiroku.Store.Causation+import Kiroku.Store.Connection+import Kiroku.Store.Effect+import Kiroku.Store.Effect.Resource+import Kiroku.Store.Error+import Kiroku.Store.Lifecycle+import Kiroku.Store.Link+import Kiroku.Store.Notification (NotifierStartError (..))+import Kiroku.Store.Observability (KirokuEvent (..), SubscriptionDbPhase (..), SubscriptionGroupContext (..), SubscriptionStopReason (..))+import Kiroku.Store.Read+import Kiroku.Store.Settings+import Kiroku.Store.Subscription+import Kiroku.Store.Subscription.Effect (Subscription, runSubscription, runSubscriptionResource)+import Kiroku.Store.Transaction+import Kiroku.Store.Types
+ src/Kiroku/Store/Append.hs view
@@ -0,0 +1,110 @@+module Kiroku.Store.Append (+ appendToStream,+ appendMultiStream,+) where++import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Kiroku.Store.Effect (Store (..))+import Kiroku.Store.Types++{- | Append a batch of events to a single stream under the given+'ExpectedVersion' precondition.++When to use this vs.+'Kiroku.Store.Transaction.runTransactionAppending':++* Reach for 'appendToStream' by default. It is the cheapest path —+ one CTE on a pool connection, no Haskell-layer @BEGIN@/@COMMIT@+ envelope, no caller-driven retry semantics to reason about.+* Reach for 'Kiroku.Store.Transaction.runTransactionAppending' /only/+ when you need to atomically combine the append with additional SQL+ writes that the store doesn't perform (most prominently a+ projection-row insert from a downstream projection table). The+ wrapper opens an explicit 'BEGIN'/'COMMIT', enables PostgreSQL+ serialization-conflict retry of the entire body by default, and+ threads the caller's continuation into the same transaction.++Semantics:++* If the precondition fails, the entire batch is rejected — appends are+ all-or-nothing per call.+* On success, events are visible to subsequent reads on /this/ store+ handle (read-your-own-writes is guaranteed). Other store handles see+ the events after their pool connection's transaction-visibility+ horizon advances.+* The returned 'AppendResult' carries the position of the /last/ event+ in the batch.++Idempotent retries: supply 'Kiroku.Store.Types.EventData.eventId' yourself+and retry on transient failures. A retry whose previous attempt actually+committed surfaces as 'Kiroku.Store.Error.DuplicateEvent' (when the+events_pkey detail is parseable). A retry that observed+'Kiroku.Store.Error.WrongExpectedVersion' on an 'ExactVersion' append+should be treated as ambiguous: either a concurrent writer raced you or+your previous attempt succeeded; the recovery in both cases is to+re-read the stream and decide.++Errors (all variants of 'Kiroku.Store.Error.StoreError'):++* 'Kiroku.Store.Error.WrongExpectedVersion' — 'ExactVersion' mismatch.+* 'Kiroku.Store.Error.StreamNotFound' — 'StreamExists' against a missing+ or soft-deleted stream.+* 'Kiroku.Store.Error.ReservedStreamName' — the target is @$all@, which+ is the global read stream and cannot be appended as an application+ stream.+* 'Kiroku.Store.Error.StreamAlreadyExists' — 'NoStream' against an+ existing stream (including soft-deleted).+* 'Kiroku.Store.Error.DuplicateEvent' — caller-supplied 'eventId'+ collides with an existing event.++Empty event lists: passing @[]@ is a programming mistake. The+underlying CTE returns 0 rows, which the interpreter maps to a+constructor that depends on the supplied 'ExpectedVersion'+('Kiroku.Store.Error.WrongExpectedVersion' for 'ExactVersion',+'Kiroku.Store.Error.StreamNotFound' for 'StreamExists', and so on).+None of these is the caller's intent; reject the call yourself before+invoking the API.+-}+appendToStream ::+ (HasCallStack, Store :> es) =>+ StreamName ->+ ExpectedVersion ->+ [EventData] ->+ Eff es AppendResult+appendToStream name expected events = send (AppendToStream name expected events)++{- | Atomically append events to multiple streams in a single+transaction.++Either every per-stream append succeeds or all of them roll back —+there is no partial-commit state. The interpreter pre-locks the named+streams in deterministic @stream_id@ order to avoid deadlocks when two+concurrent multi-stream calls touch overlapping streams in different+user orders.++@$all@ is reserved for the global read stream. If any operation targets+@$all@, the whole call is rejected before opening the transaction with+'Kiroku.Store.Error.ReservedStreamName'.++Per-stream errors are attributed to the stream that caused them: the+@Right results@ branch of the interpreter iterates the input list and+maps each empty CTE result back to the corresponding @(StreamName,+ExpectedVersion)@. Errors raised as PostgreSQL exceptions are+attributed via 'Kiroku.Store.Error.attributeMultiStreamError', which+parses the server-error detail for the offending stream name when+possible; the latent misattribution path (a future schema change that+introduces a constraint violation visible to the client) is covered+defensively.++The returned list mirrors the input order. Each 'AppendResult' carries+the corresponding stream's final state.++Empty input @[]@ is a no-op programming mistake; do not call.+-}+appendMultiStream ::+ (HasCallStack, Store :> es) =>+ [(StreamName, ExpectedVersion, [EventData])] ->+ Eff es [AppendResult]+appendMultiStream ops = send (AppendMultiStream ops)
+ src/Kiroku/Store/Causation.hs view
@@ -0,0 +1,66 @@+{- | Smart constructors for the causation- and correlation-walking reads.++These wrap the 'Kiroku.Store.Effect.FindEvents' constructor with a filter+suited to a specific question:++* 'findCausationDescendants' — walk the causation graph forward from a+ trigger event and return every event that descended from it.+* 'findCausationAncestors' — walk the causation graph backward from a+ leaf event and return every event reachable by following+ @causation_id@ upward.+* 'findByCorrelation' — return every event whose @correlation_id@ equals+ the input.++All three reuse the existing partial indexes @ix_events_causation_id@ and+@ix_events_correlation_id@ on the @events@ table, so they do not require+any schema change.+-}+module Kiroku.Store.Causation (+ findCausationDescendants,+ findCausationAncestors,+ findByCorrelation,+) where++import Data.UUID (UUID)+import Data.Vector (Vector)+import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Kiroku.Store.Effect (Store (..))+import Kiroku.Store.Types++{- | Return the seed event and every event whose @causation_id@ chain leads+back to it, in ascending @global_position@ order. The seed event is+included as the depth-0 row when it exists; otherwise the result is+empty.++Uses the @ix_events_causation_id@ partial index. Cost is+@O(depth * log n)@ where @depth@ is the length of the longest chain+rooted at the seed and @n@ is the total event count.+-}+findCausationDescendants ::+ (HasCallStack, Store :> es) =>+ EventId ->+ Eff es (Vector RecordedEvent)+findCausationDescendants eid = send (FindEvents (FilterCausationDescendants eid))++{- | Return the seed event and every ancestor reachable via @causation_id@,+in depth-ascending order (the seed is first, its immediate cause is+second, etc.). The seed event is included as the depth-0 row when it+exists; otherwise the result is empty.+-}+findCausationAncestors ::+ (HasCallStack, Store :> es) =>+ EventId ->+ Eff es (Vector RecordedEvent)+findCausationAncestors eid = send (FindEvents (FilterCausationAncestors eid))++{- | Return every event whose @correlation_id@ equals the input, in+ascending @global_position@ order. Uses the @ix_events_correlation_id@+partial index.+-}+findByCorrelation ::+ (HasCallStack, Store :> es) =>+ UUID ->+ Eff es (Vector RecordedEvent)+findByCorrelation cid = send (FindEvents (FilterCorrelation cid))
+ src/Kiroku/Store/Connection.hs view
@@ -0,0 +1,226 @@+module Kiroku.Store.Connection (+ KirokuStore (..),+ ConnectionSettingsM (..),+ ConnectionSettings,+ defaultConnectionSettings,+ withStore,+) where++import Control.Exception (bracket)+import Control.Lens ((^.))+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import Hasql.Connection.Settings qualified as Conn+import Hasql.Pool (Pool)+import Hasql.Pool qualified as Pool+import Hasql.Pool.Config qualified as Pool.Config+import Hasql.Pool.Observation (Observation)+import Hasql.Session qualified as Session+import Kiroku.Store.Notification (Notifier)+import Kiroku.Store.Notification qualified as Notifier+import Kiroku.Store.Observability (KirokuEvent)+import Kiroku.Store.Settings (StoreSettings, defaultStoreSettings)+import Kiroku.Store.Subscription.EventPublisher (EventPublisher)+import Kiroku.Store.Subscription.EventPublisher qualified as Publisher++-- | 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.+ -}+ , idleInTransactionTimeout :: !Int+ -- ^ idle_in_transaction_session_timeout in seconds (default: 30)+ , statementTimeout :: !(Maybe Int)+ {- ^ When @Just s@, set @statement_timeout = 's'@ (in seconds) on+ every pooled connection via @initSession@. Bounds the wall-clock+ runtime of any single statement; protects against pathological+ queries holding pool slots indefinitely. Default 'Nothing'+ (PostgreSQL's session default applies — typically @0@,+ meaning no timeout).++ A reasonable starting value for typical workloads is @Just 30@+ (30 seconds) — long enough to absorb GC pauses and transient+ slow disks, short enough to free the pool slot under genuine+ pathology. See @docs\/PRODUCTION-TUNING.md@ for sizing+ guidance.+ -}+ , observationHandler :: !(Maybe (Observation -> m ()))+ -- ^ Optional callback for pool connection lifecycle events+ , eventHandler :: !(Maybe (KirokuEvent -> m ()))+ {- ^ Optional callback for store-emitted operational events. See+ "Kiroku.Store.Observability" for the event taxonomy. Covers+ notifier reconnection, publisher pool errors, subscription+ lifecycle and per-phase database errors, and hard-delete+ issuance — events that 'observationHandler' (which surfaces+ @hasql-pool@'s connection-lifecycle observations) does not+ cover.++ Invoked synchronously from the originating thread (notifier+ loop, publisher loop, worker loop, store interpreter); slow+ callbacks stall those loops. For callbacks that may block, fan+ out asynchronously (e.g., write to a 'TBQueue' and drain in a+ separate thread).+ -}+ , storeSettings :: !StoreSettings+ {- ^ Interpreter-level hooks applied to 'EventData' on the append+ path and to 'RecordedEvent' on the read and subscription paths.+ Defaults to 'defaultStoreSettings' (no-op).++ See "Kiroku.Store.Settings" for the hook semantics and the+ OpenTelemetry trace-context use case that motivates this seam.+ -}+ }+ deriving stock (Generic)++-- | Connection settings defaulting to 'IO'.+type ConnectionSettings = ConnectionSettingsM IO++-- | Default connection settings.+defaultConnectionSettings :: Text -> ConnectionSettings+defaultConnectionSettings cs =+ ConnectionSettings+ { connString = cs+ , poolSize = 10+ , schema = "kiroku"+ , 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.+ -}+ }+ deriving stock (Generic)++{- | Bracket-style store lifecycle.++Acquire phase, in order:++1. Acquire the connection pool from @hasql-pool@ with the configured+ size and the @idle_in_transaction_session_timeout@ init session.+2. Start the 'Kiroku.Store.Notification.Notifier' on a dedicated+ connection: @LISTEN \<schema\>.events@.+3. Start the 'Kiroku.Store.Subscription.EventPublisher' which consumes+ notifier ticks and broadcasts new events to subscribers.++Release phase, in reverse order:++1. Cancel the 'Kiroku.Store.Subscription.EventPublisher' worker.+2. Stop the 'Kiroku.Store.Notification.Notifier' (cancel listener,+ release connection).+3. Release the pool.++The @bracket@ semantics guarantee release runs on either normal exit+or an exception in the body. The 'MonadUnliftIO' constraint matches+'Control.Exception.bracket'; consumers in pure 'IO' get an exact match,+consumers in effectful monads with an unlift in scope (e.g., a+'ReaderT'-like stack) get the same guarantee transparently.+-}+withStore :: (MonadUnliftIO m) => ConnectionSettings -> (KirokuStore -> m a) -> m a+withStore settings action = withRunInIO $ \runInIO ->+ bracket acquire release (runInIO . action)+ where+ initScript :: Text+ initScript =+ T.intercalate "; " $+ -- Resolve unqualified Kiroku table names (see "Kiroku.Store.SQL")+ -- to the configured schema on every pooled connection. Setting a+ -- not-yet-created schema is harmless: PostgreSQL does not validate+ -- search_path entries. Runtime queries still require migrations to+ -- have created the schema before the store is opened.+ ("SET search_path TO " <> quoteIdentifier (settings ^. #schema) <> ", pg_catalog")+ : ("SET idle_in_transaction_session_timeout = '" <> T.pack (show (settings ^. #idleInTransactionTimeout)) <> "s'")+ : maybe+ []+ (\t -> ["SET statement_timeout = '" <> T.pack (show t) <> "s'"])+ (settings ^. #statementTimeout)++ poolConfig :: Pool.Config.Config+ poolConfig =+ Pool.Config.settings $+ [ Pool.Config.staticConnectionSettings (Conn.connectionString (settings ^. #connString))+ , Pool.Config.size (settings ^. #poolSize)+ , Pool.Config.initSession (Session.script initScript)+ ]+ ++ maybe [] (\h -> [Pool.Config.observationHandler h]) (settings ^. #observationHandler)++ acquire = do+ p <- Pool.acquire poolConfig+ let s = settings ^. #schema+ cs = settings ^. #connString+ evtHandler = settings ^. #eventHandler+ stSettings = settings ^. #storeSettings+ -- Start Notifier (dedicated LISTEN connection)+ n <- Notifier.startNotifier cs s evtHandler+ -- Start EventPublisher (depends on Notifier's TChan)+ pub <- Publisher.startPublisher p (Notifier.tickChan n) evtHandler stSettings+ pure+ KirokuStore+ { pool = p+ , schema = s+ , notifier = n+ , publisher = pub+ , eventHandler = evtHandler+ , storeSettings = stSettings+ }++ release store = do+ -- Stop in reverse order: Publisher first, then Notifier, then pool+ Publisher.stopPublisher (store ^. #publisher)+ Notifier.stopNotifier (store ^. #notifier)+ Pool.release (store ^. #pool)++{- | Quote a 'Text' as a PostgreSQL identifier: wrap it in double quotes and+double any embedded double quote. Used to set the configured schema in+@search_path@ without risking SQL injection from a hostile schema setting.+-}+quoteIdentifier :: Text -> Text+quoteIdentifier ident = "\"" <> T.replace "\"" "\"\"" ident <> "\""
+ src/Kiroku/Store/Effect.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE TypeFamilies #-}++module Kiroku.Store.Effect (+ -- * The Store effect+ Store (..),++ -- * Interpreters+ runStorePool,+ runStoreResource,+ runStoreIO,++ -- * Internal building blocks++ --+ -- $internal+ PreparedEvent,+ prepareEvents,+ buildAppendParams,+ appendDispatchTx,+) where++import Control.Lens ((^.))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (Value)+import Data.Foldable (for_)+import Data.Generics.Labels ()+import Data.Int (Int32, Int64)+import Data.List (find)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (isNothing)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.UUID (UUID)+import Data.UUID.V7 qualified as V7+import Data.Vector (Vector)+import Data.Vector qualified as V+import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, runEff, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, runErrorNoCallStack, throwError)+import GHC.Generics (Generic)+import Hasql.Pool (Pool)+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Transaction qualified as Tx+import Hasql.Transaction.Sessions qualified as TxSessions+import Kiroku.Store.Connection (KirokuStore (..))+import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore)+import Kiroku.Store.Error (StoreError (..), attributeMultiStreamError, emptyResultError, mapUsageError)+import Kiroku.Store.Observability (KirokuEvent (..))+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Settings (decodeEvents, enrichEvents)+import Kiroku.Store.Types++-- ---------------------------------------------------------------------------+-- Store effect+-- ---------------------------------------------------------------------------++-- | The Store effect — dynamically dispatched, mockable.+data Store :: Effect where+ AppendToStream :: StreamName -> ExpectedVersion -> [EventData] -> Store m AppendResult+ ReadStreamForward :: StreamName -> StreamVersion -> Int32 -> Store m (Vector RecordedEvent)+ ReadStreamBackward :: StreamName -> StreamVersion -> Int32 -> Store m (Vector RecordedEvent)+ ReadAllForward :: GlobalPosition -> Int32 -> Store m (Vector RecordedEvent)+ ReadAllBackward :: GlobalPosition -> Int32 -> Store m (Vector RecordedEvent)+ GetStream :: StreamName -> Store m (Maybe StreamInfo)+ {- | Resolve a 'StreamName' to its surrogate 'StreamId' without+ materializing the full 'StreamInfo' row. Mirrors 'GetStream'\'s+ soft-delete semantics: returns 'Just' for both live and soft-deleted+ streams, 'Nothing' for hard-deleted or never-created streams.++ Cheaper than 'GetStream' — decodes one @int8@ column instead of five.+ Surfaced as 'Kiroku.Store.Read.lookupStreamId'.+ -}+ LookupStreamId :: StreamName -> Store m (Maybe StreamId)+ {- | Resolve a batch of surrogate 'StreamId's to their 'StreamName's in a+ single round trip. The result 'Map' contains an entry only for ids that+ name an existing stream (live or soft-deleted); hard-deleted or unknown ids+ are absent.++ The primary use is recovering source stream names from the+ 'RecordedEvent.originalStreamId' of events obtained via fan-in reads+ (@$all@, categories, causation/correlation queries, subscriptions): collect+ the distinct ids from a batch and resolve them once, rather than per event.+ Surfaced as 'Kiroku.Store.Read.lookupStreamNames' (and the singular+ 'Kiroku.Store.Read.lookupStreamName').+ -}+ LookupStreamNames :: [StreamId] -> Store m (Map StreamId StreamName)+ LinkToStream :: StreamName -> [EventId] -> Store m LinkResult+ ReadCategoryForward :: CategoryName -> GlobalPosition -> Int32 -> Store m (Vector RecordedEvent)+ AppendMultiStream :: [(StreamName, ExpectedVersion, [EventData])] -> Store m [AppendResult]+ {- | Fetch a set of 'RecordedEvent' rows that match an 'EventFilter'.+ Surfaced to consumers as the smart constructors in+ "Kiroku.Store.Causation": 'Kiroku.Store.Causation.findByCorrelation',+ 'Kiroku.Store.Causation.findCausationDescendants', and+ 'Kiroku.Store.Causation.findCausationAncestors'.++ The filter is a closed sum ('EventFilter'); mock interpreters can+ pattern-match exhaustively.+ -}+ FindEvents :: EventFilter -> Store m (Vector RecordedEvent)+ SoftDeleteStream :: StreamName -> Store m (Maybe StreamId)+ HardDeleteStream :: StreamName -> Store m (Maybe StreamId)+ UndeleteStream :: StreamName -> Store m (Maybe StreamId)+ {- | Run an arbitrary @hasql-transaction@ value in a 'BEGIN'/'COMMIT'+ block on a single pool connection. Escape hatch from the abstract+ 'Store' effect into the underlying SQL world; mock interpreters are+ expected to reject this constructor.+ -}+ RunTransaction :: Tx.Transaction a -> Store m a+ {- | Like 'RunTransaction' but uses+ 'Hasql.Transaction.Sessions.transactionNoRetry' under the hood —+ the body is run exactly once even on PostgreSQL serialization+ conflicts.+ -}+ RunTransactionNoRetry :: Tx.Transaction a -> Store m a++type instance DispatchOf Store = Dynamic++-- ---------------------------------------------------------------------------+-- PostgreSQL interpreter+-- ---------------------------------------------------------------------------++-- | Interpret Store operations against PostgreSQL via hasql-pool.+runStorePool ::+ (IOE :> es, Error StoreError :> es) =>+ KirokuStore ->+ Eff (Store : es) a ->+ Eff es a+runStorePool store = interpret_ $ \case+ AppendToStream (StreamName name) expected events -> do+ rejectReservedApplicationStream name+ events' <- liftIO $ enrichEvents (store ^. #storeSettings) events+ now <- liftIO getCurrentTime+ prepared <- prepareEvents events'+ let params = buildAppendParams name now prepared+ result <- liftIO $ Pool.use (store ^. #pool) $ case expected of+ ExactVersion (StreamVersion v) ->+ Session.statement (params, v) SQL.appendExpectedVersion+ StreamExists ->+ Session.statement params SQL.appendStreamExists+ NoStream ->+ Session.statement params SQL.appendNoStream+ AnyVersion ->+ Session.statement params SQL.appendAnyVersion+ case result of+ Left usageErr ->+ throwError (mapUsageError name expected usageErr)+ Right Nothing ->+ throwError (emptyResultError name expected)+ Right (Just r) ->+ pure r+ ReadStreamForward (StreamName name) (StreamVersion startVer) limit -> do+ evs <-+ usePool (store ^. #pool) $+ Session.statement (name, startVer, limit) SQL.readStreamForwardStmt+ liftIO $ decodeEvents (store ^. #storeSettings) evs+ ReadStreamBackward (StreamName name) (StreamVersion startVer) limit -> do+ evs <-+ usePool (store ^. #pool) $+ Session.statement (name, startVer, limit) SQL.readStreamBackwardStmt+ liftIO $ decodeEvents (store ^. #storeSettings) evs+ ReadAllForward (GlobalPosition startPos) limit -> do+ evs <-+ usePool (store ^. #pool) $+ Session.statement (startPos, limit) SQL.readAllForwardStmt+ liftIO $ decodeEvents (store ^. #storeSettings) evs+ ReadAllBackward (GlobalPosition startPos) limit -> do+ evs <-+ usePool (store ^. #pool) $+ Session.statement (startPos, limit) SQL.readAllBackwardStmt+ liftIO $ decodeEvents (store ^. #storeSettings) evs+ GetStream (StreamName name) ->+ usePool (store ^. #pool) $+ Session.statement name SQL.getStreamStmt+ LookupStreamId (StreamName name) ->+ fmap (fmap StreamId) $+ usePool (store ^. #pool) $+ Session.statement name SQL.findStreamIdStmt+ LookupStreamNames sids ->+ fmap+ (Map.fromList . map (\(s, nm) -> (StreamId s, StreamName nm)) . V.toList)+ ( usePool (store ^. #pool) $+ Session.statement [s | StreamId s <- sids] SQL.lookupStreamNamesStmt+ )+ LinkToStream (StreamName name) eventIds -> do+ rejectReservedApplicationStream name+ let uuids = V.fromList [uid | EventId uid <- eventIds]+ result <-+ usePool (store ^. #pool) $+ Session.statement (uuids, name) SQL.linkToStreamStmt+ case result of+ Nothing -> throwError (StreamNotFound (StreamName name))+ Just r -> pure r+ ReadCategoryForward (CategoryName cat) (GlobalPosition startPos) limit -> do+ evs <-+ usePool (store ^. #pool) $+ Session.statement (startPos, cat, limit) SQL.readCategoryForwardStmt+ liftIO $ decodeEvents (store ^. #storeSettings) evs+ AppendMultiStream ops -> do+ case find (\(StreamName name, _, _) -> isReservedApplicationStream name) ops of+ Just (sn, _, _) -> throwError (ReservedStreamName sn)+ Nothing -> pure ()+ now <- liftIO getCurrentTime+ -- Prepare all events for all streams+ preparedOps <-+ mapM+ ( \(sn, ev, evts) -> do+ evts' <- liftIO $ enrichEvents (store ^. #storeSettings) evts+ prepared <- prepareEvents evts'+ pure (sn, ev, prepared)+ )+ ops+ let names = V.fromList [n | (StreamName n, _, _) <- ops]+ let txn = do+ -- Pre-lock the user-named streams in deterministic (stream_id)+ -- order to avoid row-lock deadlocks between concurrent+ -- multi-stream txns touching overlapping streams in different+ -- user orders. See EP-1 F4.+ Tx.statement names SQL.lockStreamsForMultiStmt+ results <-+ mapM+ ( \(StreamName name, expected, prepared) -> do+ let params = buildAppendParams name now prepared+ appendDispatchTx expected params+ )+ preparedOps+ -- If any result is Nothing (version conflict), condemn the transaction+ case any isNothing results of+ True -> Tx.condemn >> pure results+ False -> pure results+ result <-+ liftIO $+ Pool.use (store ^. #pool) $+ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write txn+ case result of+ Left usageErr ->+ throwError (attributeMultiStreamError [(sn, ev) | (sn, ev, _) <- ops] usageErr)+ Right results -> do+ -- Check for any Nothing results (version conflicts)+ let indexed = zip ops results+ mapM+ ( \((StreamName sn, ev, _), mResult) ->+ case mResult of+ Nothing -> throwError (emptyResultError sn ev)+ Just r -> pure r+ )+ indexed+ FindEvents filt -> do+ evs <- case filt of+ FilterCorrelation cid ->+ usePool (store ^. #pool) $+ Session.statement cid SQL.findByCorrelationStmt+ FilterCausationDescendants (EventId eid) ->+ usePool (store ^. #pool) $+ Session.statement eid SQL.findCausationDescendantsStmt+ FilterCausationAncestors (EventId eid) ->+ usePool (store ^. #pool) $+ Session.statement eid SQL.findCausationAncestorsStmt+ liftIO $ decodeEvents (store ^. #storeSettings) evs+ SoftDeleteStream (StreamName name) -> do+ rejectReservedApplicationStream name+ usePool (store ^. #pool) $+ Session.statement name SQL.softDeleteStreamStmt+ HardDeleteStream (StreamName name) -> do+ rejectReservedApplicationStream name+ let txn = do+ Tx.sql "SET LOCAL kiroku.enable_hard_deletes = 'on'"+ mSid <- Tx.statement name SQL.findStreamIdStmt+ case mSid of+ Nothing -> pure Nothing+ Just sid -> do+ affected <- Tx.statement sid SQL.deleteStreamJunctionsStmt+ Tx.statement affected SQL.deleteOrphanedEventsStmt+ Tx.statement sid SQL.deleteStreamRowStmt+ pure (Just (StreamId sid))+ result <-+ usePool (store ^. #pool) $+ TxSessions.transaction TxSessions.ReadCommitted TxSessions.Write txn+ -- Emit a fail-safe audit signal when the delete actually removed+ -- rows. Compliance-grade audit should still record an+ -- application-level event before calling hardDeleteStream — see+ -- docs/PRODUCTION-DEPLOYMENT.md.+ case result of+ Just sid -> liftIO $ for_ (store ^. #eventHandler) ($ KirokuEventHardDeleteIssued (StreamName name) sid)+ Nothing -> pure ()+ pure result+ UndeleteStream (StreamName name) -> do+ rejectReservedApplicationStream name+ usePool (store ^. #pool) $+ Session.statement name SQL.undeleteStreamStmt+ RunTransaction tx ->+ runTxOnPool (store ^. #pool) TxSessions.transaction tx+ RunTransactionNoRetry tx ->+ runTxOnPool (store ^. #pool) TxSessions.transactionNoRetry tx++-- | Convenience: run a Store computation to IO.+runStoreIO ::+ KirokuStore ->+ Eff '[Store, Error StoreError, IOE] a ->+ IO (Either StoreError a)+runStoreIO store = runEff . runErrorNoCallStack . runStorePool store++-- | Interpret Store by reading the store handle from 'KirokuStoreResource'.+runStoreResource ::+ (IOE :> es, Error StoreError :> es, KirokuStoreResource :> es) =>+ Eff (Store : es) a ->+ Eff es a+runStoreResource action = do+ store <- getKirokuStore+ runStorePool store action++-- ---------------------------------------------------------------------------+-- Internal pool helper+-- ---------------------------------------------------------------------------++-- | Run a hasql session against the pool, mapping pool errors to 'StoreError'.+usePool ::+ (IOE :> es, Error StoreError :> es) =>+ Pool ->+ Session.Session a ->+ Eff es a+usePool pool session = do+ result <- liftIO (Pool.use pool session)+ case result of+ Left usageErr -> throwError (ConnectionError (T.pack (show usageErr)))+ Right a -> pure a++{- | Run a 'Tx.Transaction' against the pool using the supplied entry+point ('TxSessions.transaction' or 'TxSessions.transactionNoRetry'),+mapping pool errors to 'StoreError'. The isolation level and access+mode mirror 'appendMultiStream' / 'HardDeleteStream'.+-}+runTxOnPool ::+ (IOE :> es, Error StoreError :> es) =>+ Pool ->+ (TxSessions.IsolationLevel -> TxSessions.Mode -> Tx.Transaction a -> Session.Session a) ->+ Tx.Transaction a ->+ Eff es a+runTxOnPool pool entry tx = do+ result <-+ liftIO $+ Pool.use pool $+ entry TxSessions.ReadCommitted TxSessions.Write tx+ case result of+ Left usageErr -> throwError (ConnectionError (T.pack (show usageErr)))+ Right a -> pure a++-- | The seeded $all row is the global read stream, not an application stream.+isReservedApplicationStream :: Text -> Bool+isReservedApplicationStream = (== "$all")++rejectReservedApplicationStream ::+ (Error StoreError :> es) =>+ Text ->+ Eff es ()+rejectReservedApplicationStream name+ | isReservedApplicationStream name = throwError (ReservedStreamName (StreamName name))+ | otherwise = pure ()++-- ---------------------------------------------------------------------------+-- Internal helpers (moved from Append)+-- ---------------------------------------------------------------------------++-- | An event with a guaranteed event ID (pre-generated if needed).+data PreparedEvent = PreparedEvent+ { peEventId :: !UUID+ , peEventType :: !EventType+ , pePayload :: !Value+ , peMetadata :: !(Maybe Value)+ , peCausationId :: !(Maybe UUID)+ , peCorrelationId :: !(Maybe UUID)+ }+ deriving stock (Generic)++{- | Prepare events by generating UUIDv7s for any event that doesn't+have a caller-supplied event ID.+-}+prepareEvents :: (MonadIO m) => [EventData] -> m [PreparedEvent]+prepareEvents evts = liftIO $ do+ let needCount = length (filter (\(EventData eid _ _ _ _ _) -> isNothing eid) evts)+ newIds <-+ if needCount > 0+ then V7.genUUIDs (fromIntegral needCount)+ else pure []+ pure (assign evts newIds)+ where+ assign :: [EventData] -> [UUID] -> [PreparedEvent]+ assign [] _ = []+ assign (EventData mEid eType ePayload eMeta eCaus eCorr : es) ids =+ case mEid of+ Just (EventId uid) ->+ PreparedEvent uid eType ePayload eMeta eCaus eCorr+ : assign es ids+ Nothing -> case ids of+ (uid : rest) ->+ PreparedEvent uid eType ePayload eMeta eCaus eCorr+ : assign es rest+ [] -> error "prepareEvents: ran out of pre-generated UUIDs (bug)"++-- | Build SQL parameters from prepared events.+buildAppendParams :: Text -> UTCTime -> [PreparedEvent] -> SQL.AppendParams+buildAppendParams name now prepared =+ SQL.AppendParams+ { eventIds = V.fromList (map (^. #peEventId) prepared)+ , eventTypes = V.fromList (map (\e -> let EventType t = e ^. #peEventType in t) prepared)+ , causationIds = V.fromList (map (^. #peCausationId) prepared)+ , correlationIds = V.fromList (map (^. #peCorrelationId) prepared)+ , payloads = V.fromList (map (^. #pePayload) prepared)+ , metadatas = V.fromList (map (^. #peMetadata) prepared)+ , createdAts = V.fromList (replicate (length prepared) now)+ , streamName = name+ }++{- | Dispatch the four 'SQL.append*' statements through 'Tx.statement',+selecting the right one based on the supplied 'ExpectedVersion'.++This is the shared building block used by 'AppendMultiStream'\'s+interpreter branch and by 'Kiroku.Store.Transaction.appendToStreamTx'.+'AppendToStream' keeps its 'Session.statement'-flavored dispatch — see+the M2 entry in the Decision Log on plan 11 for why a 'Tx.Transaction'+wrapping a single statement was rejected as a refactoring target.++@'Nothing'@ comes back when the underlying CTE returns 0 rows — i.e.+the precondition failed silently. Callers map that to either+'Kiroku.Store.Error.AppendConflict' (the Tx surface) or+'Kiroku.Store.Error.StoreError' (the @Eff@ surface).+-}+appendDispatchTx :: ExpectedVersion -> SQL.AppendParams -> Tx.Transaction (Maybe AppendResult)+appendDispatchTx expected params = case expected of+ ExactVersion (StreamVersion v) ->+ Tx.statement (params, v) SQL.appendExpectedVersion+ StreamExists ->+ Tx.statement params SQL.appendStreamExists+ NoStream ->+ Tx.statement params SQL.appendNoStream+ AnyVersion ->+ Tx.statement params SQL.appendAnyVersion++{- $internal+These bindings are intentionally exposed so that+"Kiroku.Store.Transaction" can compose appends with arbitrary+'Tx.Transaction' work without re-implementing UUID prep, parameter+packing, or per-version dispatch. They are not part of the supported+public surface and may change without notice.+-}
+ src/Kiroku/Store/Effect/Resource.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TypeFamilies #-}++module Kiroku.Store.Effect.Resource (+ -- * The KirokuStoreResource effect+ KirokuStoreResource,++ -- * Operations+ getKirokuStore,++ -- * Bracket-style runner+ withKirokuStore,+) where++import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, UnliftStrategy (..), withEffToIO, (:>))+import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, getStaticRep)+import Kiroku.Store.Connection (ConnectionSettings, KirokuStore, withStore)++-- ---------------------------------------------------------------------------+-- KirokuStoreResource static effect+-- ---------------------------------------------------------------------------++{- | Static effect carrying a 'KirokuStore' handle.++Static rather than dynamic because the store handle is acquired exactly+once per program and is not meant to be mocked — the dynamic mocking+surface lives on the 'Kiroku.Store.Effect.Store' effect that operates+against the handle. Splitting the resource (static) from the operations+(dynamic) keeps mocking ergonomic without requiring callers to swap the+handle itself.++@Static WithSideEffects@ rather than @Static NoSideEffects@ because the+underlying connection pool performs IO during operation lookup.+-}+data KirokuStoreResource :: Effect++type instance DispatchOf KirokuStoreResource = Static WithSideEffects++newtype instance StaticRep KirokuStoreResource = KirokuStoreResource KirokuStore++-- | Retrieve the 'KirokuStore' handle from the effect stack.+getKirokuStore :: (KirokuStoreResource :> es) => Eff es KirokuStore+getKirokuStore = do+ KirokuStoreResource store <- getStaticRep+ pure store++-- | Bracket-style runner: acquire the store, install the effect, run the action, release.+withKirokuStore ::+ (IOE :> es) =>+ ConnectionSettings ->+ Eff (KirokuStoreResource : es) a ->+ Eff es a+withKirokuStore settings action = withEffToIO SeqUnlift $ \unlift ->+ withStore settings $ \store ->+ unlift (evalStaticRep (KirokuStoreResource store) action)
+ src/Kiroku/Store/Error.hs view
@@ -0,0 +1,347 @@+module Kiroku.Store.Error (+ StoreError (..),++ -- * Append-precondition conflicts (Tx-flavored)+ AppendConflict (..),+ appendConflictToStoreError,+ emptyResultConflict,+ -- Internal helpers used by Effect module+ mapUsageError,+ emptyResultError,+ attributeMultiStreamError,+ -- Internal pure helper exposed for unit testing+ extractStreamNameFromDetail,+) where++import Control.Exception (Exception)+import Data.Text (Text)+import Data.Text qualified as T+import Data.UUID (UUID)+import Data.UUID qualified as UUID+import GHC.Generics (Generic)+import Hasql.Errors qualified as Errors+import Hasql.Pool (UsageError (..))+import Kiroku.Store.Types++{- | Errors that can occur during store operations.++The constructor set is designed for additive evolution: new failure modes+are added rather than changing existing constructors. Pattern matches that+do not handle a new constructor will surface as @-Wincomplete-patterns@+warnings, never as silent misclassification.++The 'ConnectionError' catch-all is retained for backward compatibility:+anything not matched by a more specific constructor falls through to it.+Consumers should match on the specific constructors first when they want+to make retry-vs-escalate decisions.++'StoreError' derives 'Exception' so it can be thrown with 'throwIO' from+any 'IO' or 'MonadIO' context. The standard pattern for store callers+remains @runStoreIO :: IO (Either StoreError a)@; the 'Exception' instance+is for callers who prefer the exception-based idiom (e.g., when bridging+to libraries that expect 'SomeException').+-}+data StoreError+ = {- | The actual stream version did not match the caller's+ 'ExactVersion' expectation. The third field is the actual+ version (or 'StreamVersion' 0 when the version could not be+ recovered, e.g., the row was concurrently soft-deleted).+ -}+ WrongExpectedVersion !StreamName !ExpectedVersion !StreamVersion+ | -- | The named stream does not exist (or has been soft-deleted).+ StreamNotFound !StreamName+ | {- | The named stream is reserved for store internals and cannot be+ used as an application stream target. For now this applies only+ to @$all@, which is the global read stream backed by the seeded+ @streams.stream_id = 0@ row.+ -}+ ReservedStreamName !StreamName+ | {- | The named stream already exists. Returned for 'NoStream'+ expectations against an existing stream and for 'linkToStream'+ targets that already exist with conflicting state.+ -}+ StreamAlreadyExists !StreamName+ | {- | A caller-supplied @event_id@ collides with an existing event.++ The constructor carries 'Just' the id when the PostgreSQL detail+ string could be parsed, 'Nothing' otherwise. A 'Nothing' payload+ is rare in practice; it occurs when the server's locale changes+ the detail-string format. Consumers that want to surface the+ offending id to the user should match on 'Just'.+ -}+ DuplicateEvent !(Maybe EventId)+ | {- | The connection pool timed out acquiring a connection. Almost+ always retryable after a small backoff; sustained timeouts+ indicate that the pool is undersized for the offered load or+ that the database is unreachable.+ -}+ PoolAcquisitionTimeout+ | {- | A network or session-level error tore down the connection+ mid-operation. The 'Text' carries the underlying hasql error+ description for diagnostics. Retryable in most cases.+ -}+ ConnectionLost !Text+ | {- | PostgreSQL raised a server error whose @SQLSTATE@ code is+ outside the set this store recognises (currently @23505@+ unique violation and @23503@ foreign key violation). The first+ 'Text' is the @SQLSTATE@ code, the second is the human-readable+ message. This is *not* generally retryable — investigate.+ -}+ UnexpectedServerError !Text !Text+ | {- | Catch-all for everything not matched by a more specific+ constructor above. Retained for backward compatibility with+ consumers that already pattern-match on it; new code should+ prefer the specific constructors.+ -}+ ConnectionError !Text+ deriving stock (Eq, Show, Generic)+ deriving anyclass (Exception)++{- | Map a hasql 'UsageError' to a 'StoreError'.++Pattern matches on the error hierarchy:+ UsageError -> SessionUsageError -> StatementSessionError -> ServerStatementError -> ServerError++PostgreSQL error code mapping:+ 23505 (unique_violation) + events_pkey -> 'DuplicateEvent'+ 23505 (unique_violation) + ix_streams_stream_name -> 'StreamAlreadyExists'+ 23505 (unique_violation) + other -> 'WrongExpectedVersion'+ 23503 (foreign_key_violation) -> 'StreamNotFound'+ any other server code -> 'UnexpectedServerError'++The constraint-name matching depends on the literal strings @events_pkey@+and @ix_streams_stream_name@. If a future schema migration renames a+constraint, the @23505@ branch falls through to the generic+'WrongExpectedVersion' mapping; keep the names stable in+@kiroku-store-migrations/sql-migrations@.+-}+mapUsageError :: Text -> ExpectedVersion -> UsageError -> StoreError+mapUsageError streamName expected = \case+ SessionUsageError sessionErr ->+ mapSessionError streamName expected sessionErr+ ConnectionUsageError connErr ->+ ConnectionLost (T.pack (show connErr))+ AcquisitionTimeoutUsageError ->+ PoolAcquisitionTimeout++mapSessionError :: Text -> ExpectedVersion -> Errors.SessionError -> StoreError+mapSessionError streamName expected = \case+ Errors.StatementSessionError _ _ _ _ _ stmtErr ->+ mapStatementError streamName expected stmtErr+ other ->+ ConnectionError ("Session error: " <> T.pack (show other))++mapStatementError :: Text -> ExpectedVersion -> Errors.StatementError -> StoreError+mapStatementError streamName expected = \case+ Errors.ServerStatementError serverErr ->+ mapServerError streamName expected serverErr+ other ->+ ConnectionError ("Statement error: " <> T.pack (show other))++mapServerError :: Text -> ExpectedVersion -> Errors.ServerError -> StoreError+mapServerError streamName expected (Errors.ServerError code message detail _hint _position)+ | code == "23505" = mapUniqueViolation streamName expected message detail+ | code == "23503" = StreamNotFound (StreamName streamName)+ | otherwise = UnexpectedServerError code message++{- | Map a unique_violation (23505) to an StoreError.++PostgreSQL reports constraint violations with:+ - message: "duplicate key value violates unique constraint \"events_pkey\""+ - detail: "Key (event_id)=(uuid-value) already exists."++We check both message and detail for the constraint name.++When the events_pkey case fires but the detail string cannot be parsed+(e.g., the server's locale produced an unexpected format), the+'DuplicateEvent' constructor carries 'Nothing' rather than a fabricated+all-zeroes UUID — see 'extractEventId'.+-}+mapUniqueViolation :: Text -> ExpectedVersion -> Text -> Maybe Text -> StoreError+mapUniqueViolation streamName expected message detail+ | containsConstraint "events_pkey" = DuplicateEvent (extractEventId detail)+ | containsConstraint "ix_streams_stream_name" = StreamAlreadyExists (StreamName streamName)+ | otherwise =+ -- Generic unique violation — treat as version conflict+ WrongExpectedVersion (StreamName streamName) expected (StreamVersion 0)+ where+ containsConstraint name =+ name `T.isInfixOf` message || maybe False (T.isInfixOf name) detail++ -- Try to extract event_id from detail like "Key (event_id)=(uuid) already exists."+ extractEventId (Just d) = EventId <$> extractUuidFromDetail d+ extractEventId Nothing = Nothing++{- | Append-precondition failures observable inside a+'Hasql.Transaction.Transaction' body.++'Kiroku.Store.Transaction.appendToStreamTx' returns+@'Either' 'AppendConflict' 'AppendResult'@ rather than throwing, because+'Hasql.Transaction.Transaction' has no exception channel — the caller+decides whether to call 'Hasql.Transaction.condemn', branch around the+conflict, or recover. Reserved-stream rejection is /not/ part of this+sum because callers of 'Kiroku.Store.Transaction.appendToStreamTx' are+expected to validate the stream name themselves before entering the+transaction body (the high-level wrapper+'Kiroku.Store.Transaction.runTransactionAppending' does so prior to+opening the transaction and surfaces 'ReservedStreamName' as a+'StoreError' instead).++The constructors are 1:1 with the corresponding 'StoreError' variants —+see 'appendConflictToStoreError'.+-}+data AppendConflict+ = {- | Mirror of 'WrongExpectedVersion'. The third field is the+ actual stream version, or @StreamVersion 0@ when it could not+ be recovered (e.g., the CTE returned no rows because the+ target was concurrently soft-deleted).+ -}+ WrongExpectedVersionConflict !StreamName !ExpectedVersion !StreamVersion+ | -- | Mirror of 'StreamNotFound'.+ StreamNotFoundConflict !StreamName+ | -- | Mirror of 'StreamAlreadyExists'.+ StreamAlreadyExistsConflict !StreamName+ deriving stock (Eq, Show, Generic)++{- | Project an 'AppendConflict' onto the corresponding 'StoreError'+constructor. Used by 'Kiroku.Store.Transaction.runTransactionAppending'+when surfacing conflicts at the @Eff@ boundary.+-}+appendConflictToStoreError :: AppendConflict -> StoreError+appendConflictToStoreError = \case+ WrongExpectedVersionConflict sn ev sv -> WrongExpectedVersion sn ev sv+ StreamNotFoundConflict sn -> StreamNotFound sn+ StreamAlreadyExistsConflict sn -> StreamAlreadyExists sn++{- | Infer the appropriate 'AppendConflict' from an empty CTE result.++Mirror of 'emptyResultError' for the 'AppendConflict' surface. When the+CTE returns 0 rows, the version check or existence check failed+silently — the constructor depends on the supplied 'ExpectedVersion':++ ExactVersion v -> WrongExpectedVersionConflict (version mismatch or+ soft-deleted)+ StreamExists -> StreamNotFoundConflict (missing or soft-deleted)+ NoStream -> StreamAlreadyExistsConflict+ AnyVersion -> StreamNotFoundConflict (only happens when the+ existing row is soft-deleted and the upsert's DO+ UPDATE WHERE filter rejects it)+-}+emptyResultConflict :: StreamName -> ExpectedVersion -> AppendConflict+emptyResultConflict sn = \case+ ExactVersion v ->+ WrongExpectedVersionConflict sn (ExactVersion v) (StreamVersion 0)+ StreamExists ->+ StreamNotFoundConflict sn+ NoStream ->+ StreamAlreadyExistsConflict sn+ AnyVersion ->+ StreamNotFoundConflict sn++{- | Infer the appropriate error from an empty CTE result.++When the CTE returns 0 rows (no ServerError raised), the version check+or existence check failed silently. Map based on the ExpectedVersion:+ ExactVersion v -> WrongExpectedVersion (version mismatch, or soft-deleted)+ StreamExists -> StreamNotFound (stream doesn't exist, or soft-deleted)+ NoStream -> StreamAlreadyExists (stream already exists)+ AnyVersion -> StreamNotFound (only happens when the existing row is+ soft-deleted and the upsert's DO UPDATE WHERE filter+ rejects it; the soft-delete CTE filter was added in+ EP-1 F2, so this branch is the soft-deleted-stream case)+-}+emptyResultError :: Text -> ExpectedVersion -> StoreError+emptyResultError streamName expected =+ appendConflictToStoreError+ (emptyResultConflict (StreamName streamName) expected)++{- | Extract a UUID from a PostgreSQL detail string like:+"Key (event_id)=(01234567-89ab-7def-8012-34567890abcd) already exists."+-}+extractUuidFromDetail :: Text -> Maybe UUID+extractUuidFromDetail detail =+ case T.breakOn "=(" detail of+ (_, rest)+ | not (T.null rest) ->+ let afterParen = T.drop 2 rest -- skip "=("+ uuidText = T.takeWhile (/= ')') afterParen+ in UUID.fromText uuidText+ _ -> Nothing++{- | Extract a stream name from a PostgreSQL unique-violation detail string+like @"Key (stream_name)=(orders-1) already exists."@.++Returns @Nothing@ when the format is unrecognized — most commonly because+the server emitted a non-English locale variant or because a future schema+change altered the constraint's column. Callers should use a sensible+fallback (e.g., the first stream in a multi-stream operation) rather than+treat 'Nothing' as a fatal condition.+-}+extractStreamNameFromDetail :: Text -> Maybe Text+extractStreamNameFromDetail detail =+ case T.breakOn "=(" detail of+ (_, rest)+ | not (T.null rest) ->+ let afterParen = T.drop 2 rest -- skip "=("+ inner = T.takeWhile (/= ')') afterParen+ in if T.null inner then Nothing else Just inner+ _ -> Nothing++{- | For 'appendMultiStream' errors, recover the offending stream from the+PostgreSQL detail string when possible.++The multi-stream interpreter's transaction returns a single+@Either UsageError result@; per-statement attribution is not visible at the+@hasql@ layer. When the failure is a @23505@ unique violation on+@ix_streams_stream_name@, the PostgreSQL detail string carries the+offending stream name (e.g., @"Key (stream_name)=(multi-c) already exists."@)+and we look up the matching op to recover its 'ExpectedVersion'.++When the detail cannot be parsed (any other failure mode, including+@events_pkey@ violations whose 'DuplicateEvent' constructor carries no+stream attribution, generic server errors, and connection errors), we fall+back to attributing against the first stream in the input list and let+'mapUsageError' map the rest.++This is defensive — the current SQL paths in @kiroku-store/src/Kiroku/Store/SQL.hs@+do not raise @ix_streams_stream_name@ violations because every append CTE+uses @ON CONFLICT DO NOTHING@/@DO UPDATE@ — but a future schema change could+introduce a path that does, and the attribution should be correct from day+one.+-}+attributeMultiStreamError ::+ {- | The (name, expected) pairs from the multi-stream ops, in the order+ the caller supplied them.+ -}+ [(StreamName, ExpectedVersion)] ->+ UsageError ->+ StoreError+attributeMultiStreamError [] usageErr =+ -- Defensive: an empty multi-stream call should not reach the+ -- transaction layer, but if it somehow does, surface the raw error.+ ConnectionError ("Empty multi-stream usage error: " <> T.pack (show usageErr))+attributeMultiStreamError ops@((StreamName firstName, firstExpected) : _) usageErr =+ case extractServerError usageErr of+ Just (Errors.ServerError "23505" message (Just detail) _ _)+ | "ix_streams_stream_name" `T.isInfixOf` message+ || "ix_streams_stream_name" `T.isInfixOf` detail+ , Just sn <- extractStreamNameFromDetail detail+ , Just (StreamName name, expected) <- lookupStream sn ops ->+ mapUsageError name expected usageErr+ _ ->+ mapUsageError firstName firstExpected usageErr+ where+ lookupStream tgt = lookup' tgt+ lookup' _ [] = Nothing+ lookup' tgt (op@(StreamName n, _) : rest)+ | n == tgt = Just op+ | otherwise = lookup' tgt rest++-- | Walk a 'UsageError' down to the underlying 'Errors.ServerError', if any.+extractServerError :: UsageError -> Maybe Errors.ServerError+extractServerError = \case+ SessionUsageError (Errors.StatementSessionError _ _ _ _ _ stmtErr) ->+ case stmtErr of+ Errors.ServerStatementError serverErr -> Just serverErr+ _ -> Nothing+ _ -> Nothing
+ src/Kiroku/Store/Lifecycle.hs view
@@ -0,0 +1,110 @@+module Kiroku.Store.Lifecycle (+ softDeleteStream,+ hardDeleteStream,+ undeleteStream,+) where++import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Kiroku.Store.Effect (Store (..))+import Kiroku.Store.Types++{- | Mark a stream as deleted without removing its rows.++Soft-deleted streams are invisible to 'Kiroku.Store.Read.readStreamForward'+(returns empty), to 'Kiroku.Store.Read.readStreamBackward', and to+'Kiroku.Store.Append.appendToStream' (returns+'Kiroku.Store.Error.StreamNotFound' or+'Kiroku.Store.Error.StreamAlreadyExists' depending on+'Kiroku.Store.Types.ExpectedVersion'). They remain visible in the+@$all@ stream — the global event log is append-only — and to+'Kiroku.Store.Read.readCategory'. Use 'undeleteStream' to restore.++The exact stream name @$all@ is reserved for the global read stream.+Lifecycle operations reject it with+'Kiroku.Store.Error.ReservedStreamName' so callers cannot hide, remove,+or restore the internal global stream row.++Returns @Just streamId@ on success, or @Nothing@ if the stream did not+exist or was already soft-deleted. Reverse with 'undeleteStream' or+'hardDeleteStream'.+-}+softDeleteStream ::+ (HasCallStack, Store :> es) =>+ StreamName ->+ Eff es (Maybe StreamId)+softDeleteStream name = send (SoftDeleteStream name)++{- | Permanently remove a stream, its events (where they are not+referenced by other streams), and its links.++== Authorization model++Hard delete is gated by a session-local PostgreSQL GUC+(@kiroku.enable_hard_deletes@) that the interpreter sets inside its+transaction. Direct @DELETE@ or @TRUNCATE@ against the underlying+tables without setting that GUC raises an exception via the+@protect_deletion@ and @protect_truncation@ triggers in+@kiroku-store-migrations/sql-migrations@.++/The GUC is an advisory protection, not a security boundary./ Any+PostgreSQL session with @DELETE@ privilege on @events@,+@stream_events@, and @streams@ can issue @SET LOCAL+kiroku.enable_hard_deletes = \'on\'@ before its own @DELETE@ —+PostgreSQL grants @SET LOCAL@ to every session. The trigger exists+to make accidental issuance of @DELETE@ (a typo, an ad-hoc operator+query, an ORM that does not know the table is meant to be+append-only) fail loudly rather than to enforce role-based access+control.++In practice the model is "applications running with full @DELETE@+privilege on the data tables are trusted to call hard-delete+correctly". Production deployments that need stricter control should:++* Run the application as a low-privileged role with only @INSERT,+ UPDATE, SELECT@ on the data tables (not @DELETE@); soft-delete+ via 'softDeleteStream' is unaffected. Issue hard-deletes from a+ separate, more privileged role gated by your own access controls.++* /Or/ wrap calls to 'hardDeleteStream' in your application's+ authorization layer before they reach this function. Reading the+ @protect_deletion@ trigger as a security boundary is incorrect.++== Event preservation semantics++The interpreter cleans up junction rows ('stream_events') first,+then deletes orphaned 'events' rows — events still linked to other+streams from this one's hard-deleted source junctions are removed;+events linked to streams /not/ owned by this deletion are preserved.++== Result++Returns @Just streamId@ on success, @Nothing@ if the stream did not+exist. The exact stream name @$all@ is rejected with+'Kiroku.Store.Error.ReservedStreamName'. There is no \"undo\" — for reversible deletes use+'softDeleteStream' instead. The deletion emits no in-band audit row;+operators relying on an audit log must capture hard-deletes through+the connection-pool observation handler (see+'Kiroku.Store.Connection.ConnectionSettings.observationHandler') or+record an application-level event /before/ calling this function.+-}+hardDeleteStream ::+ (HasCallStack, Store :> es) =>+ StreamName ->+ Eff es (Maybe StreamId)+hardDeleteStream name = send (HardDeleteStream name)++{- | Restore a soft-deleted stream by clearing its @deleted_at@ row.++Reads of the restored stream return its full event history. Subsequent+appends behave as if the soft-delete never happened. Returns+@Just streamId@ on success, @Nothing@ if the stream is missing or was+not soft-deleted (already live). The exact stream name @$all@ is+rejected with 'Kiroku.Store.Error.ReservedStreamName'.+-}+undeleteStream ::+ (HasCallStack, Store :> es) =>+ StreamName ->+ Eff es (Maybe StreamId)+undeleteStream name = send (UndeleteStream name)
+ src/Kiroku/Store/Link.hs view
@@ -0,0 +1,47 @@+module Kiroku.Store.Link (+ linkToStream,+) where++import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Kiroku.Store.Effect (Store (..))+import Kiroku.Store.Types++{- | Link existing events into a target stream.++Creates the target stream if it does not exist; otherwise appends+links to the existing target. Linking does not duplicate the event+payload — the @events@ row is shared, and only a new junction row in+@stream_events@ is created. Linked events keep their original+'Kiroku.Store.Types.GlobalPosition' and 'Kiroku.Store.Types.RecordedEvent.originalStreamId' /+'originalVersion' fields; the target's 'Kiroku.Store.Types.RecordedEvent.streamVersion'+reflects the link's position in the target.++Preconditions:++* Every supplied 'Kiroku.Store.Types.EventId' must reference an event+ that currently exists. Linking an unknown id (a typo, or an id that+ was hard-deleted) rejects the entire batch atomically — the target+ stream is left in its pre-call state. (See EP-1 F3.)+* The target must not be soft-deleted. Linking to a soft-deleted target+ fails with 'Kiroku.Store.Error.StreamNotFound'. (See EP-1 F5.)+* The target must not be @$all@. @$all@ is the global read stream, and+ linking into it would bypass the append-only global ordering contract;+ the interpreter rejects this with+ 'Kiroku.Store.Error.ReservedStreamName'.+* Linking the same event into the same target stream twice fails with+ a primary-key violation on the junction's @(stream_id, event_id)@+ uniqueness.++Returns the target's 'Kiroku.Store.Types.LinkResult' — its id and the+position of the /last/ linked event in the target.++Empty input @[]@ is a no-op programming mistake; do not call.+-}+linkToStream ::+ (HasCallStack, Store :> es) =>+ StreamName ->+ [EventId] ->+ Eff es LinkResult+linkToStream targetStream eventIds = send (LinkToStream targetStream eventIds)
+ src/Kiroku/Store/Notification.hs view
@@ -0,0 +1,224 @@+module Kiroku.Store.Notification (+ Notifier (..),+ NotifierStartError (..),+ startNotifier,+ stopNotifier,+) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (Async)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.STM (TChan, TVar, atomically, newBroadcastTChanIO, newTVarIO, readTVarIO, writeTChan, writeTVar)+import Control.Exception (Exception, SomeException, asyncExceptionFromException, bracketOnError, catch, throwIO, toException)+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Foldable (for_)+import Data.Text (Text)+import Hasql.Connection (Connection)+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Conn+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Errors (ConnectionError)+import Hasql.Notifications (PgIdentifier, toPgIdentifier, waitForNotifications)+import Hasql.Notifications qualified as Notifications+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, unpreparable)+import Kiroku.Store.Observability (KirokuEvent (..))++{- | A Notifier manages a dedicated PostgreSQL connection for LISTEN/NOTIFY.+It writes a @()@ tick to a broadcast 'TChan' on every notification,+allowing subscribers to wake without polling.++The current connection is held in a 'TVar' so that+'Kiroku.Store.Notification.stopNotifier' releases whichever connection+the listener loop most recently acquired (rather than the original one,+which may have been replaced by reconnection).+-}+data Notifier = Notifier+ { tickChan :: !(TChan ())+ -- ^ Broadcast channel; consumers must use 'dupTChan' to get a personal copy+ , listenerThread :: !(Async ())+ -- ^ The async thread running the LISTEN loop+ , listenerConnRef :: !(TVar Connection)+ {- ^ The /current/ dedicated listener connection. Updated by the loop on+ each successful reconnection so 'stopNotifier' always releases the+ live socket.+ -}+ }++{- | Raised by 'startNotifier' when the initial dedicated @LISTEN@+connection cannot be acquired. Carries @hasql@'s underlying+'Connection.ConnectionError' (often a TCP-level failure or an+authentication error) for diagnostics.++Replaces the prior @IOException@-via-@fail@ shape so callers can pattern+match on a typed startup exception.+-}+newtype NotifierStartError = NotifierStartError ConnectionError+ deriving stock (Show)+ deriving anyclass (Exception)++-- Cap reconnect backoff at 30 seconds; the EventPublisher's safety poll+-- runs at the same cadence, so the worst-case latency between a+-- recovered database and a re-armed subscription is bounded by the safety+-- poll regardless of the backoff. Capping here avoids unnecessary+-- additional latency under sustained outage.+maxReconnectDelayMicros :: Int+maxReconnectDelayMicros = 30_000_000++-- Compute the backoff delay (microseconds) for the @n@-th consecutive+-- failure, @n >= 1@. Schedule: 1s, 2s, 4s, 8s, 16s, 30s, 30s, ...+reconnectDelayMicros :: Int -> Int+reconnectDelayMicros n+ | n <= 0 = 1_000_000+ | otherwise = min maxReconnectDelayMicros (1_000_000 * 2 ^ (min (n - 1) 30))++{- | Start a Notifier. Acquires a dedicated connection, sets+@application_name@ to @kiroku-listener@ for operator visibility, issues+LISTEN on the @\<schema\>.events@ channel, and spawns a thread that+writes @()@ to the broadcast TChan on every notification.++On connection failure during the loop, releases the dead connection,+waits a backoff interval (capped exponential: 1s, 2s, 4s, 8s, 16s, 30s+thereafter), acquires a replacement, re-LISTENs, and resumes. The+replacement is published into 'listenerConnRef' so 'stopNotifier'+releases it on shutdown.++If an 'eventHandler' callback is supplied, the notifier emits+'Kiroku.Store.Observability.KirokuEventNotifierReconnecting' on each+attempted reconnect (with the consecutive failure count and the+underlying exception) and 'KirokuEventNotifierReconnected' on each+successful reconnect. The failure counter resets after a successful+reconnect.++On 'Async.AsyncCancelled' (from cancellation), exits cleanly.++Initial-acquire failure raises 'NotifierStartError'.+-}+startNotifier ::+ (MonadIO m) =>+ -- | libpq connection string+ Text ->+ -- | schema name (used to construct the LISTEN channel)+ Text ->+ -- | optional event handler for reconnect observability+ Maybe (KirokuEvent -> IO ()) ->+ m Notifier+startNotifier connString schema mHandler = liftIO $ do+ chan <- newBroadcastTChanIO+ conn <- acquireOrThrow connString+ let channel = toPgIdentifier (schema <> ".events")+ Notifications.listen conn channel+ connRef <- newTVarIO conn+ thread <- Async.async (listenerLoop chan connRef channel connString mHandler)+ pure+ Notifier+ { tickChan = chan+ , listenerThread = thread+ , listenerConnRef = connRef+ }++{- | Stop the Notifier. Cancels the listener thread, waits for it to+finish, and releases whichever connection the loop is currently holding.+-}+stopNotifier :: (MonadIO m) => Notifier -> m ()+stopNotifier notifier = liftIO $ do+ Async.cancel (listenerThread notifier)+ void $ Async.waitCatch (listenerThread notifier)+ conn <- readTVarIO (listenerConnRef notifier)+ Connection.release conn++-- Internal: the listener loop. Calls 'waitForNotifications' on the current+-- connection; that call blocks indefinitely under normal operation. If it+-- returns (because the underlying 'Hasql.Connection.use' swallowed a session+-- error and produced a 'Left') or throws (because the panic propagated),+-- the loop releases the dead connection and reconnects. On async exceptions+-- it exits without releasing — 'stopNotifier' owns the final release via+-- 'listenerConnRef'.+--+-- The reconnect path takes the underlying 'SomeException' so it can carry it+-- on the 'KirokuEventNotifierReconnecting' event; the wait-returned-without-+-- exception path uses a synthetic message.+listenerLoop ::+ TChan () ->+ TVar Connection ->+ PgIdentifier ->+ Text ->+ Maybe (KirokuEvent -> IO ()) ->+ IO ()+listenerLoop chan connRef channel connStr mHandler = go+ where+ go =+ ( do+ currentConn <- readTVarIO connRef+ waitForNotifications (\_ _ -> atomically (writeTChan chan ())) currentConn+ -- waitForNotifications returns only if the underlying connection+ -- went bad and Hasql converted the error into a Left result; in+ -- that case we must reconnect rather than spin re-invoking the+ -- same dead conn.+ reconnect 1 (toException ListenerWaitReturned)+ )+ `catch` \(e :: SomeException) ->+ case asyncExceptionFromException e of+ Just (_ :: Async.AsyncCancelled) -> pure ()+ Nothing -> reconnect 1 e++ reconnect attempt cause = do+ emit (KirokuEventNotifierReconnecting attempt cause)+ oldConn <- readTVarIO connRef+ Connection.release oldConn+ threadDelay (reconnectDelayMicros attempt)+ -- bracketOnError releases the freshly acquired connection if an+ -- async exception lands between acquire and the TVar write — without+ -- it the new connection would be unreachable from stopNotifier and+ -- would leak.+ result <-+ ( Right+ <$> bracketOnError+ (acquireOrThrow connStr)+ Connection.release+ ( \newConn -> do+ Notifications.listen newConn channel+ atomically (writeTVar connRef newConn)+ )+ )+ `catch` (\(e :: SomeException) -> pure (Left e))+ case result of+ Left e ->+ case asyncExceptionFromException e of+ Just (_ :: Async.AsyncCancelled) -> throwIO e+ Nothing -> reconnect (attempt + 1) e+ Right () -> do+ emit KirokuEventNotifierReconnected+ go++ emit evt = for_ mHandler ($ evt)++-- A synthetic exception used when 'waitForNotifications' returns without+-- raising (hasql-notifications turned a connection error into a Left+-- result and dropped the diagnostic). The reconnect-event payload still+-- needs an exception value — this is it.+data ListenerWaitReturned = ListenerWaitReturned+ deriving stock (Show)+ deriving anyclass (Exception)++-- Internal: acquire a connection, set its application_name, or throw on failure.+-- Throws 'NotifierStartError' (which derives 'Exception') instead of the+-- prior @fail@-based 'IOException', so callers can match on a typed startup+-- exception.+acquireOrThrow :: Text -> IO Connection+acquireOrThrow connStr = do+ result <- Connection.acquire (Conn.connectionString connStr)+ case result of+ Left err -> throwIO (NotifierStartError err)+ Right conn -> do+ -- Tag the connection so operators can identify the listener in+ -- pg_stat_activity. Failures here are non-fatal — fall back to the+ -- default application_name silently rather than aborting startup.+ _ <- Connection.use conn (Session.statement () setAppNameStmt)+ pure conn++setAppNameStmt :: Statement () ()+setAppNameStmt =+ unpreparable "SET application_name = 'kiroku-listener'" E.noParams D.noResult
+ src/Kiroku/Store/Observability.hs view
@@ -0,0 +1,171 @@+{- | Structured operational events emitted by 'Kiroku.Store'.++This module provides the 'KirokuEvent' sum type and its supporting+enumerations. It complements+'Kiroku.Store.Connection.ConnectionSettings.observationHandler' (which+covers @hasql-pool@'s connection-lifecycle events) with events the+package emits itself:++* Notifier reconnection (the dedicated @LISTEN@ connection went bad and+ is being re-established).+* EventPublisher pool errors (the publisher's read query failed and+ will retry on the next tick or 30-second safety poll).+* Per-subscription database errors (checkpoint load, batch fetch,+ checkpoint save).+* Subscription lifecycle (started, caught-up, stopped).+* Hard-delete issuance (a fail-safe audit signal — see+ @docs\/PRODUCTION-DEPLOYMENT.md@ for the recommended in-band audit+ pattern).++Wire 'Kiroku.Store.Connection.ConnectionSettingsM.eventHandler' to a+callback that forwards to your structured logger or metrics pipeline.+The callback runs synchronously on the emit-site thread (notifier loop,+publisher loop, worker loop, store interpreter); slow callbacks therefore+stall those loops. For callbacks that may block, fan out asynchronously+(write to a 'Control.Concurrent.STM.TBQueue' and drain in a separate+thread).++The constructor set is /additive/: new events are added rather than+existing constructors changed. Pattern matches that do not handle a+new constructor will surface as @-Wincomplete-patterns@ warnings, never+as silent regressions.+-}+module Kiroku.Store.Observability (+ KirokuEvent (..),+ SubscriptionDbPhase (..),+ SubscriptionStopReason (..),+ SubscriptionGroupContext (..),+) where++import Control.Exception (SomeException)+import Data.Int (Int32)+import Hasql.Pool (UsageError)+import Kiroku.Store.Subscription.Types (SubscriptionName)+import Kiroku.Store.Types (GlobalPosition, StreamId, StreamName)++{- | A structured operational event emitted by 'Kiroku.Store' itself.++Events are emitted synchronously from the originating thread; consumer+callbacks should be fast or fan out to an asynchronous worker. See the+module Haddock for context.+-}+data KirokuEvent+ = {- | The dedicated @LISTEN@ connection encountered a non-async+ exception and the listener loop is about to attempt reconnection.+ The 'Int' is the consecutive failure count starting at @1@; it+ drives the exponential-backoff delay (capped at 30 seconds) and+ is useful as a metric label for sustained-outage alerting.+ -}+ KirokuEventNotifierReconnecting !Int !SomeException+ | {- | The listener loop successfully re-established the @LISTEN@+ connection. Pairs with the most recent+ 'KirokuEventNotifierReconnecting'; the failure counter resets to+ @0@ on observing this event.+ -}+ KirokuEventNotifierReconnected+ | {- | The 'Kiroku.Store.Subscription.EventPublisher.EventPublisher'+ read query returned a 'UsageError'. The publisher will retry on+ the next notification tick or the 30-second safety poll. Sustained+ emissions indicate either pool exhaustion (the publisher shares+ the application pool) or a persistent server error.+ -}+ KirokuEventPublisherPoolError !UsageError+ | {- | A subscription's worker thread encountered a 'UsageError' in+ the database phase identified by 'SubscriptionDbPhase'. The+ worker continues running with safe defaults (zero checkpoint,+ empty batch, dropped save) — the event is the operator's only+ signal that this happened. The trailing 'SubscriptionGroupContext'+ identifies which consumer-group member (if any) emitted it.+ -}+ KirokuEventSubscriptionDbError !SubscriptionName !SubscriptionDbPhase !UsageError !SubscriptionGroupContext+ | {- | A subscription's worker thread has just started; the worker+ will begin from the recorded 'GlobalPosition' (zero if no+ checkpoint exists or 'KirokuEventSubscriptionDbError' fired in+ the @LoadCheckpoint@ phase). The trailing 'SubscriptionGroupContext'+ identifies which consumer-group member (if any) started.+ -}+ KirokuEventSubscriptionStarted !SubscriptionName !GlobalPosition !SubscriptionGroupContext+ | {- | The subscription has reached the EventPublisher's+ @lastPublished@ position and is switching from catch-up to+ live mode at the indicated 'GlobalPosition'. Fires at most+ once per worker run. The trailing 'SubscriptionGroupContext'+ identifies which consumer-group member (if any) caught up.+ -}+ KirokuEventSubscriptionCaughtUp !SubscriptionName !GlobalPosition !SubscriptionGroupContext+ | {- | The subscription's worker has stopped at the indicated+ 'GlobalPosition'. The 'SubscriptionStopReason' discriminates+ normal completion (handler returned 'Stop') from cancellation,+ overflow, and worker-thread crashes. The trailing+ 'SubscriptionGroupContext' identifies which consumer-group member+ (if any) stopped.+ -}+ KirokuEventSubscriptionStopped !SubscriptionName !GlobalPosition !SubscriptionStopReason !SubscriptionGroupContext+ | {- | A hard-delete transaction completed successfully. Operators+ relying on a fail-safe audit log can capture this event;+ compliance-grade audit should still record an application-level+ event /before/ calling+ 'Kiroku.Store.Lifecycle.hardDeleteStream' (see+ @docs\/PRODUCTION-DEPLOYMENT.md@). Not emitted when the named+ stream did not exist.+ -}+ KirokuEventHardDeleteIssued !StreamName !StreamId+ deriving stock (Show)++-- | Which database phase a 'KirokuEventSubscriptionDbError' fired in.+data SubscriptionDbPhase+ = {- | 'Kiroku.Store.Subscription.Worker' failed to read the saved+ checkpoint at subscription startup. The worker continues with+ 'Kiroku.Store.Types.GlobalPosition' @0@; on a fresh subscription+ this is correct, on an existing subscription it silently+ re-processes events.+ -}+ LoadCheckpoint+ | {- | The worker's catch-up or category-live database fetch+ returned an error. The worker substitutes an empty batch; the+ catch-up loop interprets this as \"no more events\" and may+ prematurely switch to live mode at a stale cursor.+ -}+ FetchBatch+ | {- | The worker's @saveCheckpoint@ statement failed. The+ subscription continues running but the next restart with the+ same name re-processes events the handler has already seen.+ -}+ SaveCheckpoint+ deriving stock (Eq, Show)++-- | Why a subscription's worker thread stopped.+data SubscriptionStopReason+ = {- | The handler returned 'Kiroku.Store.Subscription.Types.Stop'+ for some event. This is the normal completion path. The+ checkpoint is saved at the event the handler returned 'Stop'+ for.+ -}+ StopHandlerRequested+ | {- | The caller invoked 'Kiroku.Store.Subscription.Types.cancel'.+ No checkpoint advance is guaranteed; events in flight at+ cancellation time will replay on the next restart.+ -}+ StopCancelled+ | {- | The publisher marked the subscription overflowed under+ 'Kiroku.Store.Subscription.Types.DropSubscription' and the+ worker surfaced+ 'Kiroku.Store.Subscription.Types.SubscriptionOverflowed'.+ -}+ StopOverflowed+ | {- | The worker thread died from an uncaught exception (typically+ a handler exception). The 'SomeException' carries the cause.+ -}+ StopWorkerCrashed !SomeException+ deriving stock (Show)++{- | Consumer-group context attached to subscription lifecycle events. A plain+(non-grouped) subscription reports 'NonGroup'; a member of a group reports+@GroupMember member size@ so operators can attribute a lifecycle event to a+specific @(member, size)@.+-}+data SubscriptionGroupContext+ = -- | Ordinary, non-grouped subscription.+ NonGroup+ | -- | Member of a group: @GroupMember member size@.+ GroupMember !Int32 !Int32+ deriving stock (Eq, Show)
+ src/Kiroku/Store/Read.hs view
@@ -0,0 +1,209 @@+module Kiroku.Store.Read (+ readStreamForward,+ readStreamForwardStream,+ readStreamBackward,+ readAllForward,+ readAllBackward,+ readCategory,+ getStream,+ lookupStreamId,+ lookupStreamName,+ lookupStreamNames,+) where++import Control.Lens ((^.))+import Data.Generics.Labels ()+import Data.Int (Int32)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Vector (Vector)+import Data.Vector qualified as V+import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Kiroku.Store.Effect (Store (..))+import Kiroku.Store.Types+import Streamly.Data.Stream (Stream)+import Streamly.Data.Stream qualified as Stream++{- | Read events from a named stream in forward (ascending version)+order.++The cursor is exclusive: events with @streamVersion > startVer@ are+returned. To read the entire stream from the beginning, pass+@'StreamVersion' 0@. Returns an empty vector for nonexistent or+soft-deleted streams. The @limit@ caps the batch size; pass a large+value for \"read everything\".+-}+readStreamForward ::+ (HasCallStack, Store :> es) =>+ StreamName ->+ StreamVersion ->+ Int32 ->+ Eff es (Vector RecordedEvent)+readStreamForward name startVer limit = send (ReadStreamForward name startVer limit)++{- | Forward read a single stream as a constant-memory Streamly 'Stream'.++The streaming sibling of 'readStreamForward'. Identical SQL path and identical+error semantics: this function dispatches 'readStreamForward' repeatedly with+the supplied @pageSize@ as the per-call limit, advancing the exclusive+'StreamVersion' cursor across pages until the next call returns an empty+batch.++The exclusive-cursor convention is preserved end-to-end: passing+@'StreamVersion' 0@ reads from the first event in the stream. Empty and+nonexistent streams terminate the stream immediately with zero elements.++The recommended @pageSize@ is @256@. Callers reading very wide events (large+payloads / metadata) should pass a smaller value to keep per-page memory+bounded; callers reading very long streams of small events may pass a larger+value to reduce round-trip count.+-}+readStreamForwardStream ::+ (HasCallStack, Store :> es) =>+ StreamName ->+ StreamVersion ->+ Int32 ->+ Stream (Eff es) RecordedEvent+readStreamForwardStream name startVer pageSize =+ Stream.concatMap (Stream.fromList . V.toList) pages+ where+ pages = Stream.unfoldrM nextPage startVer+ nextPage cursor = do+ events <- readStreamForward name cursor pageSize+ if V.null events+ then pure Nothing+ else+ let lastV = V.last events ^. #streamVersion+ in pure (Just (events, lastV))++{- | Read events from a named stream in backward (descending version)+order.++The cursor is exclusive: events with @streamVersion < startVer@ are+returned (events older than the cursor). To read the entire stream from+the latest event backward, pass @'StreamVersion' 0@ (the SQL treats it+as \"newer than any\"). Returns an empty vector for nonexistent or+soft-deleted streams.+-}+readStreamBackward ::+ (HasCallStack, Store :> es) =>+ StreamName ->+ StreamVersion ->+ Int32 ->+ Eff es (Vector RecordedEvent)+readStreamBackward name startVer limit = send (ReadStreamBackward name startVer limit)++{- | Read events from the global @$all@ stream in forward+('GlobalPosition'-ascending) order.++Cursor exclusive: events with @globalPosition > startPos@ are returned.+@$all@ contains every event ever appended (including events from+soft-deleted streams; they survive in @$all@ even after their owning+stream is hidden). Hard-deleted streams' events do /not/ appear in+@$all@. The seed row at @globalPosition = 0@ is internal and is never+returned.+-}+readAllForward ::+ (HasCallStack, Store :> es) =>+ GlobalPosition ->+ Int32 ->+ Eff es (Vector RecordedEvent)+readAllForward startPos limit = send (ReadAllForward startPos limit)++{- | Read events from the global @$all@ stream in backward+('GlobalPosition'-descending) order.++Cursor exclusive. To start from the most recent event, pass+@'GlobalPosition' 0@ (treated as \"after everything\" by the SQL).+-}+readAllBackward ::+ (HasCallStack, Store :> es) =>+ GlobalPosition ->+ Int32 ->+ Eff es (Vector RecordedEvent)+readAllBackward startPos limit = send (ReadAllBackward startPos limit)++{- | Read events whose source stream's category prefix matches the given+'CategoryName', in 'GlobalPosition' order.++The category is the substring of a 'StreamName' before the first @-@:+@StreamName "orders-1"@ has @CategoryName "orders"@. Linked events+appear at their /source/ position; the category is the source's+category, not the link target's.+-}+readCategory ::+ (HasCallStack, Store :> es) =>+ CategoryName ->+ GlobalPosition ->+ Int32 ->+ Eff es (Vector RecordedEvent)+readCategory cat startPos limit = send (ReadCategoryForward cat startPos limit)++{- | Query stream metadata.++Returns 'Just' for both live and soft-deleted streams (with @deletedAt@+populated). Returns 'Nothing' for hard-deleted streams and streams that+have never been created.+-}+getStream ::+ (HasCallStack, Store :> es) =>+ StreamName ->+ Eff es (Maybe StreamInfo)+getStream name = send (GetStream name)++{- | Look up a stream's surrogate id by name.++Returns 'Just' the 'StreamId' for both live and soft-deleted streams (mirroring+'getStream'\'s soft-delete behavior). Returns 'Nothing' for streams that have+never been created and for streams that have been hard-deleted.++This is a lighter-weight alternative to 'getStream' when the caller only needs+the surrogate id: it decodes one @int8@ column instead of the five columns+that 'StreamInfo' carries. Equivalent to projecting @info ^. #id@ from a+successful 'getStream' result, but cheaper.+-}+lookupStreamId ::+ (HasCallStack, Store :> es) =>+ StreamName ->+ Eff es (Maybe StreamId)+lookupStreamId name = send (LookupStreamId name)++{- | Resolve a batch of surrogate 'StreamId's to their 'StreamName's in a single+round trip, returning a 'Map' that omits any id which does not name an existing+stream (hard-deleted or never created). Live and soft-deleted streams are+included, mirroring 'lookupStreamId'.++This is the inverse of 'lookupStreamId' and the supported way to recover the+human-readable source stream for events obtained from /fan-in/ reads — the+global @$all@ stream, 'readCategory', the "Kiroku.Store.Causation" queries, and+subscriptions — where each 'RecordedEvent' carries only its surrogate+@originalStreamId@. Collect the distinct ids from a batch and resolve them once,+rather than paying a round trip per event:++@+let ids = 'Data.List.nub' (map (^. #originalStreamId) events)+names <- 'lookupStreamNames' ids+-- names '!?' (event '^.' #originalStreamId) :: Maybe StreamName+@++Passing @[]@ returns an empty map without a database round trip's worth of work+(an empty @ANY(ARRAY[])@ matches nothing).+-}+lookupStreamNames ::+ (HasCallStack, Store :> es) =>+ [StreamId] ->+ Eff es (Map StreamId StreamName)+lookupStreamNames sids = send (LookupStreamNames sids)++{- | Resolve a single surrogate 'StreamId' to its 'StreamName', or 'Nothing' if+no such stream exists. A convenience wrapper over 'lookupStreamNames'; prefer+the batch form when resolving the ids of a whole read batch, to avoid one round+trip per id.+-}+lookupStreamName ::+ (HasCallStack, Store :> es) =>+ StreamId ->+ Eff es (Maybe StreamName)+lookupStreamName sid = Map.lookup sid <$> lookupStreamNames [sid]
+ src/Kiroku/Store/SQL.hs view
@@ -0,0 +1,1103 @@+{-# LANGUAGE MultilineStrings #-}++module Kiroku.Store.SQL (+ -- * Append statements+ AppendParams (..),+ appendExpectedVersion,+ appendStreamExists,+ appendNoStream,+ appendAnyVersion,++ -- * Link statements+ linkToStreamStmt,++ -- * Read statements+ readStreamForwardStmt,+ readStreamBackwardStmt,+ readAllForwardStmt,+ readAllBackwardStmt,+ readCategoryForwardStmt,+ getStreamStmt,+ lookupStreamNamesStmt,++ -- * Consumer-group read statements+ readCategoryForwardConsumerGroupStmt,+ readAllForwardConsumerGroupStmt,++ -- * Causation / correlation statements+ findByCorrelationStmt,+ findCausationDescendantsStmt,+ findCausationAncestorsStmt,++ -- * Lifecycle statements+ softDeleteStreamStmt,+ undeleteStreamStmt,++ -- * Hard-delete statements (used in sequence inside one transaction)+ findStreamIdStmt,+ deleteStreamJunctionsStmt,+ deleteOrphanedEventsStmt,+ deleteStreamRowStmt,++ -- * Multi-stream pre-lock (avoids row-lock deadlocks)+ lockStreamsForMultiStmt,++ -- * Checkpoint statements+ getCheckpointStmt,+ saveCheckpointStmt,+ getCheckpointMemberStmt,+ saveCheckpointMemberStmt,+) where++import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5)+import Control.Lens ((^.))+import Data.Aeson (Value)+import Data.Functor.Contravariant ((>$<))+import Data.Generics.Labels ()+import Data.Int (Int32, Int64)+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.UUID (UUID)+import Data.Vector (Vector)+import GHC.Generics (Generic)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Kiroku.Store.Types++-- | Parameters for append CTE variants (the 7 parallel arrays + stream name).+data AppendParams = AppendParams+ { eventIds :: !(Vector UUID)+ , eventTypes :: !(Vector Text)+ , causationIds :: !(Vector (Maybe UUID))+ , correlationIds :: !(Vector (Maybe UUID))+ , payloads :: !(Vector Value)+ , metadatas :: !(Vector (Maybe Value))+ , createdAts :: !(Vector UTCTime)+ , streamName :: !Text+ }+ deriving stock (Show, Generic)++-- | Encoder for the common 8 parameters shared by all append variants.+appendParamsEncoder :: E.Params AppendParams+appendParamsEncoder =+ ((^. #eventIds) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+ <> ((^. #eventTypes) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+ <> ((^. #causationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+ <> ((^. #correlationIds) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.uuid))))+ <> ((^. #payloads) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.jsonb))))+ <> ((^. #metadatas) >$< E.param (E.nonNullable (E.foldableArray (E.nullable E.jsonb))))+ <> ((^. #createdAts) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.timestamptz))))+ <> ((^. #streamName) >$< E.param (E.nonNullable E.text))++-- | Encoder for append_expected_version: base params + expected version (Int64).+appendExpectedEncoder :: E.Params (AppendParams, Int64)+appendExpectedEncoder =+ contrazip2 appendParamsEncoder (E.param (E.nonNullable E.int8))++{- | Decoder for append results: stream_id, stream_version, global_position.+Returns Nothing if the CTE produced 0 rows (version conflict / stream not found).+-}+appendResultDecoder :: D.Result (Maybe AppendResult)+appendResultDecoder =+ D.rowMaybe $+ AppendResult+ <$> (StreamId <$> D.column (D.nonNullable D.int8))+ <*> (StreamVersion <$> D.column (D.nonNullable D.int8))+ <*> (GlobalPosition <$> D.column (D.nonNullable D.int8))++{- | Append with exact expected version (optimistic concurrency).+Returns Nothing if the stream doesn't exist or version doesn't match.+-}+appendExpectedVersion :: Statement (AppendParams, Int64) (Maybe AppendResult)+appendExpectedVersion =+ preparable+ appendExpectedVersionSQL+ appendExpectedEncoder+ appendResultDecoder++{- | Append to an existing stream at any version.+Returns Nothing if the stream doesn't exist.+-}+appendStreamExists :: Statement AppendParams (Maybe AppendResult)+appendStreamExists =+ preparable+ appendStreamExistsSQL+ appendParamsEncoder+ appendResultDecoder++{- | Append to a new stream (must not already exist).+Returns Nothing if the stream already exists.+-}+appendNoStream :: Statement AppendParams (Maybe AppendResult)+appendNoStream =+ preparable+ appendNoStreamSQL+ appendParamsEncoder+ appendResultDecoder++{- | Append to a stream, creating it if it doesn't exist.+Should always return Just (unless duplicate event ID constraint violation).+-}+appendAnyVersion :: Statement AppendParams (Maybe AppendResult)+appendAnyVersion =+ preparable+ appendAnyVersionSQL+ appendParamsEncoder+ appendResultDecoder++-- ---------------------------------------------------------------------------+-- SQL Templates+-- ---------------------------------------------------------------------------++-- | CTE with exact version check: UPDATE streams WHERE stream_version = $9.+appendExpectedVersionSQL :: Text+appendExpectedVersionSQL =+ """+ WITH+ new_events AS (+ SELECT *+ FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+ WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+ ),+ stream_update AS (+ UPDATE streams+ SET stream_version = stream_version + (SELECT count(*) FROM new_events)+ WHERE stream_name = $8+ AND stream_version = $9+ AND deleted_at IS NULL+ RETURNING stream_id, stream_version - (SELECT count(*) FROM new_events) AS initial_version+ ),+ inserted_events AS (+ INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+ SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+ FROM new_events+ WHERE EXISTS (SELECT 1 FROM stream_update)+ ORDER BY idx+ ),+ source_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, su.stream_id, su.initial_version + ne.idx, su.stream_id, su.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN stream_update su+ ),+ all_update AS (+ UPDATE streams+ SET stream_version = stream_version + (SELECT count(*) FROM new_events)+ WHERE stream_id = 0+ AND EXISTS (SELECT 1 FROM stream_update)+ RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+ ),+ all_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN all_update au+ CROSS JOIN stream_update su+ )+ SELECT su.stream_id,+ su.initial_version + (SELECT count(*) FROM new_events),+ au.initial_global_version + (SELECT count(*) FROM new_events)+ FROM stream_update su+ CROSS JOIN all_update au+ """++-- | CTE without version check: UPDATE streams WHERE stream_name = $8 (no $9).+appendStreamExistsSQL :: Text+appendStreamExistsSQL =+ """+ WITH+ new_events AS (+ SELECT *+ FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+ WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+ ),+ stream_update AS (+ UPDATE streams+ SET stream_version = stream_version + (SELECT count(*) FROM new_events)+ WHERE stream_name = $8+ AND deleted_at IS NULL+ RETURNING stream_id, stream_version - (SELECT count(*) FROM new_events) AS initial_version+ ),+ inserted_events AS (+ INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+ SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+ FROM new_events+ WHERE EXISTS (SELECT 1 FROM stream_update)+ ORDER BY idx+ ),+ source_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, su.stream_id, su.initial_version + ne.idx, su.stream_id, su.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN stream_update su+ ),+ all_update AS (+ UPDATE streams+ SET stream_version = stream_version + (SELECT count(*) FROM new_events)+ WHERE stream_id = 0+ AND EXISTS (SELECT 1 FROM stream_update)+ RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+ ),+ all_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN all_update au+ CROSS JOIN stream_update su+ )+ SELECT su.stream_id,+ su.initial_version + (SELECT count(*) FROM new_events),+ au.initial_global_version + (SELECT count(*) FROM new_events)+ FROM stream_update su+ CROSS JOIN all_update au+ """++-- | CTE for new stream creation: INSERT INTO streams ... ON CONFLICT DO NOTHING.+appendNoStreamSQL :: Text+appendNoStreamSQL =+ """+ WITH+ new_events AS (+ SELECT *+ FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+ WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+ ),+ stream_insert AS (+ INSERT INTO streams (stream_name, stream_version)+ VALUES ($8, (SELECT count(*) FROM new_events))+ ON CONFLICT (stream_name) DO NOTHING+ RETURNING stream_id, 0::bigint AS initial_version+ ),+ inserted_events AS (+ INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+ SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+ FROM new_events+ WHERE EXISTS (SELECT 1 FROM stream_insert)+ ORDER BY idx+ ),+ source_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, si.stream_id, si.initial_version + ne.idx, si.stream_id, si.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN stream_insert si+ ),+ all_update AS (+ UPDATE streams+ SET stream_version = stream_version + (SELECT count(*) FROM new_events)+ WHERE stream_id = 0+ AND EXISTS (SELECT 1 FROM stream_insert)+ RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+ ),+ all_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, 0, au.initial_global_version + ne.idx, si.stream_id, si.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN all_update au+ CROSS JOIN stream_insert si+ )+ SELECT si.stream_id,+ si.initial_version + (SELECT count(*) FROM new_events),+ au.initial_global_version + (SELECT count(*) FROM new_events)+ FROM stream_insert si+ CROSS JOIN all_update au+ """++{- | CTE for create-or-append using INSERT ... ON CONFLICT DO UPDATE (upsert).+A plain INSERT + separate UPDATE in the same CTE won't work because+data-modifying CTEs cannot see each other's changes. Instead, we use+a single upsert that both creates the stream and bumps its version atomically.+-}+appendAnyVersionSQL :: Text+appendAnyVersionSQL =+ """+ WITH+ new_events AS (+ SELECT *+ FROM unnest($1::uuid[], $2::text[], $3::uuid[], $4::uuid[], $5::jsonb[], $6::jsonb[], $7::timestamptz[])+ WITH ORDINALITY AS t(event_id, event_type, causation_id, correlation_id, data, metadata, created_at, idx)+ ),+ stream_upsert AS (+ INSERT INTO streams (stream_name, stream_version)+ VALUES ($8, (SELECT count(*) FROM new_events))+ ON CONFLICT (stream_name)+ DO UPDATE SET stream_version = streams.stream_version + (SELECT count(*) FROM new_events)+ WHERE streams.deleted_at IS NULL+ RETURNING stream_id, stream_version - (SELECT count(*) FROM new_events) AS initial_version+ ),+ inserted_events AS (+ INSERT INTO events (event_id, event_type, causation_id, correlation_id, data, metadata, created_at)+ SELECT event_id, event_type, causation_id, correlation_id, data, metadata, created_at+ FROM new_events+ WHERE EXISTS (SELECT 1 FROM stream_upsert)+ ORDER BY idx+ ),+ source_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, su.stream_id, su.initial_version + ne.idx, su.stream_id, su.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN stream_upsert su+ ),+ all_update AS (+ UPDATE streams+ SET stream_version = stream_version + (SELECT count(*) FROM new_events)+ WHERE stream_id = 0+ AND EXISTS (SELECT 1 FROM stream_upsert)+ RETURNING stream_version - (SELECT count(*) FROM new_events) AS initial_global_version+ ),+ all_links AS (+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT ne.event_id, 0, au.initial_global_version + ne.idx, su.stream_id, su.initial_version + ne.idx+ FROM new_events ne+ CROSS JOIN all_update au+ CROSS JOIN stream_upsert su+ )+ SELECT su.stream_id,+ su.initial_version + (SELECT count(*) FROM new_events),+ au.initial_global_version + (SELECT count(*) FROM new_events)+ FROM stream_upsert su+ CROSS JOIN all_update au+ """++-- ---------------------------------------------------------------------------+-- Read Statements+-- ---------------------------------------------------------------------------++-- | Shared decoder for a RecordedEvent row (11 columns).+recordedEventRow :: D.Row RecordedEvent+recordedEventRow =+ RecordedEvent+ <$> (EventId <$> D.column (D.nonNullable D.uuid))+ <*> (EventType <$> D.column (D.nonNullable D.text))+ <*> (StreamVersion <$> D.column (D.nonNullable D.int8))+ <*> (GlobalPosition <$> D.column (D.nonNullable D.int8))+ <*> (StreamId <$> D.column (D.nonNullable D.int8))+ <*> (StreamVersion <$> D.column (D.nonNullable D.int8))+ <*> D.column (D.nonNullable D.jsonb)+ <*> D.column (D.nullable D.jsonb)+ <*> D.column (D.nullable D.uuid)+ <*> D.column (D.nullable D.uuid)+ <*> D.column (D.nonNullable D.timestamptz)++-- | Shared decoder for a StreamInfo row (5 columns).+streamInfoRow :: D.Row StreamInfo+streamInfoRow =+ StreamInfo+ <$> (StreamId <$> D.column (D.nonNullable D.int8))+ <*> (StreamName <$> D.column (D.nonNullable D.text))+ <*> (StreamVersion <$> D.column (D.nonNullable D.int8))+ <*> D.column (D.nonNullable D.timestamptz)+ <*> D.column (D.nullable D.timestamptz)++-- | Encoder for stream read params: (stream_name, start_version, limit).+readStreamEncoder :: E.Params (Text, Int64, Int32)+readStreamEncoder =+ contrazip3+ (E.param (E.nonNullable E.text))+ (E.param (E.nonNullable E.int8))+ (E.param (E.nonNullable E.int4))++-- | Encoder for $all read params: (start_position, limit).+readAllEncoder :: E.Params (Int64, Int32)+readAllEncoder =+ contrazip2+ (E.param (E.nonNullable E.int8))+ (E.param (E.nonNullable E.int4))++-- | Read events from a named stream in forward order.+readStreamForwardStmt :: Statement (Text, Int64, Int32) (Vector RecordedEvent)+readStreamForwardStmt =+ preparable+ readStreamForwardSQL+ readStreamEncoder+ (D.rowVector recordedEventRow)++-- | Read events from a named stream in backward order.+readStreamBackwardStmt :: Statement (Text, Int64, Int32) (Vector RecordedEvent)+readStreamBackwardStmt =+ preparable+ readStreamBackwardSQL+ readStreamEncoder+ (D.rowVector recordedEventRow)++-- | Read events from the global $all stream in forward order.+readAllForwardStmt :: Statement (Int64, Int32) (Vector RecordedEvent)+readAllForwardStmt =+ preparable+ readAllForwardSQL+ readAllEncoder+ (D.rowVector recordedEventRow)++-- | Read events from the global $all stream in backward order.+readAllBackwardStmt :: Statement (Int64, Int32) (Vector RecordedEvent)+readAllBackwardStmt =+ preparable+ readAllBackwardSQL+ readAllEncoder+ (D.rowVector recordedEventRow)++-- | Get stream metadata by name.+getStreamStmt :: Statement Text (Maybe StreamInfo)+getStreamStmt =+ preparable+ getStreamSQL+ (E.param (E.nonNullable E.text))+ (D.rowMaybe streamInfoRow)++-- ---------------------------------------------------------------------------+-- Read SQL Templates+-- ---------------------------------------------------------------------------++{- | Read from a named stream in forward order.+Resolves stream name to ID via subquery, joins stream_events with events,+filters on stream_version > start_version, orders ascending, limits.+For stream reads, global_position is set to 0 (not available without $all join).+-}+readStreamForwardSQL :: Text+readStreamForwardSQL =+ """+ SELECT e.event_id, e.event_type,+ se.stream_version, 0::bigint AS global_position,+ se.original_stream_id, se.original_stream_version,+ e.data, e.metadata, e.causation_id, e.correlation_id,+ e.created_at+ FROM stream_events se+ JOIN events e ON e.event_id = se.event_id+ WHERE se.stream_id = (SELECT stream_id FROM streams WHERE stream_name = $1 AND deleted_at IS NULL)+ AND se.stream_version > $2+ ORDER BY se.stream_version ASC+ LIMIT $3+ """++-- | Read from a named stream in backward order.+readStreamBackwardSQL :: Text+readStreamBackwardSQL =+ """+ SELECT e.event_id, e.event_type,+ se.stream_version, 0::bigint AS global_position,+ se.original_stream_id, se.original_stream_version,+ e.data, e.metadata, e.causation_id, e.correlation_id,+ e.created_at+ FROM stream_events se+ JOIN events e ON e.event_id = se.event_id+ WHERE se.stream_id = (SELECT stream_id FROM streams WHERE stream_name = $1 AND deleted_at IS NULL)+ AND se.stream_version > $2+ ORDER BY se.stream_version DESC+ LIMIT $3+ """++{- | Read from the global $all stream in forward order.+stream_id = 0 is the $all stream. stream_version on $all is the global position.+-}+readAllForwardSQL :: Text+readAllForwardSQL =+ """+ SELECT e.event_id, e.event_type,+ se.stream_version, se.stream_version AS global_position,+ se.original_stream_id, se.original_stream_version,+ e.data, e.metadata, e.causation_id, e.correlation_id,+ e.created_at+ FROM stream_events se+ JOIN events e ON e.event_id = se.event_id+ WHERE se.stream_id = 0+ AND se.stream_version > $1+ ORDER BY se.stream_version ASC+ LIMIT $2+ """++-- | Read from the global $all stream in backward order.+readAllBackwardSQL :: Text+readAllBackwardSQL =+ """+ SELECT e.event_id, e.event_type,+ se.stream_version, se.stream_version AS global_position,+ se.original_stream_id, se.original_stream_version,+ e.data, e.metadata, e.causation_id, e.correlation_id,+ e.created_at+ FROM stream_events se+ JOIN events e ON e.event_id = se.event_id+ WHERE se.stream_id = 0+ AND se.stream_version > $1+ ORDER BY se.stream_version DESC+ LIMIT $2+ """++-- | Get stream metadata by name.+getStreamSQL :: Text+getStreamSQL =+ """+ SELECT stream_id, stream_name, stream_version, created_at, deleted_at+ FROM streams+ WHERE stream_name = $1+ """++-- ---------------------------------------------------------------------------+-- Causation / Correlation Statements+-- ---------------------------------------------------------------------------++{- | Return every event whose @correlation_id@ equals the input, in ascending+@global_position@ order. Uses the @ix_events_correlation_id@ partial index.++The @stream_events se ON se.stream_id = 0@ join resolves each event to its+single row in the global @$all@ stream, which is also where the global+position is materialized as @stream_version@.+-}+findByCorrelationStmt :: Statement UUID (Vector RecordedEvent)+findByCorrelationStmt =+ preparable+ findByCorrelationSQL+ (E.param (E.nonNullable E.uuid))+ (D.rowVector recordedEventRow)++findByCorrelationSQL :: Text+findByCorrelationSQL =+ """+ SELECT e.event_id, e.event_type,+ se.stream_version, se.stream_version AS global_position,+ se.original_stream_id, se.original_stream_version,+ e.data, e.metadata, e.causation_id, e.correlation_id,+ e.created_at+ FROM events e+ JOIN stream_events se+ ON se.event_id = e.event_id AND se.stream_id = 0+ WHERE e.correlation_id = $1+ ORDER BY se.stream_version ASC+ """++{- | Walk the causation graph forward from a seed event, returning the seed+itself and every event whose @causation_id@ chain leads back to it. The+result is ordered by ascending @global_position@.++The recursive CTE follows @causation_id@ links downstream: each child's+@causation_id@ equals a parent's @event_id@. Cost is @O(depth * log n)@+backed by the @ix_events_causation_id@ partial index.+-}+findCausationDescendantsStmt :: Statement UUID (Vector RecordedEvent)+findCausationDescendantsStmt =+ preparable+ findCausationDescendantsSQL+ (E.param (E.nonNullable E.uuid))+ (D.rowVector recordedEventRow)++findCausationDescendantsSQL :: Text+findCausationDescendantsSQL =+ """+ WITH RECURSIVE chain (event_id, depth) AS (+ SELECT event_id, 0+ FROM events+ WHERE event_id = $1+ UNION ALL+ SELECT e.event_id, c.depth + 1+ FROM events e+ JOIN chain c ON e.causation_id = c.event_id+ )+ SELECT e.event_id, e.event_type,+ se.stream_version, se.stream_version AS global_position,+ se.original_stream_id, se.original_stream_version,+ e.data, e.metadata, e.causation_id, e.correlation_id,+ e.created_at+ FROM chain c+ JOIN events e ON e.event_id = c.event_id+ JOIN stream_events se+ ON se.event_id = e.event_id AND se.stream_id = 0+ ORDER BY se.stream_version ASC+ """++{- | Walk the causation graph backward from a seed event, returning the seed+itself and every ancestor reachable via @causation_id@. Result is ordered+by ascending @depth@ (the seed is depth 0, its immediate cause is depth 1,+etc.).++The recursive CTE follows @causation_id@ links upstream: for each row+@current@ already in the working set, its parent is the row of @events@+whose @event_id@ equals @current.causation_id@.+-}+findCausationAncestorsStmt :: Statement UUID (Vector RecordedEvent)+findCausationAncestorsStmt =+ preparable+ findCausationAncestorsSQL+ (E.param (E.nonNullable E.uuid))+ (D.rowVector recordedEventRow)++findCausationAncestorsSQL :: Text+findCausationAncestorsSQL =+ """+ WITH RECURSIVE chain (event_id, depth) AS (+ SELECT event_id, 0+ FROM events+ WHERE event_id = $1+ UNION ALL+ SELECT parent.event_id, c.depth + 1+ FROM events parent+ JOIN events current ON parent.event_id = current.causation_id+ JOIN chain c ON c.event_id = current.event_id+ )+ SELECT e.event_id, e.event_type,+ se.stream_version, se.stream_version AS global_position,+ se.original_stream_id, se.original_stream_version,+ e.data, e.metadata, e.causation_id, e.correlation_id,+ e.created_at+ FROM chain c+ JOIN events e ON e.event_id = c.event_id+ JOIN stream_events se+ ON se.event_id = e.event_id AND se.stream_id = 0+ ORDER BY c.depth ASC+ """++-- ---------------------------------------------------------------------------+-- Link Statements+-- ---------------------------------------------------------------------------++{- | Link existing events into a target stream (upsert semantics).+Returns @Nothing@ when the target stream exists and is soft-deleted (the+@DO UPDATE WHERE streams.deleted_at IS NULL@ filter rejects the upsert,+so the stream_upsert CTE produces no rows). The interpreter maps @Nothing@+to @StreamNotFound@ for symmetry with @appendAnyVersion@'s soft-deleted+behavior added in EP-1 F2.+-}+linkToStreamStmt :: Statement (Vector UUID, Text) (Maybe LinkResult)+linkToStreamStmt =+ preparable+ linkToStreamSQL+ linkEncoder+ linkResultDecoder++linkEncoder :: E.Params (Vector UUID, Text)+linkEncoder =+ contrazip2+ (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+ (E.param (E.nonNullable E.text))++linkResultDecoder :: D.Result (Maybe LinkResult)+linkResultDecoder =+ D.rowMaybe $+ LinkResult+ <$> (StreamId <$> D.column (D.nonNullable D.int8))+ <*> (StreamVersion <$> D.column (D.nonNullable D.int8))++linkToStreamSQL :: Text+linkToStreamSQL =+ """+ WITH+ event_list AS (+ SELECT event_id, idx+ FROM unnest($1::uuid[]) WITH ORDINALITY AS t(event_id, idx)+ ),+ stream_upsert AS (+ INSERT INTO streams (stream_name, stream_version)+ VALUES ($2, (SELECT count(*) FROM event_list))+ ON CONFLICT (stream_name)+ DO UPDATE SET stream_version = streams.stream_version + (SELECT count(*) FROM event_list)+ WHERE streams.deleted_at IS NULL+ RETURNING stream_id, stream_version - (SELECT count(*) FROM event_list) AS initial_version+ ),+ link_inserts AS (+ -- LEFT JOIN LATERAL surfaces missing-event rows as NULLs for original_*; the+ -- NOT NULL constraint on stream_events.original_stream_id then aborts the+ -- entire CTE, rolling back the stream_upsert's version bump. Before the F3+ -- fix this was a plain JOIN LATERAL, which silently dropped missing-event+ -- rows while still bumping stream_version → silent gap in the link target.+ INSERT INTO stream_events (event_id, stream_id, stream_version, original_stream_id, original_stream_version)+ SELECT el.event_id, su.stream_id, su.initial_version + el.idx,+ orig.original_stream_id, orig.original_stream_version+ FROM event_list el+ CROSS JOIN stream_upsert su+ LEFT JOIN LATERAL (+ SELECT se.original_stream_id, se.original_stream_version+ FROM stream_events se+ WHERE se.event_id = el.event_id AND se.stream_id <> 0+ LIMIT 1+ ) orig ON true+ )+ SELECT su.stream_id, su.initial_version + (SELECT count(*) FROM event_list)+ FROM stream_upsert su+ """++-- ---------------------------------------------------------------------------+-- Category Read Statements+-- ---------------------------------------------------------------------------++-- | Read events from streams matching a category, in global position order.+readCategoryForwardStmt :: Statement (Int64, Text, Int32) (Vector RecordedEvent)+readCategoryForwardStmt =+ preparable+ readCategoryForwardSQL+ readCategoryEncoder+ (D.rowVector recordedEventRow)++readCategoryEncoder :: E.Params (Int64, Text, Int32)+readCategoryEncoder =+ contrazip3+ (E.param (E.nonNullable E.int8))+ (E.param (E.nonNullable E.text))+ (E.param (E.nonNullable E.int4))++readCategoryForwardSQL :: Text+readCategoryForwardSQL =+ """+ SELECT e.event_id, e.event_type,+ se.stream_version, se.stream_version AS global_position,+ se.original_stream_id, se.original_stream_version,+ e.data, e.metadata, e.causation_id, e.correlation_id,+ e.created_at+ FROM streams s+ JOIN LATERAL (+ SELECT se.*+ FROM stream_events se+ WHERE se.stream_id = 0+ AND se.original_stream_id = s.stream_id+ AND se.stream_version > $1+ ORDER BY se.stream_version ASC+ LIMIT $3+ ) se ON true+ JOIN events e ON e.event_id = se.event_id+ WHERE s.category = $2+ ORDER BY se.stream_version ASC+ LIMIT $3+ """++-- ---------------------------------------------------------------------------+-- Consumer-Group Read Statements+-- ---------------------------------------------------------------------------++{- | Partition-filtered category read for one consumer-group member.++Mirrors 'readCategoryForwardStmt' but returns only events whose originating+stream is assigned to member @$3@ of a group of size @$4@. The assignment rule+(MasterPlan IP-1) hashes the originating stream's surrogate id and folds the+signed result into @[0, size)@:++@member_of(stream_id) = (((hashtextextended(stream_id::text, 0) % size) + size) % size)@++The predicate is applied to @s.stream_id@ in the outer @WHERE@ so whole+unassigned streams are pruned before the lateral join. Params:+@(startPosition, category, member, size, limit)@.+-}+readCategoryForwardConsumerGroupStmt ::+ Statement (Int64, Text, Int32, Int32, Int32) (Vector RecordedEvent)+readCategoryForwardConsumerGroupStmt =+ preparable+ readCategoryForwardConsumerGroupSQL+ readCategoryConsumerGroupEncoder+ (D.rowVector recordedEventRow)++readCategoryConsumerGroupEncoder :: E.Params (Int64, Text, Int32, Int32, Int32)+readCategoryConsumerGroupEncoder =+ contrazip5+ (E.param (E.nonNullable E.int8))+ (E.param (E.nonNullable E.text))+ (E.param (E.nonNullable E.int4))+ (E.param (E.nonNullable E.int4))+ (E.param (E.nonNullable E.int4))++readCategoryForwardConsumerGroupSQL :: Text+readCategoryForwardConsumerGroupSQL =+ """+ SELECT e.event_id, e.event_type,+ se.stream_version, se.stream_version AS global_position,+ se.original_stream_id, se.original_stream_version,+ e.data, e.metadata, e.causation_id, e.correlation_id,+ e.created_at+ FROM streams s+ JOIN LATERAL (+ SELECT se.*+ FROM stream_events se+ WHERE se.stream_id = 0+ AND se.original_stream_id = s.stream_id+ AND se.stream_version > $1+ ORDER BY se.stream_version ASC+ LIMIT $5+ ) se ON true+ JOIN events e ON e.event_id = se.event_id+ WHERE s.category = $2+ AND (((hashtextextended(s.stream_id::text, 0) % $4) + $4) % $4) = $3+ ORDER BY se.stream_version ASC+ LIMIT $5+ """++{- | Partition-filtered @$all@ read for one consumer-group member.++Mirrors 'readAllForwardStmt' but returns only events whose originating stream is+assigned to member @$2@ of a group of size @$3@, using the same MasterPlan IP-1+rule as 'readCategoryForwardConsumerGroupStmt'. The predicate is applied to+@se.original_stream_id@ — the real originating stream of each @$all@ junction row+(never the reserved id 0 for normal appends). Params:+@(startPosition, member, size, limit)@.+-}+readAllForwardConsumerGroupStmt ::+ Statement (Int64, Int32, Int32, Int32) (Vector RecordedEvent)+readAllForwardConsumerGroupStmt =+ preparable+ readAllForwardConsumerGroupSQL+ readAllConsumerGroupEncoder+ (D.rowVector recordedEventRow)++readAllConsumerGroupEncoder :: E.Params (Int64, Int32, Int32, Int32)+readAllConsumerGroupEncoder =+ contrazip4+ (E.param (E.nonNullable E.int8))+ (E.param (E.nonNullable E.int4))+ (E.param (E.nonNullable E.int4))+ (E.param (E.nonNullable E.int4))++readAllForwardConsumerGroupSQL :: Text+readAllForwardConsumerGroupSQL =+ """+ SELECT e.event_id, e.event_type,+ se.stream_version, se.stream_version AS global_position,+ se.original_stream_id, se.original_stream_version,+ e.data, e.metadata, e.causation_id, e.correlation_id,+ e.created_at+ FROM stream_events se+ JOIN events e ON e.event_id = se.event_id+ WHERE se.stream_id = 0+ AND se.stream_version > $1+ AND (((hashtextextended(se.original_stream_id::text, 0) % $3) + $3) % $3) = $2+ ORDER BY se.stream_version ASC+ LIMIT $4+ """++-- ---------------------------------------------------------------------------+-- Lifecycle Statements+-- ---------------------------------------------------------------------------++-- | Soft-delete a stream by setting deleted_at. Returns Nothing if stream doesn't exist or is already deleted.+softDeleteStreamStmt :: Statement Text (Maybe StreamId)+softDeleteStreamStmt =+ preparable+ softDeleteStreamSQL+ (E.param (E.nonNullable E.text))+ (D.rowMaybe (StreamId <$> D.column (D.nonNullable D.int8)))++-- | Undelete a soft-deleted stream by clearing deleted_at. Returns Nothing if stream doesn't exist or is not deleted.+undeleteStreamStmt :: Statement Text (Maybe StreamId)+undeleteStreamStmt =+ preparable+ undeleteStreamSQL+ (E.param (E.nonNullable E.text))+ (D.rowMaybe (StreamId <$> D.column (D.nonNullable D.int8)))++{- | Look up a stream's id by name. Returns Nothing if the stream does not exist.+Used as the first step in hard-delete; subsequent steps key off the id rather+than the name so a single resolution is reused.+-}+findStreamIdStmt :: Statement Text (Maybe Int64)+findStreamIdStmt =+ preparable+ "SELECT stream_id FROM streams WHERE stream_name = $1"+ (E.param (E.nonNullable E.text))+ (D.rowMaybe (D.column (D.nonNullable D.int8)))++{- | Resolve a batch of surrogate stream ids to their (id, name) pairs in one+round trip. Ids that do not name an existing stream simply produce no row, so+the caller's 'Data.Map.Strict.Map' omits them. Surfaced as+'Kiroku.Store.Read.lookupStreamNames'.+-}+lookupStreamNamesStmt :: Statement [Int64] (Vector (Int64, Text))+lookupStreamNamesStmt =+ preparable+ "SELECT stream_id, stream_name FROM streams WHERE stream_id = ANY($1::bigint[])"+ (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.int8))))+ ( D.rowVector+ ( (,)+ <$> D.column (D.nonNullable D.int8)+ <*> D.column (D.nonNullable D.text)+ )+ )++{- | Delete every junction row that references the given stream — both rows whose+@stream_id@ is the target (the stream's own and any links from elsewhere) and+rows whose @original_stream_id@ is the target ($all entries plus link rows in+other streams that referenced events originating from the deleted stream).++Returns the distinct set of @event_id@s that lost at least one junction row.+The caller passes this set to @deleteOrphanedEventsStmt@ to remove event payloads+that no longer have any surviving junctions.++The previous single-CTE implementation tried to inline the orphan-event delete,+but PostgreSQL §7.8.2 specifies that data-modifying CTEs run against the same+snapshot, so the @NOT EXISTS@ subquery on stream_events saw the pre-delete state+and never deleted any events. Splitting into two statements within the same+hasql-transaction lets each statement see the previous statement's effects.+-}+deleteStreamJunctionsStmt :: Statement Int64 (Vector UUID)+deleteStreamJunctionsStmt =+ preparable+ """+ WITH deleted AS (+ DELETE FROM stream_events+ WHERE stream_id = $1+ OR original_stream_id = $1+ RETURNING event_id+ )+ SELECT DISTINCT event_id FROM deleted+ """+ (E.param (E.nonNullable E.int8))+ (D.rowVector (D.column (D.nonNullable D.uuid)))++{- | Delete event payloads from the @events@ table for the given event ids,+but only those whose junction rows have all been removed. Events that still+have any surviving @stream_events@ row are preserved (they remain visible from+their other homes).++Must be called after @deleteStreamJunctionsStmt@ within the same transaction+so the @NOT EXISTS@ subquery sees the post-delete state of @stream_events@.+-}+deleteOrphanedEventsStmt :: Statement (Vector UUID) ()+deleteOrphanedEventsStmt =+ preparable+ """+ DELETE FROM events+ WHERE event_id = ANY($1::uuid[])+ AND NOT EXISTS (+ SELECT 1 FROM stream_events+ WHERE stream_events.event_id = events.event_id+ )+ """+ (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+ D.noResult++{- | Delete the @streams@ row for the given stream id. Used as the final step+of hard-delete after junction rows and orphan events are cleared.+-}+deleteStreamRowStmt :: Statement Int64 ()+deleteStreamRowStmt =+ preparable+ "DELETE FROM streams WHERE stream_id = $1"+ (E.param (E.nonNullable E.int8))+ D.noResult++{- | Pre-acquire row locks on the named streams in deterministic (stream_id)+order. Used by AppendMultiStream to avoid row-lock deadlocks between+concurrent multi-stream transactions that touch overlapping streams in+different orders.++Streams that don't yet exist (NoStream variant on a fresh stream) are not+matched by the WHERE clause, so they aren't pre-locked here; concurrent+INSERTs of a fresh stream serialize on the unique index on @stream_name@.+\$all is intentionally NOT included in the pre-lock — its row lock is+acquired by each per-stream CTE inside the transaction, after the source+stream's row lock, so deadlocks between multi-stream and single-stream+transactions are avoided as long as both lock kinds in the same order+(source-first, then $all). See EP-1 F4.+-}+lockStreamsForMultiStmt :: Statement (Vector Text) ()+lockStreamsForMultiStmt =+ preparable+ """+ SELECT 1 FROM streams+ WHERE stream_name = ANY($1::text[])+ ORDER BY stream_id+ FOR UPDATE+ """+ (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+ D.noResult++-- ---------------------------------------------------------------------------+-- Lifecycle SQL Templates+-- ---------------------------------------------------------------------------++softDeleteStreamSQL :: Text+softDeleteStreamSQL =+ """+ UPDATE streams+ SET deleted_at = now()+ WHERE stream_name = $1+ AND deleted_at IS NULL+ RETURNING stream_id+ """++undeleteStreamSQL :: Text+undeleteStreamSQL =+ """+ UPDATE streams+ SET deleted_at = NULL+ WHERE stream_name = $1+ AND deleted_at IS NOT NULL+ RETURNING stream_id+ """++-- ---------------------------------------------------------------------------+-- Checkpoint Statements+-- ---------------------------------------------------------------------------++-- | Read the last-seen global position for a subscription.+getCheckpointStmt :: Statement Text (Maybe Int64)+getCheckpointStmt =+ preparable+ getCheckpointSQL+ (E.param (E.nonNullable E.text))+ (D.rowMaybe (D.column (D.nonNullable D.int8)))++-- | Upsert a checkpoint: insert or update the last-seen position.+saveCheckpointStmt :: Statement (Text, Int64) ()+saveCheckpointStmt =+ preparable+ saveCheckpointSQL+ ( contrazip2+ (E.param (E.nonNullable E.text))+ (E.param (E.nonNullable E.int8))+ )+ D.noResult++getCheckpointSQL :: Text+getCheckpointSQL =+ """+ SELECT last_seen+ FROM subscriptions+ WHERE subscription_name = $1+ """++saveCheckpointSQL :: Text+saveCheckpointSQL =+ """+ INSERT INTO subscriptions (subscription_name, last_seen, updated_at)+ VALUES ($1, $2, now())+ ON CONFLICT (subscription_name, consumer_group_member)+ DO UPDATE SET last_seen = GREATEST(subscriptions.last_seen, EXCLUDED.last_seen), updated_at = now()+ """++-- | Read the last-seen position for one consumer-group member of a subscription.+getCheckpointMemberStmt :: Statement (Text, Int32) (Maybe Int64)+getCheckpointMemberStmt =+ preparable+ getCheckpointMemberSQL+ ( contrazip2+ (E.param (E.nonNullable E.text))+ (E.param (E.nonNullable E.int4))+ )+ (D.rowMaybe (D.column (D.nonNullable D.int8)))++{- | Upsert the last-seen position for one consumer-group member, keyed on the+composite @(subscription_name, consumer_group_member)@ unique index. Uses the+same @GREATEST(...)@ monotonicity as 'saveCheckpointStmt' so a save never moves+a member's checkpoint backward.+-}+saveCheckpointMemberStmt :: Statement (Text, Int32, Int64) ()+saveCheckpointMemberStmt =+ preparable+ saveCheckpointMemberSQL+ ( contrazip3+ (E.param (E.nonNullable E.text))+ (E.param (E.nonNullable E.int4))+ (E.param (E.nonNullable E.int8))+ )+ D.noResult++getCheckpointMemberSQL :: Text+getCheckpointMemberSQL =+ """+ SELECT last_seen+ FROM subscriptions+ WHERE subscription_name = $1+ AND consumer_group_member = $2+ """++saveCheckpointMemberSQL :: Text+saveCheckpointMemberSQL =+ """+ INSERT INTO subscriptions (subscription_name, consumer_group_member, last_seen, updated_at)+ VALUES ($1, $2, $3, now())+ ON CONFLICT (subscription_name, consumer_group_member)+ DO UPDATE SET last_seen = GREATEST(subscriptions.last_seen, EXCLUDED.last_seen), updated_at = now()+ """
+ src/Kiroku/Store/Settings.hs view
@@ -0,0 +1,97 @@+{- | Interpreter-level hooks applied to 'EventData' before encoding on+the append path and to 'RecordedEvent' after decoding on the read and+subscription paths.++The hook seam lives inside 'Kiroku.Store.Effect.runStorePool' (and the+subscription publisher\/worker) rather than at the SQL encoder\/decoder+layer so the hook sees the typed value — payload and metadata as+'Data.Aeson.Value', the event type, ids — and can branch on event type+or mutate structured JSON. Plumbing it at the encoder layer would force+hooks to operate on opaque bytes.++Both fields default to 'Nothing'. With the defaults, the helpers below+take a 'pure' fast path that allocates nothing extra; no traversal of+the events list or vector occurs.++A typical use case is enriching every appended event with an+OpenTelemetry trace context drawn from the calling thread:++@+storeSettings = 'defaultStoreSettings'+ { 'enrichEvent' = Just $ \\ed -> do+ ctx <- captureCurrentSpan -- OpenTelemetry, OTLP, whatever+ pure (ed & #metadata %~ injectTraceContext ctx)+ , 'decodeHook' = Just $ \\re ->+ pure (re & #metadata %~ Just . redactPII)+ }+@++Wire the resulting 'StoreSettings' into+'Kiroku.Store.Connection.ConnectionSettings' via its @storeSettings@+field; 'Kiroku.Store.Connection.withStore' copies it onto the+'Kiroku.Store.Connection.KirokuStore' handle for the interpreter to+reach.++Direct callers of 'Kiroku.Store.Transaction.appendToStreamTx' bypass+'runStorePool' and therefore the 'enrichEvent' hook. Use+'Kiroku.Store.Transaction.enrichEventsIO' to opt in to enrichment+manually before constructing the prepared event list.+-}+module Kiroku.Store.Settings (+ StoreSettings (..),+ defaultStoreSettings,+ enrichEvents,+ decodeEvents,+) where++import Data.Vector (Vector)+import Data.Vector qualified as V+import GHC.Generics (Generic)+import Kiroku.Store.Types (EventData, RecordedEvent)++{- | Interpreter-level hooks for cross-cutting concerns at the+event-data boundary. All fields default to 'Nothing' (no-op).++* 'enrichEvent' fires on the append path before the SQL encoder runs,+ on the typed 'EventData' the caller supplied. Used to inject trace+ contexts, attach tenant ids, or encrypt payloads.++* 'decodeHook' fires on the read and subscription paths after the SQL+ decoder runs, on the typed 'RecordedEvent' about to be surfaced to+ the caller. Used to decrypt payloads, redact PII, or attach derived+ metadata.++When a field is 'Nothing', the interpreter takes a @pure@ fast path+that does not allocate or traverse.+-}+data StoreSettings = StoreSettings+ { enrichEvent :: !(Maybe (EventData -> IO EventData))+ -- ^ Append-path hook. Runs once per appended event before encoding.+ , decodeHook :: !(Maybe (RecordedEvent -> IO RecordedEvent))+ -- ^ Read- and subscription-path hook. Runs once per surfaced event.+ }+ deriving stock (Generic)++-- | Defaults to both hooks being 'Nothing' — semantically a no-op.+defaultStoreSettings :: StoreSettings+defaultStoreSettings =+ StoreSettings+ { enrichEvent = Nothing+ , decodeHook = Nothing+ }++{- | Apply 'enrichEvent' to a list of events. When the hook is+'Nothing', returns the list unchanged with no traversal.+-}+enrichEvents :: StoreSettings -> [EventData] -> IO [EventData]+enrichEvents ss xs = case enrichEvent ss of+ Nothing -> pure xs+ Just f -> traverse f xs++{- | Apply 'decodeHook' to a vector of events. When the hook is+'Nothing', returns the vector unchanged with no traversal.+-}+decodeEvents :: StoreSettings -> Vector RecordedEvent -> IO (Vector RecordedEvent)+decodeEvents ss xs = case decodeHook ss of+ Nothing -> pure xs+ Just f -> V.mapM f xs
+ src/Kiroku/Store/Subscription.hs view
@@ -0,0 +1,146 @@+module Kiroku.Store.Subscription (+ -- * Subscribe+ subscribe,+ withSubscription,++ -- * Types+ module Kiroku.Store.Subscription.Types,+) where++import Control.Concurrent.Async qualified as Async+import Control.Concurrent.STM (atomically)+import Control.Exception (bracket, finally, throwIO)+import Control.Lens ((^.))+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Data.Foldable (for_)+import Data.Generics.Labels ()+import Kiroku.Store.Connection (KirokuStore (..))+import Kiroku.Store.Subscription.EventPublisher qualified as Pub+import Kiroku.Store.Subscription.Types+import Kiroku.Store.Subscription.Worker (runWorker)++{- | Start a subscription. Returns a handle for cancellation and waiting.++The subscription spawns a worker thread that:++1. Reads the checkpoint from the database (or starts from global position 0+ for a fresh subscription name).+2. Catches up by querying the database directly until it reaches the+ 'Kiroku.Store.Subscription.EventPublisher.lastPublished' cursor.+3. Switches to live mode. For 'Kiroku.Store.Subscription.Types.AllStreams'+ subscriptions, the worker reads pre-broadcast events from the+ publisher's bounded per-subscriber queue. For+ 'Kiroku.Store.Subscription.Types.Category' subscriptions, the worker+ bypasses the broadcast entirely and re-queries the database with the+ SQL category filter whenever 'lastPublished' advances.++The returned 'SubscriptionHandle' carries an implicit lifecycle contract:+the worker thread runs until 'cancel' is called or the handler returns 'Stop'.+Forgetting to cancel leaks the thread. Prefer 'withSubscription' for any+non-trivial code path; use the bare 'subscribe' only when the caller already+has a structured lifecycle (e.g., the Streamly 'subscriptionStream' bridge).++=== Delivery semantics++Events are delivered __at least once__. The store's checkpoint is advanced+__per batch__, not per event: when the handler returns 'Continue' for every+event in a batch the checkpoint is saved at the batch tail; when the handler+returns 'Stop' for some event the checkpoint is saved at that event. The+following events on the boundary therefore __replay__ on the next+subscription with the same 'Kiroku.Store.Subscription.Types.SubscriptionName':++* The handler returned 'Continue' but the worker was cancelled or the+ process crashed before 'saveCheckpoint' completed. The events processed+ by the handler are re-delivered.+* The handler was interrupted between events (cancellation, crash) inside+ one batch. The events already processed are re-delivered along with the+ not-yet-processed ones.+* The publisher could not reach the database for one cycle (transient+ pool error). The next cycle re-fetches and re-broadcasts; subscribers+ that had already exited catch-up may see those events delivered late+ with no checkpoint advance in between, so a subsequent restart replays+ them.++Handlers must therefore be idempotent — process a duplicate event without+producing a wrong-on-replay result — or be tolerant of duplicates by some+domain-specific check (e.g., a unique key on the projection table).++=== Failure modes++The 'Kiroku.Store.Subscription.Types.SubscriptionHandleM.wait' on the+returned handle resolves with one of:++* @Right ()@ — the handler returned 'Stop' for some event and the worker+ exited cleanly. The checkpoint is saved at that event.+* @Left e@ where @e@ is 'Control.Concurrent.Async.AsyncCancelled' — the+ caller invoked 'cancel'. No checkpoint advance is guaranteed; events+ in flight at cancellation time will replay.+* @Left e@ where @e@ is+ 'Kiroku.Store.Subscription.Types.SubscriptionOverflowed' — the publisher+ marked this subscription overflowed under+ 'Kiroku.Store.Subscription.Types.DropSubscription'. Investigate the+ slow handler and either fix the slowness, raise 'queueCapacity', or+ switch to 'Kiroku.Store.Subscription.Types.DropOldest' if the consumer+ can tolerate event loss.+* @Left e@ for any exception thrown by the handler — handler exceptions+ are not caught; the worker thread dies and the original exception+ propagates to the consumer. This is intentional: a handler that+ throws is signalling that the subscription cannot proceed safely.+-}+subscribe :: (MonadIO m) => KirokuStore -> SubscriptionConfig -> m SubscriptionHandle+subscribe store config = liftIO $ do+ -- Fail fast on a misconfigured group, before any thread is spawned. A bad+ -- (member, size) is a programmer error; throwing here keeps subscribe's+ -- non-Either signature intact for every existing caller (see EP-2 Decision Log).+ for_ (consumerGroup config) $ \(ConsumerGroup m n) ->+ when (n < 1 || m < 0 || m >= n) $+ throwIO (InvalidConsumerGroup m n)+ (queue, statusVar, unsubscribe) <-+ atomically $+ Pub.subscribePublisher+ (store ^. #publisher)+ (queueCapacity config)+ (overflowPolicy config)+ let pubPosVar = Pub.lastPublished (store ^. #publisher)+ -- `finally unsubscribe` removes this subscription from the publisher's+ -- registry whenever the worker exits — gracefully on Stop, by+ -- cancellation, or on any exception (including SubscriptionOverflowed).+ -- Forgetting to unsubscribe would leave a registry entry with no reader,+ -- and the publisher would needlessly trigger this subscriber's overflow+ -- policy on the next batch.+ thread <-+ Async.async+ ( runWorker (store ^. #pool) queue statusVar pubPosVar config (store ^. #eventHandler) (store ^. #storeSettings)+ `finally` unsubscribe+ )+ pure+ SubscriptionHandle+ { cancel = Async.cancel thread+ , wait = Async.waitCatch thread+ }++{- | Bracket-style subscription lifecycle.++Starts a subscription, runs the body, and ensures the underlying worker+thread is cancelled on either normal exit or an exception thrown inside+the body. This is the recommended way to use subscriptions: forgetting+to call 'cancel' on a 'SubscriptionHandle' leaks the worker thread for+the lifetime of the process.++Equivalent to:++ bracket (subscribe store config) cancel action++but lifted to any 'MonadUnliftIO' so it composes with effectful stacks+that already have an unlift in scope.+-}+withSubscription ::+ (MonadUnliftIO m) =>+ KirokuStore ->+ SubscriptionConfig ->+ (SubscriptionHandle -> m a) ->+ m a+withSubscription store config action = withRunInIO $ \runInIO ->+ bracket (subscribe store config) cancel (runInIO . action)
+ src/Kiroku/Store/Subscription/Effect.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE TypeFamilies #-}++module Kiroku.Store.Subscription.Effect (+ -- * The Subscription effect+ Subscription (..),++ -- * Convenience wrappers+ subscribe,+ withSubscription,++ -- * Interpreters+ runSubscription,+ runSubscriptionResource,+) where++import Control.Monad.IO.Class (liftIO)+import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..), (:>))+import Effectful.Dispatch.Dynamic (HasCallStack, interpret, localUnliftIO, send)+import Effectful.Exception (bracket)+import Kiroku.Store.Connection (KirokuStore)+import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore)+import Kiroku.Store.Subscription qualified as Sub+import Kiroku.Store.Subscription.Types (SubscriptionConfigM (..), SubscriptionHandle, SubscriptionHandleM (..))++-- ---------------------------------------------------------------------------+-- Subscription effect+-- ---------------------------------------------------------------------------++{- | The Subscription effect — subscribe to event streams.++This is a higher-order effect: the handler inside the config runs in the+caller's effect monad @m@, which is @Eff localEs@ at the call site.+-}+data Subscription :: Effect where+ Subscribe :: SubscriptionConfigM m -> Subscription m SubscriptionHandle++type instance DispatchOf Subscription = Dynamic++-- ---------------------------------------------------------------------------+-- Convenience wrapper+-- ---------------------------------------------------------------------------++{- | Subscribe to an event stream (effectful API).++The handler inside the config runs in @Eff es@, so it can use any effects+available in the caller's stack.++__Lifecycle note:__ The returned handle must be canceled before the effect+scope exits. The subscription thread captures the effect environment; if the+@Eff@ computation finishes while the thread is still running, the environment+becomes invalid. Prefer 'withSubscription' (also exported from this module)+which wraps subscribe/cancel in a @bracket@ and is exception-safe.++=== Delivery semantics++Identical to 'Kiroku.Store.Subscription.subscribe': events are delivered+__at least once__, the checkpoint is advanced __per batch__, and handlers+must be idempotent. See the Haddock on+'Kiroku.Store.Subscription.subscribe' for the full enumeration of replay+boundaries (cancel-after-Continue, mid-batch cancellation, transient+publisher pool errors) and the failure-mode table for+'Kiroku.Store.Subscription.Types.SubscriptionHandleM.wait'.++The effectful interpreter wraps the user's handler with the+@ConcUnlift Persistent (Limited 1)@ unlift strategy (see 'runSubscription').+This preserves the worker's single-threaded contract: only one handler+invocation is in flight at a time, and the effect environment outlives+all handler calls so 'Effectful.State.Static.Local.State' /+'Effectful.Reader.Static.Reader' contents remain consistent across the+subscription.+-}+subscribe :: (HasCallStack, Subscription :> es) => SubscriptionConfigM (Eff es) -> Eff es SubscriptionHandle+subscribe config = send (Subscribe config)++{- | Bracket-style subscription lifecycle for the effectful API.++Starts a subscription, runs the body, and cancels the worker on either+normal exit or an exception thrown inside the body. This is the+exception-safe form of 'subscribe' — the `Eff`-based 'subscribe' captures+the caller's effect environment in the worker thread, so a leaking thread+can refer to an environment that has already been torn down.++The body runs in @Eff es@; the underlying 'SubscriptionHandle' is IO-based,+so 'cancel' is invoked via 'liftIO'. 'Effectful.Exception.bracket' guarantees+the cancel runs even on async exceptions.+-}+withSubscription ::+ (HasCallStack, Subscription :> es, IOE :> es) =>+ SubscriptionConfigM (Eff es) ->+ (SubscriptionHandle -> Eff es a) ->+ Eff es a+withSubscription config = bracket (subscribe config) (liftIO . cancel)++-- ---------------------------------------------------------------------------+-- Interpreters+-- ---------------------------------------------------------------------------++{- | Interpret 'Subscription' by delegating to the @MonadIO@-based+'Kiroku.Store.Subscription.subscribe'.++The unlift strategy is @ConcUnlift Persistent (Limited 1)@:++* @Persistent@ — the effect environment must outlive each individual+ handler invocation. The worker thread calls the handler many times+ over its lifetime; an @Ephemeral@ unlift would reset the environment+ between calls and lose any 'Effectful.State.Static.Local.State' /+ 'Effectful.Reader.Static.Reader' contents.+* @Limited 1@ — only one concurrent unlift is in flight at any time.+ The worker thread is single-threaded by construction (events are+ processed sequentially within a subscription), so a higher bound+ would be wasteful. A @Limited 0@ would prevent any unlift and break+ the handler entirely.++Do not relax these bounds without restructuring the worker.+-}+runSubscription ::+ (IOE :> es) =>+ KirokuStore ->+ Eff (Subscription : es) a ->+ Eff es a+runSubscription store = interpret $ \env -> \case+ Subscribe config ->+ localUnliftIO env (ConcUnlift Persistent (Limited 1)) $ \unlift -> do+ -- Record update intentionally: every field except 'handler' is preserved,+ -- including 'consumerGroup' and 'consumerGroupGuard' (added in EP-2). Do not+ -- switch to a full record literal here — that would silently reset new fields+ -- and drop a caller's consumer-group membership.+ let ioConfig = config{handler = \evt -> unlift (handler config evt)}+ Sub.subscribe store ioConfig++-- | Interpret Subscription by reading the store handle from 'KirokuStoreResource'.+runSubscriptionResource ::+ (IOE :> es, KirokuStoreResource :> es) =>+ Eff (Subscription : es) a ->+ Eff es a+runSubscriptionResource action = do+ store <- getKirokuStore+ runSubscription store action
+ src/Kiroku/Store/Subscription/EventPublisher.hs view
@@ -0,0 +1,251 @@+module Kiroku.Store.Subscription.EventPublisher (+ EventPublisher (..),+ Subscriber (..),+ SubscriberStatus (..),+ startPublisher,+ stopPublisher,+ subscribePublisher,+ publisherPosition,+) where++import Control.Concurrent.Async (Async)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.STM (+ STM,+ TBQueue,+ TChan,+ TVar,+ atomically,+ dupTChan,+ isFullTBQueue,+ modifyTVar',+ newTBQueue,+ newTVar,+ newTVarIO,+ readTChan,+ readTVar,+ readTVarIO,+ registerDelay,+ tryReadTBQueue,+ tryReadTChan,+ writeTBQueue,+ writeTVar,+ )+import Control.Concurrent.STM qualified as STM+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Foldable (for_)+import Data.Int (Int32, Int64)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Vector (Vector)+import Data.Vector qualified as V+import Hasql.Pool (Pool)+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Kiroku.Store.Observability (KirokuEvent (..))+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Settings (StoreSettings, decodeEvents)+import Kiroku.Store.Subscription.Types (OverflowPolicy (..))+import Kiroku.Store.Types (GlobalPosition (..), RecordedEvent (..))+import Numeric.Natural (Natural)++{- | The centralized EventPublisher. Reads events from the database once per+notification and fans them out to a registry of bounded per-subscriber+queues. The registry replaces the prior unbounded broadcast 'TChan' so+that one slow subscriber cannot grow the publisher's fan-out memory+without limit (EP-3 F6).+-}+data EventPublisher = EventPublisher+ { subscribers :: !(TVar (IntMap Subscriber))+ -- ^ Active subscriber registry, keyed by an internal id.+ , nextSubscriberId :: !(TVar Int)+ , publisherThread :: !(Async ())+ , lastPublished :: !(TVar GlobalPosition)+ -- ^ Last-published position; workers read this to know when catch-up is done+ }++{- | A registered subscriber. The publisher owns one of these per+'Kiroku.Store.Subscription.subscribe' call. The worker reads from+'subQueue' under normal operation; on overflow under 'DropSubscription'+the publisher flips 'subStatus' to 'Overflowed' and the worker+terminates the subscription with 'SubscriptionOverflowed'.+-}+data Subscriber = Subscriber+ { subQueue :: !(TBQueue (Vector RecordedEvent))+ , subStatus :: !(TVar SubscriberStatus)+ , subPolicy :: !OverflowPolicy+ }++-- | Subscriber lifecycle status as observed by its worker.+data SubscriberStatus+ = -- | Healthy; worker reads from the queue normally.+ Active+ | -- | Publisher signalled overflow; worker should surface a structured error.+ Overflowed+ deriving stock (Eq, Show)++{- | Publisher batch size — larger than subscriber batch size because the+Publisher serves all subscribers.+-}+publisherBatchSize :: Int32+publisherBatchSize = 1000++-- | Safety poll interval in microseconds (30 seconds).+safetyPollMicros :: Int+safetyPollMicros = 30_000_000++{- | Start the EventPublisher. Spawns a thread that waits for ticks from the+Notifier (or a 30-second safety poll timeout), queries the database for+new events, and delivers them to every active subscriber. Per-subscriber+overflow handling is determined by each subscription's+'OverflowPolicy'.++If an 'eventHandler' callback is supplied, the publisher emits+'Kiroku.Store.Observability.KirokuEventPublisherPoolError' when its read+query returns a 'Pool.UsageError'. The publisher continues to run on the+30-second safety poll regardless of the event firing; the event is the+operator's only structured signal that pool exhaustion or a server+error stalled the broadcast.+-}+startPublisher ::+ (MonadIO m) =>+ Pool ->+ TChan () ->+ -- | optional event handler for publisher-side observability+ Maybe (KirokuEvent -> IO ()) ->+ {- | interpreter-level event hooks; 'Kiroku.Store.Settings.decodeHook'+ runs once per fetched batch before fan-out to subscribers.+ -}+ StoreSettings ->+ m EventPublisher+startPublisher pool notifierChan mHandler stSettings = liftIO $ do+ subsVar <- newTVarIO IntMap.empty+ nextIdVar <- newTVarIO 0+ pos <- newTVarIO (GlobalPosition 0)+ -- Get a personal copy of the notifier's broadcast channel+ tickChan <- atomically (dupTChan notifierChan)+ thread <- Async.async (publisherLoop pool tickChan subsVar pos mHandler stSettings)+ pure+ EventPublisher+ { subscribers = subsVar+ , nextSubscriberId = nextIdVar+ , publisherThread = thread+ , lastPublished = pos+ }++-- | Stop the EventPublisher thread.+stopPublisher :: (MonadIO m) => EventPublisher -> m ()+stopPublisher pub = liftIO $ do+ Async.cancel (publisherThread pub)+ () <$ Async.waitCatch (publisherThread pub)++{- | Register a new subscriber with the given queue capacity and overflow+policy. Returns the bounded queue, the subscriber's status TVar, and an+@unsubscribe@ action that the caller must invoke when the subscription+ends (worker exits, cancellation). Failing to unsubscribe causes the+publisher to keep delivering to a queue with no reader, which will fill+and trigger the configured policy unnecessarily.+-}+subscribePublisher ::+ EventPublisher ->+ -- | Queue capacity (number of batches)+ Natural ->+ OverflowPolicy ->+ STM (TBQueue (Vector RecordedEvent), TVar SubscriberStatus, IO ())+subscribePublisher pub cap policy = do+ queue <- newTBQueue cap+ status <- newTVar Active+ sid <- readTVar (nextSubscriberId pub)+ writeTVar (nextSubscriberId pub) (sid + 1)+ let sub = Subscriber{subQueue = queue, subStatus = status, subPolicy = policy}+ modifyTVar' (subscribers pub) (IntMap.insert sid sub)+ let unsubscribe =+ atomically $+ modifyTVar' (subscribers pub) (IntMap.delete sid)+ pure (queue, status, unsubscribe)++-- | Read the last-published global position.+publisherPosition :: EventPublisher -> STM GlobalPosition+publisherPosition pub = readTVar (lastPublished pub)++-- Internal: the publisher loop.+publisherLoop ::+ Pool ->+ TChan () ->+ TVar (IntMap Subscriber) ->+ TVar GlobalPosition ->+ Maybe (KirokuEvent -> IO ()) ->+ StoreSettings ->+ IO ()+publisherLoop pool tickChan subsVar posVar mHandler stSettings = loop+ where+ loop = do+ -- Wait for a tick OR safety poll timeout+ waitForWakeup tickChan+ -- Drain all pending ticks (debouncing)+ drainTicks tickChan+ -- Fetch and broadcast+ fetchAndBroadcast+ loop++ fetchAndBroadcast = do+ GlobalPosition pos <- readTVarIO posVar+ result <- Pool.use pool (Session.statement (pos, publisherBatchSize) SQL.readAllForwardStmt)+ case result of+ Left err -> do+ -- Surface the pool error so operators see why broadcast+ -- has stalled; the 30-second safety poll will retry.+ for_ mHandler ($ KirokuEventPublisherPoolError err)+ Right rawEvents+ | V.null rawEvents -> pure ()+ | otherwise -> do+ -- Apply the decodeHook once per batch — every subscriber+ -- observes the same transformed view, and the cost is+ -- paid in one place instead of per-subscriber.+ events <- decodeEvents stSettings rawEvents+ let lastEvent = V.last events+ newPos = globalPosition lastEvent+ -- Snapshot the current subscriber set, then deliver outside+ -- the snapshot's STM transaction. Each delivery is its own+ -- atomic step so a slow subscriber under DropSubscription+ -- cannot rollback another's enqueue.+ subs <- readTVarIO subsVar+ for_ (IntMap.elems subs) (deliverBatch events)+ -- Advance posVar after attempting delivery to all subscribers.+ -- Subscribers under DropSubscription have already been marked+ -- Overflowed; their workers will observe and exit. Subscribers+ -- under DropOldest have lost the oldest batch but their queues+ -- are not full anymore.+ atomically (writeTVar posVar newPos)+ -- If we got a full batch, there may be more — loop immediately+ if V.length events >= fromIntegral publisherBatchSize+ then fetchAndBroadcast+ else pure ()++ deliverBatch events sub = atomically $ do+ full <- isFullTBQueue (subQueue sub)+ if not full+ then writeTBQueue (subQueue sub) events+ else case subPolicy sub of+ DropSubscription -> writeTVar (subStatus sub) Overflowed+ DropOldest -> do+ _ <- tryReadTBQueue (subQueue sub)+ writeTBQueue (subQueue sub) events++-- Wait for either a tick or a 30-second timeout (safety poll).+waitForWakeup :: TChan () -> IO ()+waitForWakeup tickChan = do+ timerVar <- registerDelay safetyPollMicros+ atomically $+ (readTChan tickChan)+ `STM.orElse` (readTVar timerVar >>= STM.check)++-- Drain all pending ticks from the channel (debouncing).+drainTicks :: TChan () -> IO ()+drainTicks tickChan = atomically go+ where+ go = do+ mTick <- tryReadTChan tickChan+ case mTick of+ Nothing -> pure ()+ Just () -> go
+ src/Kiroku/Store/Subscription/Stream.hs view
@@ -0,0 +1,67 @@+module Kiroku.Store.Subscription.Stream (+ subscriptionStream,+)+where++import Control.Concurrent.STM (TBQueue, atomically, newTBQueueIO, readTBQueue, writeTBQueue)+import Kiroku.Store.Connection (KirokuStore)+import Kiroku.Store.Subscription (subscribe)+import Kiroku.Store.Subscription.Types (+ SubscriptionConfig,+ SubscriptionConfigM (..),+ SubscriptionHandleM (..),+ SubscriptionResult (..),+ )+import Kiroku.Store.Types (RecordedEvent)+import Numeric.Natural (Natural)+import Streamly.Data.Stream (Stream)+import Streamly.Data.Stream qualified as Stream++{- | Create a pull-based 'Stream' from a kiroku subscription.++A bounded 'TBQueue' sits between kiroku's push-based handler and the+returned Streamly stream. The handler writes @Just event@ into the queue+and returns 'Continue'. A @Nothing@ sentinel signals end-of-stream.+The stream terminates when it reads @Nothing@.++The @handler@ field in the provided 'SubscriptionConfig' is ignored —+the bridge provides its own handler.++The returned cancel action cancels the underlying subscription and+writes the sentinel so any blocked reader wakes up and terminates.+-}+subscriptionStream ::+ KirokuStore ->+ SubscriptionConfig ->+ -- | TBQueue capacity (buffer size for backpressure)+ Natural ->+ IO (Stream IO RecordedEvent, IO ())+subscriptionStream store config bufferSize = do+ queue <- newTBQueueIO bufferSize++ let bridgeHandler :: RecordedEvent -> IO SubscriptionResult+ bridgeHandler event = do+ atomically $ writeTBQueue queue (Just event)+ pure Continue++ let bridgeConfig =+ config+ { handler = bridgeHandler+ }++ subHandle <- subscribe store bridgeConfig++ let cancelAction = do+ cancel subHandle+ atomically $ writeTBQueue queue Nothing++ let stream = Stream.unfoldrM (step queue) ()++ pure (stream, cancelAction)+ where+ step :: TBQueue (Maybe RecordedEvent) -> () -> IO (Maybe (RecordedEvent, ()))+ step queue () = do+ mEvent <- atomically $ readTBQueue queue+ case mEvent of+ Just event -> pure (Just (event, ()))+ Nothing -> pure Nothing
+ src/Kiroku/Store/Subscription/Types.hs view
@@ -0,0 +1,201 @@+module Kiroku.Store.Subscription.Types (+ SubscriptionName (..),+ SubscriptionTarget (..),+ SubscriptionResult (..),+ OverflowPolicy (..),+ SubscriptionOverflowed (..),+ EventHandlerM,+ EventHandler,+ SubscriptionConfigM (..),+ SubscriptionConfig,+ defaultSubscriptionConfig,+ SubscriptionHandleM (..),+ SubscriptionHandle,++ -- * Consumer groups+ ConsumerGroup (..),+ InvalidConsumerGroup (..),+ ConsumerGroupGuardConflict (..),+) where++import Control.Exception (Exception, SomeException)+import Data.Int (Int32)+import Data.Text (Text)+import Kiroku.Store.Types (CategoryName, RecordedEvent)+import Numeric.Natural (Natural)++-- | Unique name for a subscription (e.g., @"inventory-projection"@).+newtype SubscriptionName = SubscriptionName Text+ deriving newtype (Eq, Ord, Show)++-- | Which stream to subscribe to.+data SubscriptionTarget+ = -- | Subscribe to all events in global position order.+ AllStreams+ | -- | Subscribe to events from streams matching a category prefix.+ Category !CategoryName+ deriving stock (Eq, Show)++-- | What the handler returns to control the subscription lifecycle.+data SubscriptionResult+ = -- | Continue processing events.+ Continue+ | -- | Stop the subscription gracefully.+ Stop+ deriving stock (Eq, Show)++{- | What the publisher does when a subscriber's bounded queue is full.++The default 'DropSubscription' chooses production safety over best-effort+delivery: the slow subscriber is shut down and the consumer learns+explicitly via a 'SubscriptionOverflowed' exception on+'Kiroku.Store.Subscription.Types.SubscriptionHandleM' wait. The+alternative ('DropOldest') quietly trades correctness for liveness and+should only be chosen for telemetry-style subscriptions where missing+events is acceptable.+-}+data OverflowPolicy+ = {- | Mark the subscription as overflowed; the worker observes this on+ its next iteration and surfaces 'SubscriptionOverflowed' through+ 'wait'. The slow subscriber is terminated; other subscribers are+ unaffected.+ -}+ DropSubscription+ | {- | Drop the oldest queued batch and enqueue the new one. The+ subscription continues but loses events. Choose only when at-least-once+ semantics are not required for this consumer.+ -}+ DropOldest+ deriving stock (Eq, Show)++{- | Raised on a 'SubscriptionHandleM' wait when the publisher dropped the+subscription because its bounded queue overflowed (overflow policy+'DropSubscription'). The 'subscriptionName' identifies the subscription+that overflowed; the consumer is expected to investigate the slow handler+and either fix the slowness or switch to 'DropOldest'.+-}+newtype SubscriptionOverflowed = SubscriptionOverflowed+ { subscriptionName :: SubscriptionName+ }+ deriving stock (Show)+ deriving anyclass (Exception)++-- | Handler callback invoked for each event, parameterized by monad.+type EventHandlerM m = RecordedEvent -> m SubscriptionResult++-- | Handler callback defaulting to 'IO'.+type EventHandler = EventHandlerM IO++-- | Configuration for starting a subscription, parameterized by monad.+data SubscriptionConfigM m = SubscriptionConfig+ { name :: !SubscriptionName+ , target :: !SubscriptionTarget+ , handler :: !(EventHandlerM m)+ , batchSize :: !Int32+ -- ^ Number of events to fetch per batch during catch-up (default: 100)+ , queueCapacity :: !Natural+ {- ^ Maximum number of /batches/ the publisher may enqueue for this+ subscriber before applying 'overflowPolicy'. Each batch is up to+ 'EventPublisher.publisherBatchSize' events, so the effective event+ capacity is @queueCapacity * publisherBatchSize@. Default: 16+ batches (~16,000 events at the default publisher batch size).+ -}+ , overflowPolicy :: !OverflowPolicy+ {- ^ What the publisher does when this subscriber's queue is full.+ Default: 'DropSubscription' — slow subscribers are terminated with a+ structured error rather than silently growing the publisher's+ fan-out memory or losing events.+ -}+ , consumerGroup :: !(Maybe ConsumerGroup)+ {- ^ 'Nothing' (the default) = ordinary single-consumer subscription.+ 'Just cg' = this worker is member 'member cg' of a group of size+ 'size cg'. The invariant @size >= 1@ and @0 <= member < size@ is+ enforced once at 'Kiroku.Store.Subscription.subscribe' time, which+ throws 'InvalidConsumerGroup' on violation.+ -}+ , consumerGroupGuard :: !Bool+ {- ^ When 'True' (default 'False'), the worker performs a one-shot+ PostgreSQL advisory-lock conflict check at startup so two processes+ cannot both run the same @(name, member)@ at once. See the worker's+ @guardMember@ for the exact semantics and its documented limitation+ (a startup detection probe, not a lifetime-held lock). Ignored when+ 'consumerGroup' is 'Nothing'.+ -}+ }++-- | Configuration defaulting to 'IO'.+type SubscriptionConfig = SubscriptionConfigM IO++{- | Build a 'SubscriptionConfig' with the recommended defaults.++The catch-up batch size defaults to 100 events per database fetch — large+enough to amortise round-trip overhead on typical projection workloads,+small enough that a single slow handler call does not stall the worker+for long. Override the 'batchSize' field on the returned record if a+different value suits the workload.++@+let cfg = defaultSubscriptionConfig "my-projection" AllStreams handler+withSubscription store cfg $ \\h -> wait h+@+-}+defaultSubscriptionConfig ::+ SubscriptionName ->+ SubscriptionTarget ->+ EventHandlerM m ->+ SubscriptionConfigM m+defaultSubscriptionConfig name' target' handler' =+ SubscriptionConfig+ { name = name'+ , target = target'+ , handler = handler'+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }++-- | Handle returned to the caller for lifecycle management, parameterized by monad.+data SubscriptionHandleM m = SubscriptionHandle+ { cancel :: !(m ())+ -- ^ Cancel the subscription gracefully+ , wait :: !(m (Either SomeException ()))+ -- ^ Block until the subscription completes or fails+ }++-- | Handle defaulting to 'IO'.+type SubscriptionHandle = SubscriptionHandleM IO++-- | Static consumer-group membership for a subscription.+data ConsumerGroup = ConsumerGroup+ { member :: !Int32+ -- ^ 0-based member index; must satisfy @0 <= member < size@.+ , size :: !Int32+ -- ^ total members in the group; must be @>= 1@.+ }+ deriving stock (Eq, Show)++{- | Thrown by 'Kiroku.Store.Subscription.subscribe' when a 'ConsumerGroup'+violates @size >= 1@ or @0 <= member < size@. Carries the offending values for+diagnostics.+-}+data InvalidConsumerGroup = InvalidConsumerGroup+ { invalidMember :: !Int32+ , invalidSize :: !Int32+ }+ deriving stock (Show)+ deriving anyclass (Exception)++{- | Thrown at subscription startup when 'consumerGroupGuard' is 'True' and+another holder currently holds the advisory lock for this @(name, member)@.+Indicates two processes are configured as the same group member. This is a+startup /detection/ probe, not a lifetime-held lock — see the worker's+@guardMember@.+-}+data ConsumerGroupGuardConflict = ConsumerGroupGuardConflict+ { conflictName :: !SubscriptionName+ , conflictMember :: !Int32+ }+ deriving stock (Show)+ deriving anyclass (Exception)
+ src/Kiroku/Store/Subscription/Worker.hs view
@@ -0,0 +1,378 @@+module Kiroku.Store.Subscription.Worker (+ runWorker,+) where++import Contravariant.Extras (contrazip2)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.STM (TBQueue, TVar, atomically, check, readTBQueue, readTVar)+import Control.Exception (SomeException, fromException, throwIO, try)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Foldable (for_)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Int (Int32, Int64)+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Vector qualified as V+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool (Pool)+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Kiroku.Store.Observability (+ KirokuEvent (..),+ SubscriptionDbPhase (..),+ SubscriptionGroupContext (..),+ SubscriptionStopReason (..),+ )+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Settings (StoreSettings, decodeEvents)+import Kiroku.Store.Subscription.EventPublisher (SubscriberStatus (..))+import Kiroku.Store.Subscription.Types+import Kiroku.Store.Types (CategoryName (..), GlobalPosition (..), RecordedEvent (..))++{- | Run the subscription worker loop. Two phases:++Phase 1 (catch-up): queries database directly until reaching publisherPosition.+Phase 2 (live): for AllStreams, reads from the bounded TBQueue the publisher+delivers to; for Category, re-queries the database whenever the publisher+advances (the broadcast TBQueue is unused for category subscriptions).++Runs until the handler returns 'Stop', the thread is cancelled, or the+publisher signals overflow on the subscriber's status TVar (in which+case 'Kiroku.Store.Subscription.Types.SubscriptionOverflowed' is thrown+and surfaces through 'Async.waitCatch').++If an 'eventHandler' callback is supplied, the worker emits:++* 'Kiroku.Store.Observability.KirokuEventSubscriptionStarted' once at+ startup, after the checkpoint has been read.+* 'Kiroku.Store.Observability.KirokuEventSubscriptionCaughtUp' when+ catch-up completes and the worker switches to live mode.+* 'Kiroku.Store.Observability.KirokuEventSubscriptionDbError' in the+ three database-error swallowing sites: 'loadCheckpoint', 'fetchBatch',+ and 'saveCheckpoint'. The worker still degrades safely; the event is+ the operator's structured signal.+* 'Kiroku.Store.Observability.KirokuEventSubscriptionStopped' when the+ worker exits, with a reason discriminating handler-stop, cancel,+ overflow, and worker-crash.+-}+runWorker ::+ (MonadIO m) =>+ Pool ->+ TBQueue (Vector RecordedEvent) ->+ TVar SubscriberStatus ->+ TVar GlobalPosition ->+ SubscriptionConfig ->+ -- | optional event handler for subscription observability+ Maybe (KirokuEvent -> IO ()) ->+ {- | interpreter-level event hooks; 'Kiroku.Store.Settings.decodeHook'+ runs on the catch-up fetch path, mirroring the publisher's+ application in live mode.+ -}+ StoreSettings ->+ m ()+runWorker pool liveQueue statusVar pubPosVar config mHandler stSettings = liftIO $ do+ let emit evt = for_ mHandler ($ evt)+ subName = name config+ groupCtx = groupCtxOf config+ posRef <- newIORef (GlobalPosition 0)++ let body = do+ -- Optional startup guardrail: when consumerGroupGuard is on, fail fast+ -- if another holder currently holds this (name, member)'s advisory lock.+ case (consumerGroupGuard config, consumerGroup config) of+ (True, Just (ConsumerGroup m _)) -> guardMember pool subName m+ _ -> pure ()+ checkpoint <- loadCheckpoint pool config emit+ writeIORef posRef checkpoint+ emit (KirokuEventSubscriptionStarted subName checkpoint groupCtx)+ -- Phase 1: catch-up (returns Nothing if handler said Stop)+ result <- catchUp pool config checkpoint pubPosVar emit posRef stSettings+ case result of+ Nothing -> pure () -- Handler said Stop during catch-up; exit+ Just finalPos -> do+ writeIORef posRef finalPos+ emit (KirokuEventSubscriptionCaughtUp subName finalPos groupCtx)+ -- Phase 2: live. The strategy depends on (group, target):+ -- * Non-group AllStreams: read pre-broadcast events from+ -- `liveQueue`; the publisher delivers every appended event.+ -- * Non-group Category: bypass the broadcast and re-query the+ -- database whenever `lastPublished` advances.+ -- * Any group (Category or AllStreams): the DB-driven loop.+ -- A partitioned member must see only the events whose+ -- originating stream hashes to its slot; the broadcast+ -- `liveQueue` carries unfiltered $all events and there is no+ -- in-process stream-id -> member map to filter them with+ -- (mirrors the EP-3 F18 rationale). The partition predicate+ -- lives in the SQL, so re-querying with the partitioned+ -- statement on each publisher tick is the correct fit.+ case (consumerGroup config, target config) of+ (Nothing, AllStreams) -> liveLoop pool liveQueue statusVar config emit posRef finalPos+ (Nothing, Category{}) -> liveLoopDbDriven pool config pubPosVar emit posRef finalPos stSettings+ (Just _, _) -> liveLoopDbDriven pool config pubPosVar emit posRef finalPos stSettings++ result <- try body+ pos <- readIORef posRef+ case result of+ Right () -> emit (KirokuEventSubscriptionStopped subName pos StopHandlerRequested groupCtx)+ Left (e :: SomeException) -> do+ emit (KirokuEventSubscriptionStopped subName pos (classifyStopReason e) groupCtx)+ throwIO e++-- The consumer-group context for this config's lifecycle events: 'NonGroup' for+-- an ordinary subscription, @GroupMember member size@ for a group member.+groupCtxOf :: SubscriptionConfig -> SubscriptionGroupContext+groupCtxOf config = maybe NonGroup (\(ConsumerGroup m n) -> GroupMember m n) (consumerGroup config)++{- Startup-only conflict probe for the consumer-group guardrail. Uses a+transaction-scoped advisory lock ('pg_try_advisory_xact_lock') which auto-releases+at transaction end, so it only detects a /concurrent/ holder at this instant. The+key is a stable bigint hash of the @name:member@ pair computed in SQL so all+processes agree. NOTE: this does NOT hold the lock for the worker's lifetime; full+mutual exclusion would need a session-level lock on a dedicated connection (the+'Kiroku.Store.Notification.Notifier' pattern), recorded as follow-up in EP-2's+Decision Log. On a database error the probe degrades open (treats it as "no+conflict") so a transient pool error cannot wedge startup. -}+guardMember :: Pool -> SubscriptionName -> Int32 -> IO ()+guardMember pool subName@(SubscriptionName n) mem = do+ let probe :: Statement (Text, Int32) Bool+ probe =+ preparable+ "SELECT pg_try_advisory_xact_lock(hashtextextended($1 || ':' || $2::text, 0))"+ ( contrazip2+ (E.param (E.nonNullable E.text))+ (E.param (E.nonNullable E.int4))+ )+ (D.singleRow (D.column (D.nonNullable D.bool)))+ result <- Pool.use pool (Session.statement (n, mem) probe)+ case result of+ Right True -> pure () -- got the lock; no concurrent holder right now+ Right False -> throwIO (ConsumerGroupGuardConflict subName mem)+ Left _ -> pure () -- DB error: degrade open (do not block startup)++-- Map an exception to the 'SubscriptionStopReason' the operator should see.+classifyStopReason :: SomeException -> SubscriptionStopReason+classifyStopReason e+ | Just (_ :: SubscriptionOverflowed) <- fromException e = StopOverflowed+ | Just (_ :: Async.AsyncCancelled) <- fromException e = StopCancelled+ | otherwise = StopWorkerCrashed e++-- The consumer-group member index for this config, or 0 for a non-group+-- subscription. We always route checkpoints through the member-aware+-- statements with member 0 for the non-group case, so there is a single code+-- path: EP-1's schema guarantees pre-existing rows are consumer_group_member = 0,+-- so a non-group worker reads and writes the same (name, 0) row it always did.+configMember :: SubscriptionConfig -> Int32+configMember config = maybe 0 member (consumerGroup config)++-- Load the checkpoint from the database, defaulting to 0.+-- Surfaces a database error through the event handler before falling+-- back to the safe default; without the event the operator has no signal+-- that a transient pool error caused a silent re-process from position 0.+-- Keyed by (subscription_name, member) so each group member resumes from its+-- own saved position.+loadCheckpoint ::+ Pool ->+ SubscriptionConfig ->+ (KirokuEvent -> IO ()) ->+ IO GlobalPosition+loadCheckpoint pool config emit = do+ let subName@(SubscriptionName name') = name config+ mem = configMember config+ result <- Pool.use pool (Session.statement (name', mem) SQL.getCheckpointMemberStmt)+ case result of+ Left err -> do+ emit (KirokuEventSubscriptionDbError subName LoadCheckpoint err (groupCtxOf config))+ pure (GlobalPosition 0)+ Right Nothing -> pure (GlobalPosition 0)+ Right (Just pos) -> pure (GlobalPosition pos)++-- Phase 1: catch-up. Queries the database directly in batches until we+-- reach the EventPublisher's current position. Returns Nothing if the+-- handler said Stop, or Just position if catch-up completed normally.+catchUp ::+ Pool ->+ SubscriptionConfig ->+ GlobalPosition ->+ TVar GlobalPosition ->+ (KirokuEvent -> IO ()) ->+ IORef GlobalPosition ->+ StoreSettings ->+ IO (Maybe GlobalPosition)+catchUp pool config startPos pubPosVar emit posRef stSettings = go startPos+ where+ go cursor = do+ writeIORef posRef cursor+ pubPos <- atomically (readTVar pubPosVar)+ if cursor >= pubPos+ then pure (Just cursor)+ else do+ events <- fetchBatch pool config cursor emit stSettings+ if V.null events+ then pure (Just cursor)+ else do+ result <- processEvents pool config events emit posRef+ case result of+ Nothing -> pure Nothing -- handler said Stop+ Just newPos -> go newPos++-- Phase 2: live (AllStreams). Reads from the bounded TBQueue the publisher+-- delivers to. Atomically observes the subscriber's status and surfaces+-- 'SubscriptionOverflowed' if the publisher signalled overflow under+-- 'DropSubscription'.+liveLoop ::+ Pool ->+ TBQueue (Vector RecordedEvent) ->+ TVar SubscriberStatus ->+ SubscriptionConfig ->+ (KirokuEvent -> IO ()) ->+ IORef GlobalPosition ->+ GlobalPosition ->+ IO ()+liveLoop pool liveQueue statusVar config emit posRef startPos = go startPos+ where+ go cursor = do+ writeIORef posRef cursor+ next <- atomically $ do+ status <- readTVar statusVar+ case status of+ Overflowed -> pure (Left ())+ Active -> Right <$> readTBQueue liveQueue+ case next of+ Left () -> throwIO (SubscriptionOverflowed (name config))+ Right events+ | V.null freshEvents -> go cursor+ | otherwise -> do+ result <- processEvents pool config freshEvents emit posRef+ case result of+ Nothing -> pure () -- handler said Stop+ Just newPos -> go newPos+ where+ -- A subscription registers its live queue before catch-up begins.+ -- Events appended during catch-up may therefore be both fetched+ -- from SQL by catch-up and already waiting in the live queue.+ -- Drop those stale queue entries so live mode cannot replay them+ -- or move the checkpoint backward.+ freshEvents = V.filter ((> cursor) . globalPosition) events++-- Phase 2: live (DB-driven). Bypasses the broadcast and re-queries the database+-- whenever `lastPublished` advances, letting `fetchBatch` apply the source-side+-- filter. Serves both non-group `Category` subscriptions (filter by category) and+-- any consumer-group member (filter by the partition predicate baked into the+-- consumer-group SQL), at the cost of one DB round-trip per publisher tick. A+-- partitioned member cannot read the broadcast `liveQueue` because it carries+-- unfiltered $all events and there is no in-process stream-id -> member map to+-- filter them with. See EP-3 F18 / EP-2 Decision Log for the rationale versus+-- extending RecordedEvent or maintaining an in-process cache.+liveLoopDbDriven ::+ Pool ->+ SubscriptionConfig ->+ TVar GlobalPosition ->+ (KirokuEvent -> IO ()) ->+ IORef GlobalPosition ->+ GlobalPosition ->+ StoreSettings ->+ IO ()+liveLoopDbDriven pool config pubPosVar emit posRef startPos stSettings = go startPos+ where+ go cursor = do+ writeIORef posRef cursor+ -- Wait until the publisher has advanced past our cursor.+ atomically $ do+ pubPos <- readTVar pubPosVar+ check (pubPos > cursor)+ events <- fetchBatch pool config cursor emit stSettings+ if V.null events+ then go cursor+ else do+ result <- processEvents pool config events emit posRef+ case result of+ Nothing -> pure () -- handler said Stop+ Just newPos -> go newPos++-- Fetch a batch of events from the database based on subscription target.+-- Surfaces a database error through the event handler before falling back+-- to an empty vector; without the event the catch-up loop sees the empty+-- vector as "no more events" and silently switches to live mode at a stale+-- cursor.+fetchBatch ::+ Pool ->+ SubscriptionConfig ->+ GlobalPosition ->+ (KirokuEvent -> IO ()) ->+ StoreSettings ->+ IO (Vector RecordedEvent)+fetchBatch pool config (GlobalPosition pos) emit stSettings =+ case (consumerGroup config, target config) of+ (Nothing, AllStreams) -> do+ result <- Pool.use pool (Session.statement (pos, batchSize config) SQL.readAllForwardStmt)+ handle result+ (Nothing, Category (CategoryName cat)) -> do+ result <- Pool.use pool (Session.statement (pos, cat, batchSize config) SQL.readCategoryForwardStmt)+ handle result+ (Just (ConsumerGroup m n), AllStreams) -> do+ result <- Pool.use pool (Session.statement (pos, m, n, batchSize config) SQL.readAllForwardConsumerGroupStmt)+ handle result+ (Just (ConsumerGroup m n), Category (CategoryName cat)) -> do+ result <- Pool.use pool (Session.statement (pos, cat, m, n, batchSize config) SQL.readCategoryForwardConsumerGroupStmt)+ handle result+ where+ handle = \case+ Left err -> do+ emit (KirokuEventSubscriptionDbError (name config) FetchBatch err (groupCtxOf config))+ pure V.empty+ -- Apply decodeHook on the catch-up path so catch-up batches are+ -- transformed identically to live batches (which the publisher+ -- transforms once before fan-out).+ Right events -> decodeEvents stSettings events++-- Process a batch of events through the handler. Returns the new cursor+-- position if all events were processed (handler returned Continue for all),+-- or Nothing if the handler returned Stop.+processEvents ::+ Pool ->+ SubscriptionConfig ->+ Vector RecordedEvent ->+ (KirokuEvent -> IO ()) ->+ IORef GlobalPosition ->+ IO (Maybe GlobalPosition)+processEvents pool config events emit posRef = go 0+ where+ go i+ | i >= V.length events = do+ let lastEvent = V.last events+ newPos = globalPosition lastEvent+ writeIORef posRef newPos+ saveCheckpoint pool config newPos emit+ pure (Just newPos)+ | otherwise = do+ let event = events V.! i+ evtPos = globalPosition event+ writeIORef posRef evtPos+ result <- handler config event+ case result of+ Stop -> do+ -- Save checkpoint up to the event we just processed+ saveCheckpoint pool config evtPos emit+ pure Nothing+ Continue -> go (i + 1)++-- Save a checkpoint to the database. Surfaces a database error through+-- the event handler; the worker continues running but the next restart+-- with the same name re-processes events the handler has already seen.+-- Keyed by (subscription_name, member) so each group member persists its own+-- position; non-group subscriptions use member 0 (see 'configMember').+saveCheckpoint ::+ Pool ->+ SubscriptionConfig ->+ GlobalPosition ->+ (KirokuEvent -> IO ()) ->+ IO ()+saveCheckpoint pool config (GlobalPosition pos) emit = do+ let subName@(SubscriptionName name') = name config+ mem = configMember config+ result <- Pool.use pool (Session.statement (name', mem, pos) SQL.saveCheckpointMemberStmt)+ case result of+ Left err -> emit (KirokuEventSubscriptionDbError subName SaveCheckpoint err (groupCtxOf config))+ Right () -> pure ()
+ src/Kiroku/Store/Transaction.hs view
@@ -0,0 +1,320 @@+{- | Transactional combinators that compose a Kiroku event-store+operation with arbitrary additional @hasql-transaction@ work in a+single ACID transaction.++This module is the entry point for callers — most prominently the+@keiro@ projection layer — that need to atomically write to their own+SQL tables in the same transaction as an event append. Three ergonomic+levels are provided:++* 'runTransaction' / 'runTransactionNoRetry' — bare escape hatch: run+ an opaque 'Tx.Transaction' against the store's connection pool.++* 'appendToStreamTx' — a 'Tx.Transaction'-flavored single-stream+ append. Useful inside a 'runTransaction' block when the caller+ wants full control over conflict handling.++* 'runTransactionAppending' / 'runTransactionAppendingNoRetry' — the+ recommended high-level wrapper that combines a single-stream append+ with the caller's 'Tx.Transaction' continuation in one atomic+ transaction. This is the primary API for @keiro@-style projection+ consumers.++The @-NoRetry@ variants use+'Hasql.Transaction.Sessions.transactionNoRetry' under the hood; the+default variants use 'Hasql.Transaction.Sessions.transaction', which+automatically retries the body on PostgreSQL serialization conflicts.+The retry runs the entire 'Tx.Transaction' value more than once. This+is safe for pure-SQL bodies (each retry's prior partial work rolls back+inside Postgres before the next attempt begins) but should be+considered when the caller reasons about external observability.++Mocking: a mock 'Kiroku.Store.Effect.Store' interpreter cannot+meaningfully execute an opaque 'Tx.Transaction' against in-memory state+and is expected to reject 'Kiroku.Store.Effect.RunTransaction' /+'Kiroku.Store.Effect.RunTransactionNoRetry' at runtime.+-}+module Kiroku.Store.Transaction (+ -- * Bare escape hatch+ runTransaction,+ runTransactionNoRetry,++ -- * Tx-flavored append building block+ appendToStreamTx,+ PreparedEvent,+ prepareEventsIO,++ -- * Convenience wrapper for the keiro use case+ runTransactionAppending,+ runTransactionAppendingNoRetry,+ runTransactionAppendingResource,+ runTransactionAppendingResourceNoRetry,++ -- * Manual enrichment for direct 'appendToStreamTx' callers+ enrichEventsIO,++ -- * Append-precondition conflicts+ AppendConflict (..),+ appendConflictToStoreError,+) where++import Control.Lens ((^.))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Functor (($>))+import Data.Generics.Labels ()+import Data.Time.Clock (UTCTime, getCurrentTime)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (send)+import GHC.Stack (HasCallStack)+import Hasql.Transaction qualified as Tx+import Kiroku.Store.Connection (KirokuStore)+import Kiroku.Store.Effect (PreparedEvent, Store (..), appendDispatchTx, buildAppendParams, prepareEvents)+import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore)+import Kiroku.Store.Error (AppendConflict (..), StoreError (..), appendConflictToStoreError, emptyResultConflict)+import Kiroku.Store.Settings qualified as Settings+import Kiroku.Store.Types++{- | Run an arbitrary 'Tx.Transaction' against the store's connection+pool inside a 'BEGIN'/'COMMIT' block.++The body may run /more than once/ if PostgreSQL raises a serialization+conflict — automatic retry is the default behavior of+'Hasql.Transaction.Sessions.transaction'. Use 'runTransactionNoRetry'+when retry is unacceptable (for example, the caller has been promised+exactly-once semantics that an outside observer of intermediate state+could break).++The body executes at 'Hasql.Transaction.Sessions.ReadCommitted'+isolation in 'Hasql.Transaction.Sessions.Write' mode, mirroring the+existing transactional sites in 'Kiroku.Store.Append.appendMultiStream'+and the hard-delete path.++Errors: a hasql 'Hasql.Pool.UsageError' is translated to+'Kiroku.Store.Error.ConnectionError'. Calling 'Tx.condemn' inside the+body marks the transaction for rollback at commit; the call returns the+final value the body produced, but no SQL writes from this transaction+will be visible. Mock interpreters of 'Store' reject this constructor.+-}+runTransaction ::+ (HasCallStack, Store :> es) =>+ Tx.Transaction a ->+ Eff es a+runTransaction tx = send (RunTransaction tx)++{- | Like 'runTransaction' but uses+'Hasql.Transaction.Sessions.transactionNoRetry' — the body is executed+exactly once even on PostgreSQL serialization conflicts. A conflict+surfaces as 'Kiroku.Store.Error.ConnectionError' carrying the underlying+'Hasql.Pool.UsageError'.+-}+runTransactionNoRetry ::+ (HasCallStack, Store :> es) =>+ Tx.Transaction a ->+ Eff es a+runTransactionNoRetry tx = send (RunTransactionNoRetry tx)++-- ---------------------------------------------------------------------------+-- Tx-flavored append+-- ---------------------------------------------------------------------------++{- | Generate UUIDv7s for any 'EventData' lacking a caller-supplied+'eventId' and return the prepared list, ready to feed into+'appendToStreamTx' inside a 'Tx.Transaction'.++'Tx.Transaction' has no 'MonadIO' instance, so UUID generation must+happen /before/ the transaction body runs. This helper is the IO-side+preparation step paired with 'appendToStreamTx'.+-}+prepareEventsIO :: (MonadIO m) => [EventData] -> m [PreparedEvent]+prepareEventsIO = prepareEvents++{- | Append a batch of events to a single stream as part of a larger+'Tx.Transaction'.++The 'Tx.Transaction'-flavored counterpart to+'Kiroku.Store.Append.appendToStream'. It does /not/ enforce the @$all@+reserved-stream check — callers should validate the stream name before+entering the transaction body, or use 'runTransactionAppending', which+performs the rejection up front.++The combinator returns 'Either' instead of throwing because+'Tx.Transaction' has no exception channel. On 'Left' the caller decides+whether to call 'Tx.condemn' to roll back the transaction, branch+around the conflict, or commit (which would persist the rest of the+transaction body without the append).++The events list must be pre-prepared via 'prepareEventsIO' (which+generates UUIDv7s) and the @createdAt@ timestamp must be captured by+the caller prior to entering the transaction body.++Empty event lists are a programming mistake — see+'Kiroku.Store.Append.appendToStream' for the rationale.+-}+appendToStreamTx ::+ StreamName ->+ ExpectedVersion ->+ [PreparedEvent] ->+ UTCTime ->+ Tx.Transaction (Either AppendConflict AppendResult)+appendToStreamTx sn@(StreamName name) expected prepared now = do+ let params = buildAppendParams name now prepared+ mResult <- appendDispatchTx expected params+ pure $ case mResult of+ Just r -> Right r+ Nothing -> Left (emptyResultConflict sn expected)++-- ---------------------------------------------------------------------------+-- Convenience wrapper+-- ---------------------------------------------------------------------------++{- | Append events to a single stream and run an arbitrary+'Tx.Transaction' continuation in one ACID transaction.++This is the recommended API for callers who want to combine an event+append with their own SQL writes (canonical example: a projection row+that must land iff the append commits).++Behavior:++* If the target stream is the reserved @$all@, the call rejects with+ @'Left' ('ReservedStreamName' …)@ /before/ opening any transaction;+ the continuation is not invoked.+* UUIDv7 ids are generated for events with a 'Nothing' 'eventId', and+ the current time is captured, before the transaction begins+ ('Tx.Transaction' has no 'MonadIO' so this prep cannot happen+ inside).+* Inside the transaction, 'appendToStreamTx' is called. On 'Left'+ (version conflict, missing stream, etc.), the transaction is+ 'Tx.condemn'-ed, the continuation is /not/ run, and the call returns+ @'Left' storeErr@.+* On 'Right' the continuation runs with the resulting 'AppendResult'.+ If the continuation calls 'Tx.condemn', the transaction rolls back+ at commit time and no writes — including the event append — are+ visible.+* The transaction body may execute more than once if PostgreSQL raises+ a serialization conflict; use 'runTransactionAppendingNoRetry' to+ disable retry.++Connection-level failures from the @hasql-pool@ layer surface through+the surrounding @'Effectful.Error.Static.Error' 'StoreError'@ effect+('Kiroku.Store.Error.ConnectionError', 'ConnectionLost', etc.), not+through the returned 'Either' — that 'Either' is reserved for semantic+append-precondition conflicts (and the up-front reserved-stream+rejection).++This wrapper does /not/ apply the+'Kiroku.Store.Settings.enrichEvent' hook, because resolving the+'StoreSettings' requires reaching the live 'KirokuStore' handle and the+constraint set here is intentionally minimal. Callers running on a+'Kiroku.Store.Effect.Resource.KirokuStoreResource'-flavored stack and+wanting the hook should use 'runTransactionAppendingResource'; callers+on a bare stack can call 'enrichEventsIO' explicitly before invoking+this wrapper.+-}+runTransactionAppending ::+ (HasCallStack, IOE :> es, Store :> es) =>+ StreamName ->+ ExpectedVersion ->+ [EventData] ->+ (AppendResult -> Tx.Transaction a) ->+ Eff es (Either StoreError a)+runTransactionAppending = runTransactionAppendingWith RunTransaction++{- | Like 'runTransactionAppending' but uses+'Hasql.Transaction.Sessions.transactionNoRetry' under the hood — the+transaction body runs exactly once even on PostgreSQL serialization+conflicts.++Like 'runTransactionAppending', this wrapper bypasses the+'Kiroku.Store.Settings.enrichEvent' hook; see that function's+Haddock for guidance on hooking under different stacks.+-}+runTransactionAppendingNoRetry ::+ (HasCallStack, IOE :> es, Store :> es) =>+ StreamName ->+ ExpectedVersion ->+ [EventData] ->+ (AppendResult -> Tx.Transaction a) ->+ Eff es (Either StoreError a)+runTransactionAppendingNoRetry = runTransactionAppendingWith RunTransactionNoRetry++{- | Hook-aware variant of 'runTransactionAppending' for callers running+under a 'Kiroku.Store.Effect.Resource.KirokuStoreResource' effect.++Behaves exactly like 'runTransactionAppending' except that the+'Kiroku.Store.Settings.enrichEvent' hook (if any) is applied to every+'EventData' before the transaction body opens. The hook fires in+'IO', /outside/ the transaction; subsequent retries of a serialization+conflict do not re-invoke it (the enriched events are already prepared).++This is the recommended path for callers — most prominently the+@keiro@ projection layer — that want trace-context or PII-injection+hooks to fire uniformly across both direct @'appendToStream'@ calls+and transactional append+projection sites.+-}+runTransactionAppendingResource ::+ (HasCallStack, IOE :> es, KirokuStoreResource :> es, Store :> es) =>+ StreamName ->+ ExpectedVersion ->+ [EventData] ->+ (AppendResult -> Tx.Transaction a) ->+ Eff es (Either StoreError a)+runTransactionAppendingResource sn expected events k = do+ store <- getKirokuStore+ events' <- liftIO $ enrichEventsIO store events+ runTransactionAppendingWith RunTransaction sn expected events' k++{- | Like 'runTransactionAppendingResource' but uses+'Hasql.Transaction.Sessions.transactionNoRetry' under the hood.+-}+runTransactionAppendingResourceNoRetry ::+ (HasCallStack, IOE :> es, KirokuStoreResource :> es, Store :> es) =>+ StreamName ->+ ExpectedVersion ->+ [EventData] ->+ (AppendResult -> Tx.Transaction a) ->+ Eff es (Either StoreError a)+runTransactionAppendingResourceNoRetry sn expected events k = do+ store <- getKirokuStore+ events' <- liftIO $ enrichEventsIO store events+ runTransactionAppendingWith RunTransactionNoRetry sn expected events' k++{- | Apply the store's 'Kiroku.Store.Settings.enrichEvent' hook (if any)+to a list of 'EventData' values.++Use this when calling 'appendToStreamTx' directly — that lower-level+API does not see the interpreter and therefore does not run the hook+on its own. Calling 'enrichEventsIO' yourself before+'prepareEventsIO' restores hook coverage for that path.++When 'Kiroku.Store.Settings.enrichEvent' is 'Nothing' the function+returns the input list unchanged with no traversal.+-}+enrichEventsIO :: KirokuStore -> [EventData] -> IO [EventData]+enrichEventsIO store = Settings.enrichEvents (store ^. #storeSettings)++{- | Shared implementation for 'runTransactionAppending' and+'runTransactionAppendingNoRetry'. The only difference between the+two wrappers is which 'Store' constructor is sent.+-}+runTransactionAppendingWith ::+ (IOE :> es, Store :> es) =>+ (forall x. Tx.Transaction x -> Store (Eff es) x) ->+ StreamName ->+ ExpectedVersion ->+ [EventData] ->+ (AppendResult -> Tx.Transaction a) ->+ Eff es (Either StoreError a)+runTransactionAppendingWith ctor sn@(StreamName name) expected events k+ | name == "$all" = pure (Left (ReservedStreamName sn))+ | otherwise = do+ prepared <- prepareEventsIO events+ now <- liftIO getCurrentTime+ let body = do+ outcome <- appendToStreamTx sn expected prepared now+ case outcome of+ Left conflict ->+ Tx.condemn $> Left (appendConflictToStoreError conflict)+ Right ar ->+ Right <$> k ar+ send (ctor body)
+ src/Kiroku/Store/Types.hs view
@@ -0,0 +1,290 @@+module Kiroku.Store.Types (+ StreamName (..),+ StreamId (..),+ EventId (..),+ EventType (..),+ StreamVersion (..),+ GlobalPosition (..),+ ExpectedVersion (..),+ EventData (..),+ RecordedEvent (..),+ StreamInfo (..),+ AppendResult (..),+ LinkResult (..),+ CategoryName (..),+ EventFilter (..),+) where++import Data.Aeson (Value)+import Data.Int (Int64)+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.UUID (UUID)+import GHC.Generics (Generic)++-- Stream identification++{- | The human-readable name of a stream (e.g. @"orders-1"@). Stream names+are unique per store; the substring before the first @-@ is the+stream's category, used by 'CategoryName'-targeted reads and+subscriptions.++All names except @$all@ are ordinary application stream names. Names+such as @"invoice-payment"@, @"$invoice-payment"@, names containing+commas, and names without a dash are accepted by the store. The exact+name @$all@ is reserved for the global read stream and mutating APIs+reject it with 'Kiroku.Store.Error.ReservedStreamName'; use+'Kiroku.Store.Read.readAllForward' or+'Kiroku.Store.Read.readAllBackward' to read the global sequence.+-}+newtype StreamName = StreamName Text+ deriving stock (Eq, Ord, Show, Generic)++{- | The database surrogate id of a stream. Stable for the lifetime of+the stream row; reused by 'hardDeleteStream' followed by re-creation+only at the database's discretion. Not generally used by application+code — prefer 'StreamName' for identification.+-}+newtype StreamId = StreamId Int64+ deriving stock (Eq, Ord, Show, Generic)++-- Event identification++{- | The store's identifier for an event. Generated by the store as a+UUIDv7 unless the caller supplies one in 'EventData.eventId' (used for+idempotent retries — see 'appendToStream').++The 'Ord' instance compares by raw UUID byte order, /not/ by+generation time. UUIDv7 is timestamp-prefixed in its high bytes, so+byte order roughly matches generation order, but two ids generated in+the same millisecond can compare in either direction. For+time-ordering use 'RecordedEvent.globalPosition'.+-}+newtype EventId = EventId UUID+ deriving stock (Eq, Ord, Show, Generic)++{- | The application-level discriminator for an event payload (e.g.+@"OrderCreated"@). Free-form text; the store does not interpret it.+-}+newtype EventType = EventType Text+ deriving stock (Eq, Ord, Show, Generic)++-- Positions++{- | Monotonic per-stream version counter. Starts at 0 for a freshly+created empty stream and increments by one per appended event. After+@N@ events, the stream's version is @N@; the @i@-th event has+@streamVersion = i@ (one-indexed within a stream).+-}+newtype StreamVersion = StreamVersion Int64+ deriving stock (Eq, Ord, Show, Generic)++{- | Monotonic global position counter, shared across all streams.+Strictly increasing per successful append; gap-free under all four+'ExpectedVersion' paths (see EP-1's audit). Used by the @$all@ read+path and by subscriptions as the cursor key.+-}+newtype GlobalPosition = GlobalPosition Int64+ deriving stock (Eq, Ord, Show, Generic)++{- | Version expectations for appends.++The store enforces optimistic concurrency at the stream level: each+'appendToStream' call carries an 'ExpectedVersion' that the+@stream_version@ row must satisfy at commit time. A mismatch produces+'Kiroku.Store.Error.WrongExpectedVersion' or+'Kiroku.Store.Error.StreamAlreadyExists' depending on the constructor.+-}+data ExpectedVersion+ = {- | The stream must not exist yet. Creates the stream and appends+ the events. Fails with+ 'Kiroku.Store.Error.StreamAlreadyExists' if the stream is+ already present, including soft-deleted streams. Use this for+ aggregate creation.+ -}+ NoStream+ | {- | The stream must already exist (and not be soft-deleted), but+ its current version does not matter. Fails with+ 'Kiroku.Store.Error.StreamNotFound' if the stream is missing+ or soft-deleted.+ -}+ StreamExists+ | {- | The stream's current version must match exactly. Use this+ when the caller has read the stream and wants to append only+ if no concurrent writer has advanced it. Fails with+ 'Kiroku.Store.Error.WrongExpectedVersion' on mismatch.+ -}+ ExactVersion !StreamVersion+ | {- | Upsert: create the stream if missing, append otherwise. Does+ not check the existing version. Maps to a single+ @INSERT ... ON CONFLICT DO UPDATE@ at the SQL layer. The name+ is historical — \"create-or-append\" is the working+ description.+ -}+ AnyVersion+ deriving stock (Eq, Show, Generic)++{- | What the caller provides when appending events.++Field accessors are intended to be used through @generic-lens@ labels+(@event ^. #eventType@); the cabal common stanza enables+@DuplicateRecordFields@ and @OverloadedLabels@ so the same field names+can appear on both 'EventData' and 'RecordedEvent'.+-}+data EventData = EventData+ { eventId :: !(Maybe EventId)+ {- ^ 'Nothing' lets the store generate a UUIDv7 at append time. 'Just'+ lets the caller supply an id, primarily to make appends idempotent+ across transient failures: a retry with the same id either succeeds+ (because the previous attempt did not commit) or surfaces as+ 'Kiroku.Store.Error.DuplicateEvent' (because it did).+ -}+ , eventType :: !EventType+ {- ^ Application-level discriminator. Free-form; the store does not+ interpret it but it is indexed for queries.+ -}+ , payload :: !Value+ -- ^ The event's JSONB payload.+ , metadata :: !(Maybe Value)+ {- ^ Optional JSONB metadata. Often used for tenant ids, trace+ contexts, and correlation data.+ -}+ , causationId :: !(Maybe UUID)+ {- ^ Optional id of the event that caused this one (the immediate+ cause). Used to reconstruct chains.+ -}+ , correlationId :: !(Maybe UUID)+ {- ^ Optional correlation id (the saga / transaction this event+ belongs to). Distinct from @causationId@.+ -}+ }+ deriving stock (Show, Generic)++{- | Stream metadata returned by 'getStream'.++The 'id' field shadows 'Prelude.id' under 'DuplicateRecordFields'; access+it via @info ^. #id@ to disambiguate. 'Prelude.id' remains available as+@Data.Function.id@ if needed.+-}+data StreamInfo = StreamInfo+ { id :: !StreamId+ {- ^ The stream's database surrogate id. Stable for the row's+ lifetime.+ -}+ , name :: !StreamName+ -- ^ The stream's human-readable name as supplied at creation.+ , version :: !StreamVersion+ -- ^ The stream's current version (count of appended events).+ , createdAt :: !UTCTime+ -- ^ When the stream row was first inserted.+ , deletedAt :: !(Maybe UTCTime)+ {- ^ 'Just' the soft-delete timestamp if the stream has been+ soft-deleted, 'Nothing' otherwise. Hard-deleted streams do not+ appear in 'getStream' at all.+ -}+ }+ deriving stock (Eq, Show, Generic)++{- | What comes back from reading events.++For events read from their /source/ stream, @streamVersion@ and+@originalVersion@ agree, and @originalStreamId@ matches the stream being+read. For events read from a /linked/ target stream (one populated by+'linkToStream'), @streamVersion@ is the target's version (the position+of the link in the target stream) while @originalVersion@ is the+source's version (where the event lived when first appended) and+@originalStreamId@ is the source's id. Subscriptions and category reads+return events at their source positions.+-}+data RecordedEvent = RecordedEvent+ { eventId :: !EventId+ -- ^ The event's stable id (UUIDv7 by default).+ , eventType :: !EventType+ -- ^ The application-level type discriminator.+ , streamVersion :: !StreamVersion+ {- ^ Position in the stream being read. For source-stream reads this+ equals @originalVersion@; for linked-target reads it is the+ link's position in the target.+ -}+ , globalPosition :: !GlobalPosition+ {- ^ Position in the global @$all@ sequence at original-append time.+ Stable across links; used as the subscription cursor.+ -}+ , originalStreamId :: !StreamId+ {- ^ The surrogate id of the stream the event was first appended to. For+ fan-in reads (@$all@, categories, causation\/correlation queries,+ subscriptions) this is the only stream identifier on the event; resolve a+ batch of these to human-readable 'StreamName's with+ 'Kiroku.Store.Read.lookupStreamNames'.+ -}+ , originalVersion :: !StreamVersion+ -- ^ The position the event was assigned in its source stream.+ , payload :: !Value+ , metadata :: !(Maybe Value)+ , causationId :: !(Maybe UUID)+ , correlationId :: !(Maybe UUID)+ , createdAt :: !UTCTime+ }+ deriving stock (Eq, Show, Generic)++-- | Result of a successful 'appendToStream' or 'appendMultiStream' call.+data AppendResult = AppendResult+ { streamId :: !StreamId+ {- ^ The id of the stream that was appended to (created if it did+ not exist).+ -}+ , streamVersion :: !StreamVersion+ {- ^ The stream's version after the append (the position of the+ /last/ event in the batch).+ -}+ , globalPosition :: !GlobalPosition+ -- ^ The global position assigned to the /last/ event in the batch.+ }+ deriving stock (Eq, Show, Generic)++{- | Result of a successful 'linkToStream' call.++There is no @globalPosition@ field because linking does not advance the+global counter — the linked events keep their original+'globalPosition'. To enumerate the new positions of linked events, read+the target stream after the call.+-}+data LinkResult = LinkResult+ { streamId :: !StreamId+ -- ^ The id of the link target (created if it did not exist).+ , streamVersion :: !StreamVersion+ {- ^ The target's version after the link (position of the /last/+ linked event in the target).+ -}+ }+ deriving stock (Eq, Show, Generic)++{- | The category prefix of a stream name (the part before the first+@-@). E.g., @StreamName "orders-1"@ has @CategoryName "orders"@. Used by+'readCategory' and category-targeted subscriptions to fan-in events from+many streams that share a prefix.+-}+newtype CategoryName = CategoryName Text+ deriving stock (Eq, Ord, Show, Generic)++{- | Filter passed to the 'Kiroku.Store.Effect.FindEvents' constructor and the+public smart constructors in "Kiroku.Store.Causation". Each constructor maps+to one SQL statement in "Kiroku.Store.SQL".++The sum is closed: mock interpreters that implement 'Kiroku.Store.Effect.Store'+can pattern-match exhaustively. Adding a new filter is a breaking change for+downstream interpreters and is captured by GHC's exhaustiveness check.+-}+data EventFilter+ = -- | Match every event whose @correlation_id@ equals the supplied UUID.+ FilterCorrelation !UUID+ | {- | Match the seed event and every event whose @causation_id@ chain+ walks back to it. The seed event itself is included as the depth-0+ row when it exists.+ -}+ FilterCausationDescendants !EventId+ | {- | Match the seed event and every event reachable by walking+ @causation_id@ upward from the seed. The seed itself is included.+ -}+ FilterCausationAncestors !EventId+ deriving stock (Eq, Show, Generic)
+ test/Main.hs view
@@ -0,0 +1,1795 @@+module Main where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM (atomically, check, newTVarIO, readTVar, writeTVar)+import Control.Exception (SomeException)+import Control.Exception qualified+import Control.Lens ((&), (.~), (^.))+import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Data.Aeson (Value (..))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int64)+import Data.Text qualified as T+import Data.UUID qualified as UUID+import Data.Vector qualified as V+import Effectful (Eff, IOE, runEff, (:>))+import Effectful.Error.Static (runErrorNoCallStack)+import EphemeralPg qualified as Pg+import Kiroku.Store+import Kiroku.Store.Error (extractStreamNameFromDetail)+import Kiroku.Store.Subscription.Effect qualified as SubEff+import Kiroku.Store.Subscription.EventPublisher (publisherPosition)+import Kiroku.Store.Subscription.Types (OverflowPolicy (..), SubscriptionConfigM (..), SubscriptionOverflowed (..))+import Test.Causation qualified as Causation+import Test.Concurrency qualified as Concurrency+import Test.ConsumerGroup qualified as ConsumerGroup+import Test.ConsumerGroupEffect qualified as ConsumerGroupEffect+import Test.ConsumerGroupSql qualified as ConsumerGroupSql+import Test.FailureInjection qualified as FailureInjection+import Test.Helpers+import Test.Hspec+import Test.InterpreterHooks qualified as InterpreterHooks+import Test.Properties qualified as Properties+import Test.ReadStream qualified as ReadStream+import Test.StreamNameLookup qualified as StreamNameLookup+import Test.Transaction qualified as Transaction++main :: IO ()+main = withSharedMigratedPostgres $ hspec $ do+ Properties.spec+ Concurrency.spec+ FailureInjection.spec+ Transaction.spec+ ReadStream.spec+ StreamNameLookup.spec+ InterpreterHooks.spec+ Causation.spec+ ConsumerGroupSql.spec+ ConsumerGroup.spec+ ConsumerGroupEffect.spec+ around withTestStore $ do+ describe "schema migrations" $ do+ it "installs every Kiroku table under the kiroku schema" $ \store -> do+ let tables = ["streams", "events", "stream_events", "subscriptions"]+ results <- mapM (\t -> tableExists store ("kiroku." <> t)) tables+ results `shouldBe` replicate (length tables) True++ it "leaves the public schema free of Kiroku tables" $ \store -> do+ let tables = ["streams", "events", "stream_events", "subscriptions"]+ results <- mapM (\t -> tableExists store ("public." <> t)) tables+ results `shouldBe` replicate (length tables) False++ it "provides a UUIDv7 database default for direct event inserts" $ \store -> do+ eventIdText <- insertEventUsingDefaultId store+ version <- serverVersionNum store+ let isV7 = T.length eventIdText > 14 && T.index eventIdText 14 == '7'+ unless isV7 $+ expectationFailure+ ( "expected database-generated event_id to be UUIDv7 on PostgreSQL "+ <> T.unpack version+ <> ", got "+ <> T.unpack eventIdText+ )++ describe "appendToStream" $ do+ describe "NoStream" $ do+ it "creates a new stream and appends events" $ \store -> do+ let event = makeEvent "OrderCreated" (Aeson.object [("orderId", Aeson.String "123")])+ result <- runStoreIO store $ appendToStream (StreamName "order-123") NoStream [event]+ case result of+ Left err -> expectationFailure ("Expected success, got: " <> show err)+ Right r -> do+ (r ^. #streamVersion) `shouldBe` StreamVersion 1+ (r ^. #globalPosition) `shouldBe` GlobalPosition 1++ it "fails when stream already exists" $ \store -> do+ _ <- runStoreIO store $ appendToStream (StreamName "order-456") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+ result <- runStoreIO store $ appendToStream (StreamName "order-456") NoStream [makeEvent "OrderUpdated" (Aeson.object [])]+ case result of+ Left (StreamAlreadyExists _) -> pure ()+ other -> expectationFailure ("Expected StreamAlreadyExists, got: " <> show other)++ describe "ExactVersion" $ do+ it "appends when version matches" $ \store -> do+ Right r1 <- runStoreIO store $ appendToStream (StreamName "order-789") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+ (r1 ^. #streamVersion) `shouldBe` StreamVersion 1++ result <- runStoreIO store $ appendToStream (StreamName "order-789") (ExactVersion (StreamVersion 1)) [makeEvent "OrderUpdated" (Aeson.object [])]+ case result of+ Left err -> expectationFailure ("Expected success, got: " <> show err)+ Right r -> do+ (r ^. #streamVersion) `shouldBe` StreamVersion 2+ (r ^. #globalPosition) `shouldBe` GlobalPosition 2++ it "fails on version conflict" $ \store -> do+ _ <- runStoreIO store $ appendToStream (StreamName "order-conflict") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+ result <- runStoreIO store $ appendToStream (StreamName "order-conflict") (ExactVersion (StreamVersion 0)) [makeEvent "OrderUpdated" (Aeson.object [])]+ case result of+ Left (WrongExpectedVersion _ _ _) -> pure ()+ other -> expectationFailure ("Expected WrongExpectedVersion, got: " <> show other)++ describe "StreamExists" $ do+ it "appends to an existing stream" $ \store -> do+ _ <- runStoreIO store $ appendToStream (StreamName "stream-exists-test") NoStream [makeEvent "Created" (Aeson.object [])]+ result <- runStoreIO store $ appendToStream (StreamName "stream-exists-test") StreamExists [makeEvent "Updated" (Aeson.object [])]+ case result of+ Left err -> expectationFailure ("Expected success, got: " <> show err)+ Right r -> (r ^. #streamVersion) `shouldBe` StreamVersion 2++ it "fails when stream does not exist" $ \store -> do+ result <- runStoreIO store $ appendToStream (StreamName "nonexistent-stream") StreamExists [makeEvent "Created" (Aeson.object [])]+ case result of+ Left (StreamNotFound _) -> pure ()+ other -> expectationFailure ("Expected StreamNotFound, got: " <> show other)++ describe "AnyVersion" $ do+ it "creates a new stream" $ \store -> do+ result <- runStoreIO store $ appendToStream (StreamName "any-new") AnyVersion [makeEvent "Created" (Aeson.object [])]+ case result of+ Left err -> expectationFailure ("Expected success, got: " <> show err)+ Right r -> (r ^. #streamVersion) `shouldBe` StreamVersion 1++ it "appends to an existing stream" $ \store -> do+ _ <- runStoreIO store $ appendToStream (StreamName "any-existing") AnyVersion [makeEvent "Created" (Aeson.object [])]+ result <- runStoreIO store $ appendToStream (StreamName "any-existing") AnyVersion [makeEvent "Updated" (Aeson.object [])]+ case result of+ Left err -> expectationFailure ("Expected success, got: " <> show err)+ Right r -> (r ^. #streamVersion) `shouldBe` StreamVersion 2++ describe "batch append" $ do+ it "appends multiple events with sequential versions" $ \store -> do+ let events =+ [ makeEvent "Event1" (Aeson.object [("n", Aeson.Number 1)])+ , makeEvent "Event2" (Aeson.object [("n", Aeson.Number 2)])+ , makeEvent "Event3" (Aeson.object [("n", Aeson.Number 3)])+ ]+ result <- runStoreIO store $ appendToStream (StreamName "batch-test") NoStream events+ case result of+ Left err -> expectationFailure ("Expected success, got: " <> show err)+ Right r -> do+ (r ^. #streamVersion) `shouldBe` StreamVersion 3+ (r ^. #globalPosition) `shouldBe` GlobalPosition 3++ describe "global position contiguity" $ do+ it "assigns contiguous global positions across streams" $ \store -> do+ Right r1 <- runStoreIO store $ appendToStream (StreamName "stream-a") NoStream [makeEvent "A" (Aeson.object [])]+ (r1 ^. #globalPosition) `shouldBe` GlobalPosition 1++ Right r2 <- runStoreIO store $ appendToStream (StreamName "stream-b") NoStream [makeEvent "B" (Aeson.object [])]+ (r2 ^. #globalPosition) `shouldBe` GlobalPosition 2++ Right r3 <- runStoreIO store $ appendToStream (StreamName "stream-c") NoStream [makeEvent "C" (Aeson.object [])]+ (r3 ^. #globalPosition) `shouldBe` GlobalPosition 3++ describe "duplicate event ID" $ do+ it "rejects duplicate event IDs" $ \store -> do+ let eid = EventId (case UUID.fromString "01234567-89ab-7def-8012-34567890abcd" of Just u -> u; Nothing -> error "bad uuid")+ let event1 =+ EventData+ { eventId = Just eid+ , eventType = EventType "Created"+ , payload = Aeson.object []+ , metadata = Nothing+ , causationId = Nothing+ , correlationId = Nothing+ }+ Right _ <- runStoreIO store $ appendToStream (StreamName "dup-test-1") NoStream [event1]++ let event2 =+ EventData+ { eventId = Just eid+ , eventType = EventType "Created"+ , payload = Aeson.object []+ , metadata = Nothing+ , causationId = Nothing+ , correlationId = Nothing+ }+ result <- runStoreIO store $ appendToStream (StreamName "dup-test-2") NoStream [event2]+ case result of+ Left (DuplicateEvent _) -> pure ()+ other -> expectationFailure ("Expected DuplicateEvent, got: " <> show other)++ describe "stream-name contract" $ do+ it "treats system-looking names other than $all as ordinary streams" $ \store -> do+ let names =+ [ StreamName "invoice-payment"+ , StreamName "$invoice-payment"+ , StreamName "invoice,payment"+ , StreamName "invoicepayment"+ ]+ mapM_+ ( \name -> do+ Right r <- runStoreIO store $ appendToStream name NoStream [makeEvent "StreamNameContract" (Aeson.object [])]+ (r ^. #streamVersion) `shouldBe` StreamVersion 1+ Right events <- runStoreIO store $ readStreamForward name (StreamVersion 0) 10+ V.length events `shouldBe` 1+ )+ names++ it "rejects $all as an application append target" $ \store -> do+ result <- runStoreIO store $ appendToStream (StreamName "$all") AnyVersion [makeEvent "BadAllAppend" (Aeson.object [])]+ case result of+ Left (ReservedStreamName (StreamName "$all")) -> pure ()+ other -> expectationFailure ("Expected ReservedStreamName for $all append, got: " <> show other)+ Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 10+ V.length allEvents `shouldBe` 0++ it "rejects $all as a multi-stream append target without partial commit" $ \store -> do+ result <-+ runStoreIO store $+ appendMultiStream+ [ (StreamName "multi-reserved-ok", NoStream, [makeEvent "ShouldRollback" (Aeson.object [])])+ , (StreamName "$all", AnyVersion, [makeEvent "BadAllMulti" (Aeson.object [])])+ ]+ case result of+ Left (ReservedStreamName (StreamName "$all")) -> pure ()+ other -> expectationFailure ("Expected ReservedStreamName for $all multi-stream append, got: " <> show other)+ Right info <- runStoreIO store $ getStream (StreamName "multi-reserved-ok")+ info `shouldBe` Nothing++ it "rejects $all as a link target" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "reserved-link-source") NoStream [makeEvent "Source" (Aeson.object [])]+ Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "reserved-link-source") (StreamVersion 0) 10+ let eid = V.head srcEvents ^. #eventId+ result <- runStoreIO store $ linkToStream (StreamName "$all") [eid]+ case result of+ Left (ReservedStreamName (StreamName "$all")) -> pure ()+ other -> expectationFailure ("Expected ReservedStreamName for $all link, got: " <> show other)+ Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 10+ V.length allEvents `shouldBe` 1++ it "rejects lifecycle operations against $all" $ \store -> do+ soft <- runStoreIO store $ softDeleteStream (StreamName "$all")+ hard <- runStoreIO store $ hardDeleteStream (StreamName "$all")+ undel <- runStoreIO store $ undeleteStream (StreamName "$all")+ let shouldBeReserved label result =+ case result of+ Left (ReservedStreamName (StreamName "$all")) -> pure ()+ other -> expectationFailure ("Expected ReservedStreamName for " <> label <> ", got: " <> show other)+ shouldBeReserved "softDeleteStream $all" soft+ shouldBeReserved "hardDeleteStream $all" hard+ shouldBeReserved "undeleteStream $all" undel+ Right info <- runStoreIO store $ getStream (StreamName "$all")+ case info of+ Just si -> (si ^. #deletedAt) `shouldBe` Nothing+ Nothing -> expectationFailure "Expected reserved $all stream row to remain present"++ describe "readStreamForward" $ do+ it "reads events in forward order (read-your-own-writes)" $ \store -> do+ let events =+ [ makeEvent "A" (Aeson.object [("n", Aeson.Number 1)])+ , makeEvent "B" (Aeson.object [("n", Aeson.Number 2)])+ , makeEvent "C" (Aeson.object [("n", Aeson.Number 3)])+ ]+ Right _ <- runStoreIO store $ appendToStream (StreamName "read-fwd") NoStream events+ Right result <- runStoreIO store $ readStreamForward (StreamName "read-fwd") (StreamVersion 0) 100+ V.length result `shouldBe` 3+ (V.head result ^. #eventType) `shouldBe` EventType "A"+ (result V.! 1 ^. #eventType) `shouldBe` EventType "B"+ (result V.! 2 ^. #eventType) `shouldBe` EventType "C"+ (V.head result ^. #streamVersion) `shouldBe` StreamVersion 1+ (result V.! 1 ^. #streamVersion) `shouldBe` StreamVersion 2+ (result V.! 2 ^. #streamVersion) `shouldBe` StreamVersion 3++ describe "readStreamBackward" $ do+ it "reads events in backward order" $ \store -> do+ let events =+ [ makeEvent "A" (Aeson.object [])+ , makeEvent "B" (Aeson.object [])+ , makeEvent "C" (Aeson.object [])+ ]+ Right _ <- runStoreIO store $ appendToStream (StreamName "read-bwd") NoStream events+ Right result <- runStoreIO store $ readStreamBackward (StreamName "read-bwd") (StreamVersion 0) 100+ V.length result `shouldBe` 3+ (V.head result ^. #eventType) `shouldBe` EventType "C"+ (result V.! 1 ^. #eventType) `shouldBe` EventType "B"+ (result V.! 2 ^. #eventType) `shouldBe` EventType "A"+ (V.head result ^. #streamVersion) `shouldBe` StreamVersion 3+ (result V.! 1 ^. #streamVersion) `shouldBe` StreamVersion 2+ (result V.! 2 ^. #streamVersion) `shouldBe` StreamVersion 1++ describe "cursor-based pagination" $ do+ it "paginates using stream version as cursor" $ \store -> do+ let events = map (\i -> makeEvent ("E" <> T.pack (show i)) (Aeson.object [])) [1 .. 5 :: Int]+ Right _ <- runStoreIO store $ appendToStream (StreamName "read-page") NoStream events+ -- Read first page of 2+ Right page1 <- runStoreIO store $ readStreamForward (StreamName "read-page") (StreamVersion 0) 2+ V.length page1 `shouldBe` 2+ let cursor1 = page1 V.! 1 ^. #streamVersion+ cursor1 `shouldBe` StreamVersion 2+ -- Read second page from cursor+ Right page2 <- runStoreIO store $ readStreamForward (StreamName "read-page") cursor1 2+ V.length page2 `shouldBe` 2+ (V.head page2 ^. #streamVersion) `shouldBe` StreamVersion 3+ -- Read third page — only 1 event left+ let cursor2 = page2 V.! 1 ^. #streamVersion+ Right page3 <- runStoreIO store $ readStreamForward (StreamName "read-page") cursor2 2+ V.length page3 `shouldBe` 1+ -- Read past end — empty+ let cursor3 = V.head page3 ^. #streamVersion+ Right page4 <- runStoreIO store $ readStreamForward (StreamName "read-page") cursor3 2+ V.length page4 `shouldBe` 0++ describe "readAllForward" $ do+ it "reads events from $all in global order" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "all-s1") NoStream [makeEvent "X" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "all-s2") NoStream [makeEvent "Y" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "all-s3") NoStream [makeEvent "Z" (Aeson.object [])]+ Right result <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ V.length result `shouldBe` 3+ (V.head result ^. #eventType) `shouldBe` EventType "X"+ (result V.! 1 ^. #eventType) `shouldBe` EventType "Y"+ (result V.! 2 ^. #eventType) `shouldBe` EventType "Z"+ -- Global positions should be contiguous+ (V.head result ^. #globalPosition) `shouldBe` GlobalPosition 1+ (result V.! 1 ^. #globalPosition) `shouldBe` GlobalPosition 2+ (result V.! 2 ^. #globalPosition) `shouldBe` GlobalPosition 3++ describe "readAllBackward" $ do+ it "reads events from $all in reverse order" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "allb-s1") NoStream [makeEvent "X" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "allb-s2") NoStream [makeEvent "Y" (Aeson.object [])]+ Right result <- runStoreIO store $ readAllBackward (GlobalPosition 0) 100+ V.length result `shouldBe` 2+ (V.head result ^. #eventType) `shouldBe` EventType "Y"+ (result V.! 1 ^. #eventType) `shouldBe` EventType "X"++ describe "read empty/nonexistent stream" $ do+ it "returns empty Vector for nonexistent stream" $ \store -> do+ Right result <- runStoreIO store $ readStreamForward (StreamName "no-such-stream") (StreamVersion 0) 100+ V.length result `shouldBe` 0++ describe "getStream" $ do+ it "returns metadata for existing stream" $ \store -> do+ Right _ <-+ runStoreIO store $+ appendToStream+ (StreamName "meta-test")+ NoStream+ [ makeEvent "A" (Aeson.object [])+ , makeEvent "B" (Aeson.object [])+ ]+ Right info <- runStoreIO store $ getStream (StreamName "meta-test")+ case info of+ Just si -> do+ (si ^. #name) `shouldBe` StreamName "meta-test"+ (si ^. #version) `shouldBe` StreamVersion 2+ Nothing -> expectationFailure "Expected Just StreamInfo, got Nothing"++ it "returns Nothing for nonexistent stream" $ \store -> do+ Right info <- runStoreIO store $ getStream (StreamName "no-such-stream")+ info `shouldBe` Nothing++ describe "lookupStreamId" $ do+ it "returns the same id as getStream for a live stream" $ \store -> do+ Right _ <-+ runStoreIO store $+ appendToStream+ (StreamName "lookup-live")+ NoStream+ [makeEvent "A" (Aeson.object [])]+ Right mInfo <- runStoreIO store $ getStream (StreamName "lookup-live")+ Right mSid <- runStoreIO store $ lookupStreamId (StreamName "lookup-live")+ case (mInfo, mSid) of+ (Just info, Just sid) ->+ (info ^. #id) `shouldBe` sid+ _ ->+ expectationFailure "Expected both getStream and lookupStreamId to return Just"++ it "returns Nothing for a stream that has never been created" $ \store -> do+ Right mSid <- runStoreIO store $ lookupStreamId (StreamName "lookup-missing")+ mSid `shouldBe` Nothing++ it "returns Just the same id for a soft-deleted stream" $ \store -> do+ Right _ <-+ runStoreIO store $+ appendToStream+ (StreamName "lookup-soft")+ NoStream+ [makeEvent "A" (Aeson.object [])]+ Right mSidBefore <- runStoreIO store $ lookupStreamId (StreamName "lookup-soft")+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "lookup-soft")+ Right mSidAfter <- runStoreIO store $ lookupStreamId (StreamName "lookup-soft")+ mSidAfter `shouldBe` mSidBefore+ Right mInfo <- runStoreIO store $ getStream (StreamName "lookup-soft")+ case (mInfo, mSidAfter) of+ (Just info, Just sid) -> (info ^. #id) `shouldBe` sid+ _ -> expectationFailure "Expected Just on a soft-deleted stream"++ describe "integration: full lifecycle through withStore" $ do+ it "append, read forward, read $all, getStream — all through public API" $ \store -> do+ -- Append events to two streams+ Right _ <-+ runStoreIO store $+ appendToStream+ (StreamName "integ-orders")+ NoStream+ [ makeEvent "OrderCreated" (Aeson.object [("id", Aeson.String "1")])+ , makeEvent "OrderShipped" (Aeson.object [("id", Aeson.String "1")])+ ]+ Right _ <-+ runStoreIO store $+ appendToStream+ (StreamName "integ-users")+ NoStream+ [ makeEvent "UserRegistered" (Aeson.object [("name", Aeson.String "alice")])+ ]++ -- Read from a named stream+ Right orders <- runStoreIO store $ readStreamForward (StreamName "integ-orders") (StreamVersion 0) 100+ V.length orders `shouldBe` 2+ (V.head orders ^. #eventType) `shouldBe` EventType "OrderCreated"+ (orders V.! 1 ^. #eventType) `shouldBe` EventType "OrderShipped"++ -- Read from $all — should see all 3 events in global order+ Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ V.length allEvents `shouldBe` 3+ (V.head allEvents ^. #globalPosition) `shouldBe` GlobalPosition 1+ (allEvents V.! 2 ^. #globalPosition) `shouldBe` GlobalPosition 3++ -- Query stream metadata+ Right orderInfo <- runStoreIO store $ getStream (StreamName "integ-orders")+ case orderInfo of+ Just si -> (si ^. #version) `shouldBe` StreamVersion 2+ Nothing -> expectationFailure "Expected stream info"++ Right noInfo <- runStoreIO store $ getStream (StreamName "nonexistent")+ noInfo `shouldBe` Nothing++ -- =================================================================+ -- Link tests (M5.8)+ -- =================================================================+ describe "linkToStream" $ do+ it "links a single event to a new stream" $ \store -> do+ let event = makeEvent "OrderCreated" (Aeson.object [("id", Aeson.String "1")])+ Right appendR <- runStoreIO store $ appendToStream (StreamName "source-1") NoStream [event]+ -- Read back to get the event ID+ Right events <- runStoreIO store $ readStreamForward (StreamName "source-1") (StreamVersion 0) 100+ let eid = V.head events ^. #eventId+ -- Link it+ Right linkR <- runStoreIO store $ linkToStream (StreamName "linked-1") [eid]+ (linkR ^. #streamVersion) `shouldBe` StreamVersion 1+ -- Read the linked stream+ Right linked <- runStoreIO store $ readStreamForward (StreamName "linked-1") (StreamVersion 0) 100+ V.length linked `shouldBe` 1+ (V.head linked ^. #eventId) `shouldBe` eid+ (V.head linked ^. #originalStreamId) `shouldBe` (appendR ^. #streamId)+ (V.head linked ^. #originalVersion) `shouldBe` StreamVersion 1++ it "links multiple events with sequential versions" $ \store -> do+ let events =+ [ makeEvent "A" (Aeson.object [])+ , makeEvent "B" (Aeson.object [])+ , makeEvent "C" (Aeson.object [])+ ]+ Right _ <- runStoreIO store $ appendToStream (StreamName "source-multi") NoStream events+ Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "source-multi") (StreamVersion 0) 100+ let eids = V.toList (V.map (^. #eventId) srcEvents)+ Right linkR <- runStoreIO store $ linkToStream (StreamName "linked-multi") eids+ (linkR ^. #streamVersion) `shouldBe` StreamVersion 3+ Right linked <- runStoreIO store $ readStreamForward (StreamName "linked-multi") (StreamVersion 0) 100+ V.length linked `shouldBe` 3+ (V.head linked ^. #streamVersion) `shouldBe` StreamVersion 1+ (linked V.! 1 ^. #streamVersion) `shouldBe` StreamVersion 2+ (linked V.! 2 ^. #streamVersion) `shouldBe` StreamVersion 3++ it "links events to an existing stream and bumps version" $ \store -> do+ let events1 = [makeEvent "A" (Aeson.object [])]+ events2 = [makeEvent "B" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "src-a") NoStream events1+ Right _ <- runStoreIO store $ appendToStream (StreamName "src-b") NoStream events2+ Right evA <- runStoreIO store $ readStreamForward (StreamName "src-a") (StreamVersion 0) 100+ Right evB <- runStoreIO store $ readStreamForward (StreamName "src-b") (StreamVersion 0) 100+ let eidA = V.head evA ^. #eventId+ eidB = V.head evB ^. #eventId+ -- Link first event+ Right r1 <- runStoreIO store $ linkToStream (StreamName "linked-existing") [eidA]+ (r1 ^. #streamVersion) `shouldBe` StreamVersion 1+ -- Link second event to same stream+ Right r2 <- runStoreIO store $ linkToStream (StreamName "linked-existing") [eidB]+ (r2 ^. #streamVersion) `shouldBe` StreamVersion 2+ -- Read all linked events+ Right linked <- runStoreIO store $ readStreamForward (StreamName "linked-existing") (StreamVersion 0) 100+ V.length linked `shouldBe` 2++ it "linked events still appear in $all at original global positions" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "orig-all") NoStream [makeEvent "X" (Aeson.object [])]+ Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "orig-all") (StreamVersion 0) 100+ let eid = V.head srcEvents ^. #eventId+ _ <- runStoreIO store $ linkToStream (StreamName "linked-all") [eid]+ -- Read $all — should have exactly 1 event (not duplicated)+ Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ let matchingEvents = V.filter (\e -> (e ^. #eventId) == eid) allEvents+ V.length matchingEvents `shouldBe` 1++ it "rejects linking the same event to the same stream twice" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "src-dup") NoStream [makeEvent "X" (Aeson.object [])]+ Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "src-dup") (StreamVersion 0) 100+ let eid = V.head srcEvents ^. #eventId+ Right _ <- runStoreIO store $ linkToStream (StreamName "linked-dup") [eid]+ result <- runStoreIO store $ linkToStream (StreamName "linked-dup") [eid]+ case result of+ Left _ -> pure () -- Expected: some error (PK violation)+ Right _ -> expectationFailure "Expected error for duplicate link"++ -- F3 regression — silent version gap when source events do not exist.+ -- Before the fix, the CTE's `JOIN LATERAL` silently dropped link rows for+ -- event_ids that had no `stream_events` row (e.g. never existed, or were+ -- hard-deleted). The `stream_upsert` had already bumped `stream_version`,+ -- so the stream advanced by N but only some link rows were inserted.+ it "rejects link when the source event does not exist" $ \store -> do+ let bogus = EventId (case UUID.fromString "11111111-1111-7111-8111-111111111111" of Just u -> u; Nothing -> error "bad uuid")+ result <- runStoreIO store $ linkToStream (StreamName "f3-bogus") [bogus]+ case result of+ Left _ -> pure ()+ Right r -> expectationFailure ("Expected error for missing event, got: " <> show r)+ -- Target stream must not have been left in a half-created state.+ Right info <- runStoreIO store $ getStream (StreamName "f3-bogus")+ info `shouldBe` Nothing++ it "rejects link with a mix of valid and missing events (no partial commit)" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "f3-mixed-src") NoStream [makeEvent "Real" (Aeson.object [])]+ Right realEvents <- runStoreIO store $ readStreamForward (StreamName "f3-mixed-src") (StreamVersion 0) 100+ let realId = V.head realEvents ^. #eventId+ let bogus = EventId (case UUID.fromString "22222222-2222-7222-8222-222222222222" of Just u -> u; Nothing -> error "bad uuid")+ result <- runStoreIO store $ linkToStream (StreamName "f3-mixed-tgt") [realId, bogus]+ case result of+ Left _ -> pure ()+ Right r -> expectationFailure ("Expected error for partial-missing batch, got: " <> show r)+ Right info <- runStoreIO store $ getStream (StreamName "f3-mixed-tgt")+ info `shouldBe` Nothing++ -- F5 regression — linkToStream against a soft-deleted target stream.+ -- Symmetric with the appendAnyVersion soft-delete check from F2: the+ -- DO UPDATE clause's WHERE filters on deleted_at IS NULL, so the+ -- upsert returns no row and the interpreter maps that to StreamNotFound.+ it "rejects link to a soft-deleted target stream" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "f5-src") NoStream [makeEvent "X" (Aeson.object [])]+ Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "f5-src") (StreamVersion 0) 100+ let eid = V.head srcEvents ^. #eventId+ Right _ <- runStoreIO store $ appendToStream (StreamName "f5-target") NoStream [makeEvent "Init" (Aeson.object [])]+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "f5-target")+ result <- runStoreIO store $ linkToStream (StreamName "f5-target") [eid]+ case result of+ Left (StreamNotFound _) -> pure ()+ other -> expectationFailure ("Expected StreamNotFound for soft-deleted target, got: " <> show other)+ -- Soft-deleted target's version must not have advanced.+ Right info <- runStoreIO store $ getStream (StreamName "f5-target")+ case info of+ Just si -> (si ^. #version) `shouldBe` StreamVersion 1+ Nothing -> expectationFailure "soft-deleted stream row should still exist"++ -- =================================================================+ -- Category read tests (M5.8)+ -- =================================================================+ describe "readCategory" $ do+ it "reads events from matching category streams in global position order" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "order-1") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "order-2") NoStream [makeEvent "OrderShipped" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "user-1") NoStream [makeEvent "UserRegistered" (Aeson.object [])]+ Right result <- runStoreIO store $ readCategory (CategoryName "order") (GlobalPosition 0) 100+ V.length result `shouldBe` 2+ (V.head result ^. #eventType) `shouldBe` EventType "OrderCreated"+ (result V.! 1 ^. #eventType) `shouldBe` EventType "OrderShipped"+ -- Verify global positions are ascending+ (V.head result ^. #globalPosition) `shouldSatisfy` (< (result V.! 1 ^. #globalPosition))++ it "supports pagination with start position and limit" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "cat-1") NoStream [makeEvent "A" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "cat-2") NoStream [makeEvent "B" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "cat-3") NoStream [makeEvent "C" (Aeson.object [])]+ -- Read first 2+ Right page1 <- runStoreIO store $ readCategory (CategoryName "cat") (GlobalPosition 0) 2+ V.length page1 `shouldBe` 2+ -- Read from cursor+ let cursor = page1 V.! 1 ^. #globalPosition+ Right page2 <- runStoreIO store $ readCategory (CategoryName "cat") cursor 100+ V.length page2 `shouldBe` 1++ it "returns empty for nonexistent category" $ \store -> do+ Right result <- runStoreIO store $ readCategory (CategoryName "nope") (GlobalPosition 0) 100+ V.length result `shouldBe` 0++ it "includes linked events that originate from category streams" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "evt-1") NoStream [makeEvent "EventA" (Aeson.object [])]+ Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "evt-1") (StreamVersion 0) 100+ let eid = V.head srcEvents ^. #eventId+ -- Link into a different-category stream+ Right _ <- runStoreIO store $ linkToStream (StreamName "projection-1") [eid]+ -- Category "evt" should still return the event (it originates from evt-1)+ Right result <- runStoreIO store $ readCategory (CategoryName "evt") (GlobalPosition 0) 100+ V.length result `shouldBe` 1+ (V.head result ^. #eventType) `shouldBe` EventType "EventA"++ -- =================================================================+ -- Multi-stream transaction tests (M5.8)+ -- =================================================================+ describe "appendMultiStream" $ do+ it "atomically appends to two streams" $ \store -> do+ let ops =+ [ (StreamName "multi-a", NoStream, [makeEvent "A" (Aeson.object [])])+ , (StreamName "multi-b", NoStream, [makeEvent "B" (Aeson.object [])])+ ]+ Right results <- runStoreIO store $ appendMultiStream ops+ length results `shouldBe` 2+ ((results !! 0) ^. #streamVersion) `shouldBe` StreamVersion 1+ ((results !! 1) ^. #streamVersion) `shouldBe` StreamVersion 1++ it "rolls back all streams on version conflict" $ \store -> do+ -- Create stream multi-c+ Right _ <- runStoreIO store $ appendToStream (StreamName "multi-c") NoStream [makeEvent "C" (Aeson.object [])]+ let ops =+ [ (StreamName "multi-d", NoStream, [makeEvent "D" (Aeson.object [])])+ , (StreamName "multi-c", NoStream, [makeEvent "C2" (Aeson.object [])]) -- conflict: already exists+ ]+ result <- runStoreIO store $ appendMultiStream ops+ case result of+ Left _ -> do+ -- Verify multi-d was NOT created (rollback)+ Right info <- runStoreIO store $ getStream (StreamName "multi-d")+ info `shouldBe` Nothing+ Right _ -> expectationFailure "Expected error for version conflict"++ it "appends to three streams with different expected versions" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "tri-1") NoStream [makeEvent "X" (Aeson.object [])]+ let ops =+ [ (StreamName "tri-1", ExactVersion (StreamVersion 1), [makeEvent "X2" (Aeson.object [])])+ , (StreamName "tri-2", NoStream, [makeEvent "Y" (Aeson.object [])])+ , (StreamName "tri-3", AnyVersion, [makeEvent "Z" (Aeson.object [])])+ ]+ Right results <- runStoreIO store $ appendMultiStream ops+ length results `shouldBe` 3+ ((results !! 0) ^. #streamVersion) `shouldBe` StreamVersion 2+ ((results !! 1) ^. #streamVersion) `shouldBe` StreamVersion 1+ ((results !! 2) ^. #streamVersion) `shouldBe` StreamVersion 1++ -- F4 regression — pre-lock pass over named streams in stream_id order.+ -- The deterministic deadlock-prevention scenario (two concurrent calls+ -- touching the same streams in opposite orders) is covered by EP-6's+ -- planned concurrency-test harness; this test verifies that the+ -- pre-lock does not change user-visible ordering of global positions+ -- within a single multi-stream call.+ it "preserves user-supplied ordering of global positions" $ \store -> do+ let ops =+ [ (StreamName "f4-zzz", NoStream, [makeEvent "Z" (Aeson.object [])])+ , (StreamName "f4-mmm", NoStream, [makeEvent "M" (Aeson.object [])])+ , (StreamName "f4-aaa", NoStream, [makeEvent "A" (Aeson.object [])])+ ]+ Right results <- runStoreIO store $ appendMultiStream ops+ length results `shouldBe` 3+ let p0 = (results !! 0) ^. #globalPosition+ p1 = (results !! 1) ^. #globalPosition+ p2 = (results !! 2) ^. #globalPosition+ p0 `shouldSatisfy` (< p1)+ p1 `shouldSatisfy` (< p2)+ -- Read $all and confirm the events appear in user-supplied order.+ Right allEvts <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ let names = V.toList (V.map (^. #eventType) allEvts)+ names `shouldBe` [EventType "Z", EventType "M", EventType "A"]++ -- =================================================================+ -- Soft delete tests (M6.8)+ -- =================================================================+ describe "softDeleteStream" $ do+ it "soft-deletes a stream and getStream shows deletedAt" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "del-1") NoStream [makeEvent "A" (Aeson.object [])]+ Right mId <- runStoreIO store $ softDeleteStream (StreamName "del-1")+ mId `shouldSatisfy` (/= Nothing)+ Right info <- runStoreIO store $ getStream (StreamName "del-1")+ case info of+ Just si -> (si ^. #deletedAt) `shouldSatisfy` (/= Nothing)+ Nothing -> expectationFailure "Expected stream info with deletedAt set"++ it "returns empty for reads from a soft-deleted stream" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "del-read") NoStream [makeEvent "A" (Aeson.object [])]+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "del-read")+ Right fwd <- runStoreIO store $ readStreamForward (StreamName "del-read") (StreamVersion 0) 100+ V.length fwd `shouldBe` 0+ Right bwd <- runStoreIO store $ readStreamBackward (StreamName "del-read") (StreamVersion 0) 100+ V.length bwd `shouldBe` 0++ it "rejects appends to a soft-deleted stream" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "del-append") NoStream [makeEvent "A" (Aeson.object [])]+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "del-append")+ result <- runStoreIO store $ appendToStream (StreamName "del-append") StreamExists [makeEvent "B" (Aeson.object [])]+ case result of+ Left (StreamNotFound _) -> pure ()+ other -> expectationFailure ("Expected StreamNotFound, got: " <> show other)++ it "returns Nothing for nonexistent stream" $ \store -> do+ Right mId <- runStoreIO store $ softDeleteStream (StreamName "no-such")+ mId `shouldBe` Nothing++ it "returns Nothing for already-deleted stream" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "del-twice") NoStream [makeEvent "A" (Aeson.object [])]+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "del-twice")+ Right mId <- runStoreIO store $ softDeleteStream (StreamName "del-twice")+ mId `shouldBe` Nothing++ it "events from soft-deleted stream still appear in $all" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "del-all") NoStream [makeEvent "KeepInAll" (Aeson.object [])]+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "del-all")+ Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ let matching = V.filter (\e -> (e ^. #eventType) == EventType "KeepInAll") allEvents+ V.length matching `shouldBe` 1++ -- F2 regression — the protection against writes to a soft-deleted stream is+ -- enforced by a `deleted_at IS NULL` filter inside each append CTE, not by a+ -- pre-check that races concurrent soft-deletes. These tests exercise every+ -- append variant so a reader can see at a glance which constructor maps to+ -- which error after a soft-delete.+ it "ExactVersion append rejected against soft-deleted stream" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "f2-cte-exv") NoStream [makeEvent "Init" (Aeson.object [])]+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "f2-cte-exv")+ result <- runStoreIO store $ appendToStream (StreamName "f2-cte-exv") (ExactVersion (StreamVersion 1)) [makeEvent "X" (Aeson.object [])]+ case result of+ Left (WrongExpectedVersion _ _ _) -> pure ()+ Left (StreamNotFound _) -> pure ()+ other -> expectationFailure ("Expected WrongExpectedVersion or StreamNotFound, got: " <> show other)++ it "AnyVersion append rejected against soft-deleted stream" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "f2-cte-any") NoStream [makeEvent "Init" (Aeson.object [])]+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "f2-cte-any")+ result <- runStoreIO store $ appendToStream (StreamName "f2-cte-any") AnyVersion [makeEvent "X" (Aeson.object [])]+ case result of+ Left (StreamNotFound _) -> pure ()+ other -> expectationFailure ("Expected StreamNotFound, got: " <> show other)++ it "NoStream append rejected against soft-deleted stream" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "f2-cte-no") NoStream [makeEvent "Init" (Aeson.object [])]+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "f2-cte-no")+ result <- runStoreIO store $ appendToStream (StreamName "f2-cte-no") NoStream [makeEvent "X" (Aeson.object [])]+ case result of+ Left (StreamAlreadyExists _) -> pure ()+ other -> expectationFailure ("Expected StreamAlreadyExists, got: " <> show other)++ -- =================================================================+ -- Undelete tests (M6.8)+ -- =================================================================+ describe "undeleteStream" $ do+ it "restores a soft-deleted stream" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "undel-1") NoStream [makeEvent "A" (Aeson.object [])]+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "undel-1")+ Right mId <- runStoreIO store $ undeleteStream (StreamName "undel-1")+ mId `shouldSatisfy` (/= Nothing)+ Right info <- runStoreIO store $ getStream (StreamName "undel-1")+ case info of+ Just si -> (si ^. #deletedAt) `shouldBe` Nothing+ Nothing -> expectationFailure "Expected stream info"++ it "reads work after undelete" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "undel-read") NoStream [makeEvent "A" (Aeson.object [])]+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "undel-read")+ Right _ <- runStoreIO store $ undeleteStream (StreamName "undel-read")+ Right events <- runStoreIO store $ readStreamForward (StreamName "undel-read") (StreamVersion 0) 100+ V.length events `shouldBe` 1++ it "appends work after undelete" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "undel-append") NoStream [makeEvent "A" (Aeson.object [])]+ Right _ <- runStoreIO store $ softDeleteStream (StreamName "undel-append")+ Right _ <- runStoreIO store $ undeleteStream (StreamName "undel-append")+ Right r <- runStoreIO store $ appendToStream (StreamName "undel-append") StreamExists [makeEvent "B" (Aeson.object [])]+ (r ^. #streamVersion) `shouldBe` StreamVersion 2++ it "returns Nothing for non-deleted stream" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "undel-noop") NoStream [makeEvent "A" (Aeson.object [])]+ Right mId <- runStoreIO store $ undeleteStream (StreamName "undel-noop")+ mId `shouldBe` Nothing++ -- =================================================================+ -- Hard delete tests (M6.8)+ -- =================================================================+ describe "hardDeleteStream" $ do+ it "hard-deletes a stream completely" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "hard-1") NoStream [makeEvent "A" (Aeson.object [])]+ Right mId <- runStoreIO store $ hardDeleteStream (StreamName "hard-1")+ mId `shouldSatisfy` (/= Nothing)+ Right info <- runStoreIO store $ getStream (StreamName "hard-1")+ info `shouldBe` Nothing++ it "events from hard-deleted stream no longer appear in $all" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "hard-all") NoStream [makeEvent "HardDelEvent" (Aeson.object [])]+ Right _ <- runStoreIO store $ hardDeleteStream (StreamName "hard-all")+ Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ let matching = V.filter (\e -> (e ^. #eventType) == EventType "HardDelEvent") allEvents+ V.length matching `shouldBe` 0++ it "returns Nothing for nonexistent stream" $ \store -> do+ Right mId <- runStoreIO store $ hardDeleteStream (StreamName "hard-no-such")+ mId `shouldBe` Nothing++ -- F6 regression — TRUNCATE on protected tables must be gated by the+ -- same GUC as DELETE. Without the BEFORE TRUNCATE triggers added in+ -- EP-1 F6, an operator could TRUNCATE events / stream_events / streams+ -- without setting kiroku.enable_hard_deletes, bypassing the row-level+ -- protect_deletion check.+ it "TRUNCATE on events is rejected without the GUC" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "f6-truncate") NoStream [makeEvent "X" (Aeson.object [])]+ rejected <- truncateRejected store "events"+ rejected `shouldBe` True++ it "TRUNCATE on stream_events is rejected without the GUC" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "f6-truncate-se") NoStream [makeEvent "X" (Aeson.object [])]+ rejected <- truncateRejected store "stream_events"+ rejected `shouldBe` True++ it "TRUNCATE on streams is rejected without the GUC" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "f6-truncate-s") NoStream [makeEvent "X" (Aeson.object [])]+ rejected <- truncateRejected store "streams"+ rejected `shouldBe` True++ -- F1 regression — events orphaned in `events` table after hard-delete.+ it "removes orphan event payloads from the events table" $ \store -> do+ let evts = map (\i -> makeEvent ("F1Orphan" <> T.pack (show i)) (Aeson.object [])) [1 .. 3 :: Int]+ Right _ <- runStoreIO store $ appendToStream (StreamName "f1-orphan") NoStream evts+ before <- countEvents store+ Right _ <- runStoreIO store $ hardDeleteStream (StreamName "f1-orphan")+ after <- countEvents store+ (before - after) `shouldBe` 3++ -- F1 regression — events that are linked to other streams must survive+ -- hard-delete of their source stream's owner if any non-target junctions remain.+ it "preserves events still linked to non-target streams" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "f1-keep-src") NoStream [makeEvent "Keep" (Aeson.object [])]+ Right srcEvents <- runStoreIO store $ readStreamForward (StreamName "f1-keep-src") (StreamVersion 0) 100+ let eid = V.head srcEvents ^. #eventId+ -- Append another stream that gets a different event so we can hard-delete keep-src+ -- without touching the linked stream's source. Then link f1-keep-src's event to a+ -- third stream we will leave alone.+ Right _ <- runStoreIO store $ appendToStream (StreamName "f1-other") NoStream [makeEvent "Other" (Aeson.object [])]+ -- Link via appendToStream + linkToStream to a different stream+ _ <- runStoreIO store $ linkToStream (StreamName "f1-keep-link") [eid]+ -- Hard-deleting f1-keep-src removes the source's events even though the link+ -- referenced them: link rows have original_stream_id = f1-keep-src's id, so they+ -- match the junction-delete WHERE clause. The contract is documented in F1's fix+ -- commit: hard-delete cascades through link junctions of the deleted stream's+ -- original events. (See SQL.hs hard-delete documentation.)+ Right _ <- runStoreIO store $ hardDeleteStream (StreamName "f1-keep-src")+ -- f1-other's event must still exist (not affected at all).+ Right otherEvents <- runStoreIO store $ readStreamForward (StreamName "f1-other") (StreamVersion 0) 100+ V.length otherEvents `shouldBe` 1++ -- =================================================================+ -- Subscription tests (M7.7)+ -- =================================================================+ describe "subscribe" $ do+ it "catches up from position 0 on a store with existing events" $ \store -> do+ -- Append 10 events+ let events = map (\i -> makeEvent ("E" <> T.pack (show i)) (Aeson.object [])) [1 .. 10 :: Int]+ Right _ <- runStoreIO store $ appendToStream (StreamName "catchup-1") NoStream events+ -- Wait until the EventPublisher has ingested all 10 events.+ waitForPublisher store (GlobalPosition 10)+ -- Subscribe from position 0+ ref <- newIORef ([] :: [RecordedEvent])+ countRef <- newTVarIO (0 :: Int)+ let handler' evt = do+ modifyIORef' ref (evt :)+ n <- atomically $ do+ c <- readTVar countRef+ let c' = c + 1+ writeTVar countRef c'+ pure c'+ if n >= 10+ then pure Stop+ else pure Continue+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "catchup-test"+ , target = AllStreams+ , handler = handler'+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ result <- waitWithTimeout 10_000_000 handle+ case result of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+ Right (Right ()) -> pure ()+ collected <- readIORef ref+ length collected `shouldBe` 10++ it "receives live events appended after subscription starts" $ \store -> do+ ref <- newIORef ([] :: [RecordedEvent])+ countRef <- newTVarIO (0 :: Int)+ let handler' evt = do+ modifyIORef' ref (evt :)+ n <- atomically $ do+ c <- readTVar countRef+ let c' = c + 1+ writeTVar countRef c'+ pure c'+ if n >= 5+ then pure Stop+ else pure Continue+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "live-test"+ , target = AllStreams+ , handler = handler'+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ -- Give subscription time to start+ threadDelay 100_000+ -- Append 5 events+ let events = map (\i -> makeEvent ("Live" <> T.pack (show i)) (Aeson.object [])) [1 .. 5 :: Int]+ Right _ <- runStoreIO store $ appendToStream (StreamName "live-1") NoStream events+ -- Wait for subscription to complete+ result <- waitWithTimeout 10_000_000 handle+ case result of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+ Right (Right ()) -> pure ()+ collected <- readIORef ref+ length collected `shouldBe` 5++ it "persists checkpoint and resumes from saved position" $ \store -> do+ -- Append 10 events+ let events = map (\i -> makeEvent ("CP" <> T.pack (show i)) (Aeson.object [])) [1 .. 10 :: Int]+ Right _ <- runStoreIO store $ appendToStream (StreamName "ckpt-1") NoStream events+ waitForPublisher store (GlobalPosition 10)+ -- First subscription: process 5 events then stop+ countRef1 <- newTVarIO (0 :: Int)+ let handler1 _evt = do+ n <- atomically $ do+ c <- readTVar countRef1+ let c' = c + 1+ writeTVar countRef1 c'+ pure c'+ if n >= 5+ then pure Stop+ else pure Continue+ let cfg1 =+ SubscriptionConfig+ { name = SubscriptionName "ckpt-test"+ , target = AllStreams+ , handler = handler1+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ h1 <- subscribe store cfg1+ _ <- waitWithTimeout 10_000_000 h1+ -- Second subscription with same name: should resume from position 5+ ref2 <- newIORef ([] :: [RecordedEvent])+ countRef2 <- newTVarIO (0 :: Int)+ let handler2 evt = do+ modifyIORef' ref2 (evt :)+ n <- atomically $ do+ c <- readTVar countRef2+ let c' = c + 1+ writeTVar countRef2 c'+ pure c'+ if n >= 5+ then pure Stop+ else pure Continue+ let cfg2 =+ SubscriptionConfig+ { name = SubscriptionName "ckpt-test"+ , target = AllStreams+ , handler = handler2+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ h2 <- subscribe store cfg2+ _ <- waitWithTimeout 10_000_000 h2+ collected <- readIORef ref2+ -- Should receive events 6–10 only+ length collected `shouldBe` 5++ it "does not replay catch-up events when switching to all-stream live mode" $ \store -> do+ let seedEvents = map (\i -> makeEvent ("TransitionSeed" <> T.pack (show i)) (Aeson.object [])) [1 .. 5 :: Int]+ Right _ <- runStoreIO store $ appendToStream (StreamName "transition-seed") NoStream seedEvents+ waitForPublisher store (GlobalPosition 5)++ firstSeen <- newEmptyMVar+ releaseFirst <- newEmptyMVar+ countRef <- newTVarIO (0 :: Int)+ ref <- newIORef ([] :: [RecordedEvent])+ let stopType = EventType "TransitionStopAfterLive"+ handler' evt = do+ modifyIORef' ref (evt :)+ n <- atomically $ do+ c <- readTVar countRef+ let c' = c + 1+ writeTVar countRef c'+ pure c'+ if n == 1+ then do+ putMVar firstSeen ()+ takeMVar releaseFirst+ else pure ()+ if evt ^. #eventType == stopType+ then pure Stop+ else pure Continue+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "transition-no-duplicates"+ , target = AllStreams+ , handler = handler'+ , batchSize = 2+ , queueCapacity = 32+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ takeMVar firstSeen++ mapM_+ ( \i -> do+ let sn = StreamName ("transition-during-" <> T.pack (show (i :: Int)))+ Right _ <- runStoreIO store $ appendToStream sn NoStream [makeEvent ("TransitionDuring" <> T.pack (show i)) (Aeson.object [])]+ pure ()+ )+ [6 .. 10]+ waitForPublisher store (GlobalPosition 10)+ putMVar releaseFirst ()+ atomically $ do+ c <- readTVar countRef+ check (c >= 10)++ Right _ <- runStoreIO store $ appendToStream (StreamName "transition-stop") NoStream [makeEvent "TransitionStopAfterLive" (Aeson.object [])]+ result <- waitWithTimeout 10_000_000 handle+ case result of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+ Right (Right ()) -> pure ()++ collected <- reverse <$> readIORef ref+ map (^. #globalPosition) collected `shouldBe` map GlobalPosition [1 .. 11]++ it "does not skip an event when cancelled before checkpoint save" $ \store -> do+ let events = map (\i -> makeEvent ("CancelReplay" <> T.pack (show i)) (Aeson.object [])) [1 .. 3 :: Int]+ Right _ <- runStoreIO store $ appendToStream (StreamName "cancel-replay") NoStream events+ waitForPublisher store (GlobalPosition 3)++ firstSeen <- newEmptyMVar+ block <- newEmptyMVar+ firstRef <- newIORef ([] :: [RecordedEvent])+ let handler1 evt = do+ modifyIORef' firstRef (evt :)+ putMVar firstSeen ()+ takeMVar block+ pure Continue+ cfg1 =+ SubscriptionConfig+ { name = SubscriptionName "cancel-replay-test"+ , target = AllStreams+ , handler = handler1+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ h1 <- subscribe store cfg1+ takeMVar firstSeen+ cancel h1+ _ <- waitWithTimeout 5_000_000 h1++ ref2 <- newIORef ([] :: [RecordedEvent])+ let handler2 evt = do+ modifyIORef' ref2 (evt :)+ pure Stop+ cfg2 =+ SubscriptionConfig+ { name = SubscriptionName "cancel-replay-test"+ , target = AllStreams+ , handler = handler2+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ h2 <- subscribe store cfg2+ result <- waitWithTimeout 10_000_000 h2+ case result of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+ Right (Right ()) -> pure ()+ replayed <- reverse <$> readIORef ref2+ map (^. #globalPosition) replayed `shouldBe` [GlobalPosition 1]++ it "saves checkpoints at Stop boundaries without skipping the next event" $ \store -> do+ let events = map (\i -> makeEvent ("StopBoundary" <> T.pack (show i)) (Aeson.object [])) [1 .. 5 :: Int]+ Right _ <- runStoreIO store $ appendToStream (StreamName "stop-boundary") NoStream events+ waitForPublisher store (GlobalPosition 5)++ countRef1 <- newTVarIO (0 :: Int)+ let handler1 _evt = do+ n <- atomically $ do+ c <- readTVar countRef1+ let c' = c + 1+ writeTVar countRef1 c'+ pure c'+ if n >= 3 then pure Stop else pure Continue+ cfg1 =+ SubscriptionConfig+ { name = SubscriptionName "stop-boundary-test"+ , target = AllStreams+ , handler = handler1+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ h1 <- subscribe store cfg1+ _ <- waitWithTimeout 10_000_000 h1++ ref2 <- newIORef ([] :: [RecordedEvent])+ countRef2 <- newTVarIO (0 :: Int)+ let handler2 evt = do+ modifyIORef' ref2 (evt :)+ n <- atomically $ do+ c <- readTVar countRef2+ let c' = c + 1+ writeTVar countRef2 c'+ pure c'+ if n >= 2 then pure Stop else pure Continue+ cfg2 =+ SubscriptionConfig+ { name = SubscriptionName "stop-boundary-test"+ , target = AllStreams+ , handler = handler2+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ h2 <- subscribe store cfg2+ result <- waitWithTimeout 10_000_000 h2+ case result of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+ Right (Right ()) -> pure ()+ replayed <- reverse <$> readIORef ref2+ map (^. #globalPosition) replayed `shouldBe` [GlobalPosition 4, GlobalPosition 5]++ -- F18 regression — Category subscriptions in live mode previously+ -- received unfiltered events from $all because `filterEvents` was+ -- a no-op for Category. The fix routes Category live-mode through+ -- a DB-driven loop that re-uses the SQL category filter. Before+ -- the fix, the handler would observe the UserNoise event below.+ it "delivers only category-matching events during live mode (F18)" $ \store -> do+ seedSeen <- newEmptyMVar+ ref <- newIORef ([] :: [RecordedEvent])+ countRef <- newTVarIO (0 :: Int)+ let handler' evt = do+ modifyIORef' ref (evt :)+ n <- atomically $ do+ c <- readTVar countRef+ let c' = c + 1+ writeTVar countRef c'+ pure c'+ -- After the catch-up seed event, signal that we are+ -- entering live mode. Subsequent appends exercise+ -- the live path under the new DB-driven loop.+ if n == 1+ then putMVar seedSeen ()+ else pure ()+ if n >= 3 then pure Stop else pure Continue+ -- Pre-seed an order event so catch-up fires the handler once.+ Right _ <-+ runStoreIO store $+ appendToStream+ (StreamName "order-seed")+ NoStream+ [makeEvent "OrderSeed" (Aeson.object [])]+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "f18-live-test"+ , target = Category (CategoryName "order")+ , handler = handler'+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ -- Block until catch-up has delivered the seed event — the+ -- worker has finished catch-up and is about to enter live+ -- mode.+ takeMVar seedSeen+ -- Append a non-matching user event followed by two matching+ -- order events. Under the bug, UserNoise would slip through+ -- the live broadcast unfiltered.+ Right _ <- runStoreIO store $ appendToStream (StreamName "user-1") NoStream [makeEvent "UserNoise" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "order-2") NoStream [makeEvent "OrderTwo" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "order-3") NoStream [makeEvent "OrderThree" (Aeson.object [])]+ result <- waitWithTimeout 10_000_000 handle+ case result of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+ Right (Right ()) -> pure ()+ collected <- readIORef ref+ length collected `shouldBe` 3+ -- No UserNoise event should have been delivered.+ mapM_+ (\e -> (e ^. #eventType) `shouldNotBe` EventType "UserNoise")+ collected++ it "delivers only category-matching events during catch-up" $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "order-1") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "order-2") NoStream [makeEvent "OrderShipped" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "user-1") NoStream [makeEvent "UserRegistered" (Aeson.object [])]+ waitForPublisher store (GlobalPosition 3)+ ref <- newIORef ([] :: [RecordedEvent])+ countRef <- newTVarIO (0 :: Int)+ let handler' evt = do+ modifyIORef' ref (evt :)+ n <- atomically $ do+ c <- readTVar countRef+ let c' = c + 1+ writeTVar countRef c'+ pure c'+ if n >= 2+ then pure Stop+ else pure Continue+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "cat-sub-test"+ , target = Category (CategoryName "order")+ , handler = handler'+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ _ <- waitWithTimeout 10_000_000 handle+ collected <- readIORef ref+ length collected `shouldBe` 2+ -- All events should be order events+ mapM_ (\e -> (e ^. #eventType) `shouldSatisfy` (\(EventType t) -> T.isPrefixOf "Order" t)) collected++ it "preserves category subscription order under mixed invoice-payment writes" $ \store -> do+ let appendOne sn typ =+ runStoreIO store (appendToStream sn AnyVersion [makeEvent typ (Aeson.object [])]) >>= \result ->+ case result of+ Right _ -> pure ()+ Left err -> expectationFailure ("append failed: " <> show err)+ appendOne (StreamName "invoice-payment") "InvoicePaymentStarted"+ appendOne (StreamName "user-1") "UserNoiseOne"+ appendOne (StreamName "invoice-reminder") "InvoiceReminderSent"+ appendOne (StreamName "order-1") "OrderNoiseOne"+ appendOne (StreamName "invoice-payment") "InvoicePaymentFinished"+ appendOne (StreamName "user-2") "UserNoiseTwo"+ appendOne (StreamName "invoice-refund") "InvoiceRefundFinished"+ waitForPublisher store (GlobalPosition 7)++ ref <- newIORef ([] :: [RecordedEvent])+ countRef <- newTVarIO (0 :: Int)+ let handler' evt = do+ modifyIORef' ref (evt :)+ n <- atomically $ do+ c <- readTVar countRef+ let c' = c + 1+ writeTVar countRef c'+ pure c'+ if n >= 4 then pure Stop else pure Continue+ cfg =+ SubscriptionConfig+ { name = SubscriptionName "invoice-category-ordering"+ , target = Category (CategoryName "invoice")+ , handler = handler'+ , batchSize = 2+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ result <- waitWithTimeout 10_000_000 handle+ case result of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+ Right (Right ()) -> pure ()+ collected <- reverse <$> readIORef ref+ map (^. #globalPosition) collected `shouldBe` [GlobalPosition 1, GlobalPosition 3, GlobalPosition 5, GlobalPosition 7]+ map (^. #eventType) collected+ `shouldBe` [ EventType "InvoicePaymentStarted"+ , EventType "InvoiceReminderSent"+ , EventType "InvoicePaymentFinished"+ , EventType "InvoiceRefundFinished"+ ]++ it "cancels a running subscription cleanly" $ \store -> do+ let handler' _evt = pure Continue+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "cancel-test"+ , target = AllStreams+ , handler = handler'+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ -- Give it time to start+ threadDelay 100_000+ cancel handle+ result <- waitWithTimeout 5_000_000 handle+ -- Should exit cleanly (AsyncCancelled or Right ())+ case result of+ Left _timeout -> expectationFailure "Cancel did not terminate in time"+ Right (Left _) -> pure () -- AsyncCancelled is expected+ Right (Right ()) -> pure ()++ it "receives events appended to an initially empty store" $ \store -> do+ ref <- newIORef ([] :: [RecordedEvent])+ let handler' evt = do+ modifyIORef' ref (evt :)+ pure Stop+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "empty-store-test"+ , target = AllStreams+ , handler = handler'+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ -- Give subscription time to start in live mode+ threadDelay 100_000+ -- Append one event+ Right _ <- runStoreIO store $ appendToStream (StreamName "empty-1") NoStream [makeEvent "First" (Aeson.object [])]+ result <- waitWithTimeout 10_000_000 handle+ case result of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+ Right (Right ()) -> pure ()+ collected <- readIORef ref+ length collected `shouldBe` 1++ it "handles rapid appends without losing events (debouncing)" $ \store -> do+ ref <- newIORef ([] :: [RecordedEvent])+ countRef <- newTVarIO (0 :: Int)+ let handler' evt = do+ modifyIORef' ref (evt :)+ n <- atomically $ do+ c <- readTVar countRef+ let c' = c + 1+ writeTVar countRef c'+ pure c'+ if n >= 50+ then pure Stop+ else pure Continue+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "debounce-test"+ , target = AllStreams+ , handler = handler'+ , batchSize = 100+ , -- Sized to absorb 50 publisher batches without+ -- backpressure overflow. The default 16 was+ -- intermittently overrun under load (the+ -- publisher emits one batch per append because+ -- there is no inter-append debounce window in+ -- this loop), surfacing as+ -- SubscriptionOverflowed in flaky CI runs.+ -- Coverage of the bounded-queue policy lives+ -- in the F6 overflow test below, not here.+ queueCapacity = 64+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ threadDelay 100_000+ -- Append 50 events rapidly to different streams+ mapM_+ ( \i -> do+ let sn = StreamName ("rapid-" <> T.pack (show (i :: Int)))+ Right _ <- runStoreIO store $ appendToStream sn NoStream [makeEvent ("R" <> T.pack (show i)) (Aeson.object [])]+ pure ()+ )+ [1 .. 50]+ result <- waitWithTimeout 30_000_000 handle+ case result of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+ Right (Right ()) -> pure ()+ collected <- readIORef ref+ length collected `shouldBe` 50++ -- F6 regression — the publisher's broadcast was an unbounded TChan;+ -- a slow subscriber's dupTChan grew without limit until the host+ -- ran out of memory. The fix replaces the broadcast with a+ -- per-subscriber bounded TBQueue plus an overflow policy. With+ -- DropSubscription, the publisher signals overflow on the+ -- subscriber's status TVar; the worker observes it on its next+ -- STM read and surfaces SubscriptionOverflowed via wait/waitCatch.+ it "surfaces SubscriptionOverflowed when a slow subscriber overruns its queue (F6)" $ \store -> do+ firstSeen <- newEmptyMVar+ release <- newEmptyMVar+ seenCount <- newTVarIO (0 :: Int)+ let handler' _evt = do+ n <- atomically $ do+ c <- readTVar seenCount+ let c' = c + 1+ writeTVar seenCount c'+ pure c'+ if n == 1+ then do+ putMVar firstSeen ()+ takeMVar release+ else pure ()+ pure Continue+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "f6-overflow-test"+ , target = AllStreams+ , handler = handler'+ , batchSize = 100+ , queueCapacity = 1+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ -- First append: triggers handler, which blocks on the release MVar.+ Right _ <- runStoreIO store $ appendToStream (StreamName "f6-1") NoStream [makeEvent "E1" (Aeson.object [])]+ takeMVar firstSeen+ -- While the worker is stuck inside the handler, append events one+ -- at a time and wait for the publisher to fetch each individually.+ -- Each append corresponds to a separate publisher batch written+ -- to the subscriber's queue. Capacity is 1, so the second+ -- write fills it and the third triggers DropSubscription.+ let waitForPub n = atomically $ do+ GlobalPosition p <- publisherPosition (store ^. #publisher)+ check (p >= n)+ let appendOne i = do+ let sn = StreamName ("f6-" <> T.pack (show (i :: Int)))+ Right _ <- runStoreIO store $ appendToStream sn NoStream [makeEvent "Ex" (Aeson.object [])]+ waitForPub (fromIntegral i)+ -- Append 4 more events with publisher synchronisation. Combined+ -- with the first event, that is 5 publisher batches.+ appendOne 2+ appendOne 3+ appendOne 4+ appendOne 5+ -- Release the handler. Worker exits processEvents and on the+ -- next STM read observes Overflowed.+ putMVar release ()+ result <- waitWithTimeout 10_000_000 handle+ case result of+ Left timeout -> expectationFailure timeout+ Right (Right ()) -> expectationFailure "expected SubscriptionOverflowed, got clean exit"+ Right (Left e) ->+ case Control.Exception.fromException e of+ Just (SubscriptionOverflowed sn) ->+ sn `shouldBe` SubscriptionName "f6-overflow-test"+ Nothing ->+ expectationFailure ("expected SubscriptionOverflowed, got: " <> show e)++ ref2 <- newIORef ([] :: [RecordedEvent])+ countRef2 <- newTVarIO (0 :: Int)+ let handler2 evt = do+ modifyIORef' ref2 (evt :)+ n <- atomically $ do+ c <- readTVar countRef2+ let c' = c + 1+ writeTVar countRef2 c'+ pure c'+ if n >= 4 then pure Stop else pure Continue+ cfg2 =+ SubscriptionConfig+ { name = SubscriptionName "f6-overflow-test"+ , target = AllStreams+ , handler = handler2+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ h2 <- subscribe store cfg2+ replayResult <- waitWithTimeout 10_000_000 h2+ case replayResult of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed after overflow restart: " <> show err)+ Right (Right ()) -> pure ()+ replayed <- reverse <$> readIORef ref2+ map (^. #globalPosition) replayed `shouldBe` map GlobalPosition [2 .. 5]++ it "catches up with an Eff-based handler via the effectful API" $ \store -> do+ -- Append 10 events+ let events = map (\i -> makeEvent ("Eff" <> T.pack (show i)) (Aeson.object [])) [1 .. 10 :: Int]+ Right _ <- runStoreIO store $ appendToStream (StreamName "eff-sub-1") NoStream events+ waitForPublisher store (GlobalPosition 10)+ -- Subscribe using the effectful API with an Eff-based handler+ ref <- newIORef ([] :: [RecordedEvent])+ countRef <- newTVarIO (0 :: Int)+ result <- runEff . runErrorNoCallStack @StoreError . runStorePool store . runSubscription store $ do+ let effHandler :: (IOE :> es) => RecordedEvent -> Eff es SubscriptionResult+ effHandler evt = do+ liftIO $ modifyIORef' ref (evt :)+ n <- liftIO $ atomically $ do+ c <- readTVar countRef+ let c' = c + 1+ writeTVar countRef c'+ pure c'+ if n >= 10+ then pure Stop+ else pure Continue+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "eff-catchup-test"+ , target = AllStreams+ , handler = effHandler+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- SubEff.subscribe cfg+ liftIO $ do+ r <- waitWithTimeout 10_000_000 handle+ case r of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+ Right (Right ()) -> pure ()+ case result of+ Left err -> expectationFailure ("Store error: " <> show err)+ Right () -> pure ()+ collected <- readIORef ref+ length collected `shouldBe` 10++ -- =================================================================+ -- withSubscription bracket tests (EP-2 F25)+ -- =================================================================+ describe "withSubscription" $ do+ -- F25 regression — bracket cancels the worker on normal scope exit.+ it "cancels the worker on normal scope exit" $ \store -> do+ handleRef <- newIORef Nothing+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "withsub-normal"+ , target = AllStreams+ , handler = \_ -> pure Continue+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ withSubscription store cfg $ \h -> do+ writeIORef handleRef (Just h)+ threadDelay 100_000+ Just h <- readIORef handleRef+ -- Worker must terminate now that the scope has exited.+ outcome <- Async.race (threadDelay 2_000_000) (wait h)+ case outcome of+ Left () -> expectationFailure "worker did not exit after withSubscription scope"+ Right _ -> pure ()++ -- F25 regression — bracket cancels the worker even when the body throws.+ it "cancels the worker when the body throws" $ \store -> do+ handleRef <- newIORef Nothing+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "withsub-throw"+ , target = AllStreams+ , handler = \_ -> pure Continue+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ result <-+ Control.Exception.try @SomeException $+ withSubscription store cfg $ \h -> do+ writeIORef handleRef (Just h)+ threadDelay 100_000+ error "withSubscription body deliberately throws"+ case result of+ Left _ -> pure ()+ Right () -> expectationFailure "expected exception to propagate"+ Just h <- readIORef handleRef+ outcome <- Async.race (threadDelay 2_000_000) (wait h)+ case outcome of+ Left () -> expectationFailure "worker did not exit after exception in withSubscription body"+ Right _ -> pure ()++ -- =================================================================+ -- Pure helpers (no database fixture)+ -- =================================================================++ -- F1 regression — pure detail parser used by attributeMultiStreamError.+ -- The integration scenario that would exercise this code path+ -- (ix_streams_stream_name 23505 raised inside an appendMultiStream txn)+ -- is unreachable via current SQL because every append CTE uses ON CONFLICT+ -- DO NOTHING / DO UPDATE. The pure helper is unit-tested here so a future+ -- schema change that introduces such a path arrives with the attribution+ -- already correct.+ describe "extractStreamNameFromDetail" $ do+ it "extracts the stream name from a typical PostgreSQL detail" $ do+ extractStreamNameFromDetail "Key (stream_name)=(orders-1) already exists."+ `shouldBe` Just "orders-1"+ it "extracts a stream name containing dashes and digits" $ do+ extractStreamNameFromDetail "Key (stream_name)=(multi-c-2) already exists."+ `shouldBe` Just "multi-c-2"+ it "returns Nothing when the detail is empty" $ do+ extractStreamNameFromDetail "" `shouldBe` Nothing+ it "returns Nothing when the detail does not contain '=('" $ do+ extractStreamNameFromDetail "no key here" `shouldBe` Nothing+ it "returns Nothing for an empty parenthesised value" $ do+ extractStreamNameFromDetail "Key (stream_name)=() already exists."+ `shouldBe` Nothing++ -- =================================================================+ -- Notifier reconnection tests (EP-3 F1)+ -- =================================================================+ describe "Notifier reconnection" $ do+ -- F1 regression — the listener loop reconnects on backend termination,+ -- and `stopNotifier` must release the *current* (post-reconnect)+ -- connection. Without the fix, the original Notifier.listenerConn was+ -- a frozen reference to the first conn and the reconnected conn leaked+ -- past `withStore` exit. We assert no kiroku-listener backend remains+ -- in pg_stat_activity after the store shuts down.+ it "releases the reconnected listener connection on shutdown" $ \() -> do+ result <- Pg.withCached $ \db -> do+ let connStr = Pg.connectionString db+ settings = defaultConnectionSettings connStr+ withStore settings $ \store -> do+ pid1 <- waitForListenerPid (store ^. #pool) 5_000_000+ terminateBackend (store ^. #pool) pid1+ pid2 <- waitForListenerPidNotEqual (store ^. #pool) pid1 15_000_000+ pid2 `shouldNotBe` pid1+ -- After withStore exits, no kiroku-listener connection remains.+ listenerCount connStr+ case result of+ Left err -> error ("Failed to start ephemeral PostgreSQL: " <> show err)+ Right n -> n `shouldBe` (0 :: Int64)++ -- =================================================================+ -- Health monitoring tests (M6.8)+ -- =================================================================+ describe "observationHandler" $ do+ it "receives observations during store operations" $ \() -> do+ ref <- newIORef ([] :: [Observation])+ let handler obs = modifyIORef' ref (obs :)+ withTestStoreSettings+ (\settings -> settings{observationHandler = Just handler})+ $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "obs-test") NoStream [makeEvent "X" (Aeson.object [])]+ pure ()+ observations <- readIORef ref+ length observations `shouldSatisfy` (> 0)++ -- =================================================================+ -- KirokuEvent observation surface (EP-5 F1, F13, F14)+ -- =================================================================+ describe "KirokuEvent observation" $ do+ -- EP-5 F1 regression — terminating the listener backend triggers+ -- KirokuEventNotifierReconnecting then KirokuEventNotifierReconnected.+ -- Before EP-5 the reconnect path emitted no signal at all.+ it "emits notifier reconnect events on backend termination (F1)" $ \() -> do+ ref <- newIORef ([] :: [KirokuEvent])+ let evtHandler e = modifyIORef' ref (e :)+ result <- Pg.withCached $ \db -> do+ let settings =+ defaultConnectionSettings (Pg.connectionString db)+ & #eventHandler .~ Just evtHandler+ withStore settings $ \store -> do+ pid1 <- waitForListenerPid (store ^. #pool) 5_000_000+ terminateBackend (store ^. #pool) pid1+ _ <- waitForListenerPidNotEqual (store ^. #pool) pid1 15_000_000+ pure ()+ case result of+ Left err -> error ("Failed to start ephemeral PostgreSQL: " <> show err)+ Right () -> pure ()+ evts <- readIORef ref+ let isReconnecting (KirokuEventNotifierReconnecting _ _) = True+ isReconnecting _ = False+ isReconnected KirokuEventNotifierReconnected = True+ isReconnected _ = False+ any isReconnecting evts `shouldBe` True+ any isReconnected evts `shouldBe` True++ -- EP-5 F14 regression — subscriptions emit started, caught-up, and+ -- stopped events. Before EP-5 the lifecycle was invisible.+ --+ -- Subscribe before appending so the worker enters catch-up at+ -- position 0, immediately reaches the publisher's position 0,+ -- emits CaughtUp, transitions to live mode, then receives the+ -- two appended events and stops.+ it "emits subscription lifecycle events (F14)" $ \() -> do+ ref <- newIORef ([] :: [KirokuEvent])+ let evtHandler e = modifyIORef' ref (e :)+ withTestStoreSettings+ (& #eventHandler .~ Just evtHandler)+ $ \store -> do+ countRef <- newTVarIO (0 :: Int)+ let h _ = do+ n <- atomically $ do+ c <- readTVar countRef+ writeTVar countRef (c + 1)+ pure (c + 1)+ if n >= 2 then pure Stop else pure Continue+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "lifecycle-test"+ , target = AllStreams+ , handler = h+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ handle <- subscribe store cfg+ -- Give the worker a moment to enter live mode.+ threadDelay 200_000+ Right _ <-+ runStoreIO store $+ appendToStream (StreamName "lifecycle-1") NoStream [makeEvent "X" (Aeson.object [])]+ Right _ <-+ runStoreIO store $+ appendToStream (StreamName "lifecycle-1") (ExactVersion (StreamVersion 1)) [makeEvent "Y" (Aeson.object [])]+ _ <- waitWithTimeout 10_000_000 handle+ pure ()+ evts <- readIORef ref+ let isStarted (KirokuEventSubscriptionStarted (SubscriptionName "lifecycle-test") _ _) = True+ isStarted _ = False+ isCaughtUp (KirokuEventSubscriptionCaughtUp (SubscriptionName "lifecycle-test") _ _) = True+ isCaughtUp _ = False+ isStopped (KirokuEventSubscriptionStopped (SubscriptionName "lifecycle-test") _ StopHandlerRequested _) = True+ isStopped _ = False+ any isStarted evts `shouldBe` True+ any isCaughtUp evts `shouldBe` True+ any isStopped evts `shouldBe` True++ -- EP-5 F13 regression — hard-delete emits a fail-safe audit event.+ -- Before EP-5 there was no in-band audit signal.+ it "emits a hard-delete event when the stream existed (F13)" $ \() -> do+ ref <- newIORef ([] :: [KirokuEvent])+ let evtHandler e = modifyIORef' ref (e :)+ withTestStoreSettings+ (& #eventHandler .~ Just evtHandler)+ $ \store -> do+ Right _ <-+ runStoreIO store $+ appendToStream (StreamName "hard-delete-evt") NoStream [makeEvent "X" (Aeson.object [])]+ Right _ <- runStoreIO store $ hardDeleteStream (StreamName "hard-delete-evt")+ -- A hard-delete on a non-existent stream must not emit+ -- the event — verify by issuing a second one.+ Right _ <- runStoreIO store $ hardDeleteStream (StreamName "never-existed")+ pure ()+ evts <- readIORef ref+ let hardDeletes =+ [ name'+ | KirokuEventHardDeleteIssued (StreamName name') _ <- evts+ ]+ hardDeletes `shouldBe` ["hard-delete-evt"]
+ test/Test/Causation.hs view
@@ -0,0 +1,168 @@+{- | Tests for "Kiroku.Store.Causation" — the causation- and+correlation-walking helpers.++Three groups of tests exercise the three exported functions:++ * 'findCausationDescendants' over a 5-deep chain @A -> B -> C -> D -> E@+ spread across three streams, plus single-element and empty cases.+ * 'findCausationAncestors' over the same chain, asserting leaf-first+ depth ordering.+ * 'findByCorrelation' fanning in across multiple streams, plus a noise+ correlation and an empty case.+-}+module Test.Causation (spec) where++import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as T+import Data.UUID (UUID)+import Data.UUID qualified as UUID+import Data.UUID.V4 qualified as UUIDv4+import Data.Vector (Vector)+import Data.Vector qualified as V+import Kiroku.Store+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec++spec :: Spec+spec = around withTestStore $ do+ describe "findCausationDescendants" $ do+ it "returns the seed event and every descendant in global-position order" $ \store -> do+ uuids@[uA, uB, uC, uD, uE] <- replicateUuids 5+ appendChain store uuids+ Right found <- runStoreIO store $ findCausationDescendants (EventId uA)+ eventIds found `shouldBe` map EventId uuids+ globalPositionsStrictlyIncreasing found `shouldBe` True++ it "on an eventId with no descendants returns a vector of length 1 (the seed only)" $ \store -> do+ uId <- UUIDv4.nextRandom+ let ev = mkEventWithIds "Solo" (Just uId) Nothing Nothing+ Right _ <- runStoreIO store $ appendToStream (StreamName "solo-stream") NoStream [ev]+ Right found <- runStoreIO store $ findCausationDescendants (EventId uId)+ V.length found `shouldBe` 1+ (V.head found ^. #eventId) `shouldBe` EventId uId++ it "on a non-existent eventId returns an empty vector" $ \store -> do+ -- Make sure the store has *some* events so we know we're not+ -- silently returning the whole table.+ let ev = makeEvent "Other" Aeson.Null+ Right _ <- runStoreIO store $ appendToStream (StreamName "other-stream") NoStream [ev]+ Right found <- runStoreIO store $ findCausationDescendants (EventId UUID.nil)+ V.null found `shouldBe` True++ describe "findCausationAncestors" $ do+ it "walks from a leaf back to the root, leaf first" $ \store -> do+ uuids@[uA, uB, uC, uD, uE] <- replicateUuids 5+ appendChain store uuids+ Right found <- runStoreIO store $ findCausationAncestors (EventId uE)+ eventIds found `shouldBe` map EventId [uE, uD, uC, uB, uA]++ describe "findByCorrelation" $ do+ it "returns every event with the given correlation across multiple streams in global-position order" $ \store -> do+ cMain <- UUIDv4.nextRandom+ cOther <- UUIDv4.nextRandom+ -- 7 events with correlation = cMain across 4 streams.+ let mkEv :: Int -> EventData+ mkEv i =+ mkEventWithIds+ (mkName "Main" i)+ Nothing+ Nothing+ (Just cMain)+ mainPlan =+ [ ("saga-a", NoStream, [mkEv 1, mkEv 2])+ , ("saga-b", NoStream, [mkEv 3])+ , ("saga-c", NoStream, [mkEv 4, mkEv 5, mkEv 6])+ , ("saga-d", NoStream, [mkEv 7])+ ]+ mapM_+ ( \(sn, ev, evts) -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName sn) ev evts+ pure ()+ )+ mainPlan+ -- Noise: one event with no correlation.+ Right _ <- runStoreIO store $ appendToStream (StreamName "noise-stream") NoStream [makeEvent "Noise" Aeson.Null]+ -- A separate correlation set we should not see.+ let mkOther :: Int -> EventData+ mkOther i =+ mkEventWithIds+ (mkName "Other" i)+ Nothing+ Nothing+ (Just cOther)+ Right _ <- runStoreIO store $ appendToStream (StreamName "other-saga") NoStream [mkOther i | i <- [1 .. 5 :: Int]]++ Right found <- runStoreIO store $ findByCorrelation cMain+ V.length found `shouldBe` 7+ all (\e -> e ^. #correlationId == Just cMain) found `shouldBe` True+ globalPositionsStrictlyIncreasing found `shouldBe` True++ it "on an unknown correlation returns an empty vector" $ \store -> do+ -- Insert *something* so we're not just observing an empty store.+ let noise = mkEventWithIds "Noise" Nothing Nothing (Just UUID.nil)+ Right _ <-+ runStoreIO store $+ appendToStream (StreamName "noise-stream") NoStream [noise]+ unknown <- UUIDv4.nextRandom+ Right found <- runStoreIO store $ findByCorrelation unknown+ V.null found `shouldBe` True++-- ---------------------------------------------------------------------------+-- Local helpers+-- ---------------------------------------------------------------------------++replicateUuids :: Int -> IO [UUID]+replicateUuids n = mapM (const UUIDv4.nextRandom) [1 .. n]++{- | Build an 'EventData' from explicit event-id, causation-id, and+correlation-id arguments. Wraps the field updates in a typed binding so+'DuplicateRecordFields' does not complain about ambiguous record+updates ('eventId', 'causationId', and 'correlationId' all appear on+both 'EventData' and 'RecordedEvent').+-}+mkEventWithIds :: Text -> Maybe UUID -> Maybe UUID -> Maybe UUID -> EventData+mkEventWithIds typ mEid mCause mCorr =+ EventData+ { eventId = fmap EventId mEid+ , eventType = EventType typ+ , payload = Aeson.Null+ , metadata = Nothing+ , causationId = mCause+ , correlationId = mCorr+ }++{- | Append a 5-event causation chain @A -> B -> C -> D -> E@ across three+streams (@pm-trigger@, @pm-cmd@, @pm-result@). Each event's+@causationId@ points at the previous event's @eventId@.++Expects exactly five UUIDs; calls 'error' on any other length so the+caller's signature stays simple.+-}+appendChain :: KirokuStore -> [UUID] -> IO ()+appendChain store [uA, uB, uC, uD, uE] = do+ let evA = mkEventWithIds "A" (Just uA) Nothing Nothing+ evB = mkEventWithIds "B" (Just uB) (Just uA) Nothing+ evC = mkEventWithIds "C" (Just uC) (Just uB) Nothing+ evD = mkEventWithIds "D" (Just uD) (Just uC) Nothing+ evE = mkEventWithIds "E" (Just uE) (Just uD) Nothing+ Right _ <- runStoreIO store $ appendToStream (StreamName "pm-trigger") NoStream [evA]+ Right _ <- runStoreIO store $ appendToStream (StreamName "pm-cmd") NoStream [evB]+ Right _ <- runStoreIO store $ appendToStream (StreamName "pm-cmd") AnyVersion [evC]+ Right _ <- runStoreIO store $ appendToStream (StreamName "pm-result") NoStream [evD]+ Right _ <- runStoreIO store $ appendToStream (StreamName "pm-result") AnyVersion [evE]+ pure ()+appendChain _ _ = error "appendChain: expected exactly 5 UUIDs"++eventIds :: Vector RecordedEvent -> [EventId]+eventIds = V.toList . V.map (^. #eventId)++globalPositionsStrictlyIncreasing :: Vector RecordedEvent -> Bool+globalPositionsStrictlyIncreasing v =+ let ps = V.toList (V.map (\e -> let GlobalPosition p = e ^. #globalPosition in p) v)+ in and (zipWith (<) ps (drop 1 ps))++mkName :: String -> Int -> Text+mkName tag i = T.pack (tag <> "-" <> show i)
+ test/Test/Concurrency.hs view
@@ -0,0 +1,280 @@+{- | Deterministic concurrency tests for kiroku-store.++Each test spawns multiple threads that race on append paths the+single-threaded scenario suite cannot exercise. The tests target the+EP-6 M1 Concurrency Scenarios (F9–F11) and verify EP-1 F4 (the sorted+@SELECT … FOR UPDATE@ pre-pass that prevents multi-stream deadlocks)+under deliberate adversarial ordering.++Each test acquires a fresh ephemeral PostgreSQL via 'withTestStore'.+-}+module Test.Concurrency (spec) where++import Control.Concurrent.Async qualified as Async+import Control.Lens ((^.))+import Control.Monad (forM_)+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.Int (Int64)+import Data.List (sort)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.UUID qualified as UUID+import Data.Vector qualified as V+import Kiroku.Store+import Test.Helpers (countEvents, makeEvent, withTestStore)+import Test.Hspec++spec :: Spec+spec = describe "kiroku-store concurrency (deterministic)" $ do+ it "many AnyVersion writers to one stream preserve stream and global order" $+ withTestStore $ \store -> do+ let writerCount = 24+ stream = StreamName "stress-one-stream"+ results <-+ Async.forConcurrently [1 .. writerCount] $ \i -> do+ runStoreIO store $+ appendToStream+ stream+ AnyVersion+ [makeEvent ("Stress" <> T.pack (show i)) (Aeson.object [])]+ mapM_ assertRightAppend results+ Right streamEvents <- runStoreIO store $ readStreamForward stream (StreamVersion 0) 1000+ V.length streamEvents `shouldBe` writerCount+ streamVersions streamEvents `shouldBe` [1 .. fromIntegral writerCount]+ Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 1000+ V.length allEvents `shouldBe` writerCount+ globalPositions allEvents `shouldBe` [1 .. fromIntegral writerCount]++ it "many AnyVersion writers to invoice-payment preserve stream and global order" $+ withTestStore $ \store -> do+ let writerCount = 32+ stream = StreamName "invoice-payment"+ results <-+ Async.forConcurrently [1 .. writerCount] $ \i -> do+ runStoreIO store $+ appendToStream+ stream+ AnyVersion+ [makeEvent ("InvoicePayment" <> T.pack (show i)) (Aeson.object [])]+ mapM_ assertRightAppend results+ Right streamEvents <- runStoreIO store $ readStreamForward stream (StreamVersion 0) 1000+ V.length streamEvents `shouldBe` writerCount+ streamVersions streamEvents `shouldBe` [1 .. fromIntegral writerCount]+ Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 1000+ V.length allEvents `shouldBe` writerCount+ globalPositions allEvents `shouldBe` [1 .. fromIntegral writerCount]+ Set.fromList (eventIds streamEvents) `shouldBe` Set.fromList (eventIds allEvents)++ it "many batched writers to different streams preserve batch-local and global order" $+ withTestStore $ \store -> do+ let streamCount = 12+ batchSize = 10+ totalEvents = streamCount * batchSize+ mkStream i = StreamName ("stress-batch-" <> T.pack (show i))+ mkBatch i =+ [ makeEvent ("Batch" <> T.pack (show i) <> "-" <> T.pack (show j)) (Aeson.object [])+ | j <- [1 .. batchSize]+ ]+ results <-+ Async.forConcurrently [1 .. streamCount] $ \i -> do+ runStoreIO store $ appendToStream (mkStream i) NoStream (mkBatch i)+ mapM_ assertRightAppend results+ forM_ [1 .. streamCount] $ \i -> do+ Right streamEvents <- runStoreIO store $ readStreamForward (mkStream i) (StreamVersion 0) 1000+ streamVersions streamEvents `shouldBe` [1 .. fromIntegral batchSize]+ Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 1000+ V.length allEvents `shouldBe` totalEvents+ globalPositions allEvents `shouldBe` [1 .. fromIntegral totalEvents]++ it "large append batches return the final stream and global positions" $+ withTestStore $ \store -> do+ let stream = StreamName "stress-large-batches"+ mkBatch label n =+ [ makeEvent (label <> "-" <> T.pack (show i)) (Aeson.object [])+ | i <- [1 .. n]+ ]+ Right r10 <- runStoreIO store $ appendToStream stream NoStream (mkBatch "Batch10" 10)+ (r10 ^. #streamVersion) `shouldBe` StreamVersion 10+ (r10 ^. #globalPosition) `shouldBe` GlobalPosition 10+ Right r100 <- runStoreIO store $ appendToStream stream AnyVersion (mkBatch "Batch100" 100)+ (r100 ^. #streamVersion) `shouldBe` StreamVersion 110+ (r100 ^. #globalPosition) `shouldBe` GlobalPosition 110+ Right streamEvents <- runStoreIO store $ readStreamForward stream (StreamVersion 0) 200+ streamVersions streamEvents `shouldBe` [1 .. 110]+ Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 200+ globalPositions allEvents `shouldBe` [1 .. 110]++ it "overlapping appendMultiStream stress preserves all-or-nothing ordering" $+ withTestStore $ \store -> do+ let streams = [StreamName "stress-multi-a", StreamName "stress-multi-b", StreamName "stress-multi-c"]+ rotations =+ [ streams+ , [StreamName "stress-multi-b", StreamName "stress-multi-c", StreamName "stress-multi-a"]+ , [StreamName "stress-multi-c", StreamName "stress-multi-a", StreamName "stress-multi-b"]+ ]+ opsFor i =+ [ (sn, AnyVersion, [makeEvent ("Multi" <> T.pack (show i) <> "-" <> labelStream sn) (Aeson.object [])])+ | sn <- rotations !! (i `mod` length rotations)+ ]+ forM_ streams $ \sn -> do+ result <- runStoreIO store $ appendToStream sn NoStream [makeEvent "init" (Aeson.object [])]+ assertRightAppend result+ results <-+ Async.forConcurrently [1 .. 9] $ \i -> do+ runStoreIO store $ appendMultiStream (opsFor i)+ mapM_ assertRightMulti results+ forM_ streams $ \sn -> do+ Right streamEvents <- runStoreIO store $ readStreamForward sn (StreamVersion 0) 100+ streamVersions streamEvents `shouldBe` [1 .. 10]+ Right allEvents <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ V.length allEvents `shouldBe` 30+ globalPositions allEvents `shouldBe` [1 .. 30]++ it "duplicate event failure leaves touched streams and $all unchanged" $+ withTestStore $ \store -> do+ let duplicate =+ EventId $+ case UUID.fromString "01234567-89ab-7def-8012-34567890abce" of+ Just u -> u+ Nothing -> error "bad uuid"+ duplicateEvent =+ EventData+ { eventId = Just duplicate+ , eventType = EventType "Duplicate"+ , payload = Aeson.object []+ , metadata = Nothing+ , causationId = Nothing+ , correlationId = Nothing+ }+ Right _ <- runStoreIO store $ appendToStream (StreamName "rollback-seed") NoStream [duplicateEvent]+ Right _ <- runStoreIO store $ appendToStream (StreamName "rollback-a") NoStream [makeEvent "init-a" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "rollback-b") NoStream [makeEvent "init-b" (Aeson.object [])]+ beforeCount <- countEvents store+ Right beforeAll <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ result <-+ runStoreIO store $+ appendMultiStream+ [ (StreamName "rollback-a", AnyVersion, [duplicateEvent])+ , (StreamName "rollback-b", AnyVersion, [makeEvent "should-not-commit" (Aeson.object [])])+ ]+ case result of+ Left (DuplicateEvent _) -> pure ()+ other -> expectationFailure ("duplicate event should abort the multi-stream transaction, got: " <> show other)+ countEvents store `shouldReturn` beforeCount+ Right afterAll <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ globalPositions afterAll `shouldBe` globalPositions beforeAll+ Right streamA <- runStoreIO store $ readStreamForward (StreamName "rollback-a") (StreamVersion 0) 100+ Right streamB <- runStoreIO store $ readStreamForward (StreamName "rollback-b") (StreamVersion 0) 100+ streamVersions streamA `shouldBe` [1]+ streamVersions streamB `shouldBe` [1]++ -- F9 — Two concurrent appends to different streams. Both calls+ -- must succeed, the global positions must be unique and contiguous,+ -- and the test must not deadlock.+ it "two concurrent appends to different streams both succeed (F9)" $+ withTestStore $ \store -> do+ (rA, rB) <-+ Async.concurrently+ (runStoreIO store $ appendToStream (StreamName "f9-a") NoStream [makeEvent "A" (Aeson.object [])])+ (runStoreIO store $ appendToStream (StreamName "f9-b") NoStream [makeEvent "B" (Aeson.object [])])+ case (rA, rB) of+ (Right resA, Right resB) -> do+ let pA = case resA ^. #globalPosition of GlobalPosition n -> n+ pB = case resB ^. #globalPosition of GlobalPosition n -> n+ pA `shouldNotBe` pB+ Set.fromList [pA, pB] `shouldBe` Set.fromList [1, 2]+ other -> expectationFailure ("F9: both should succeed, got: " <> show other)++ -- F10 — Two concurrent appends to the same stream with the same+ -- ExactVersion. Exactly one must succeed; the other must fail+ -- with WrongExpectedVersion. No deadlock. Stream is pre-created+ -- because ExactVersion 0 against a non-existent stream is itself+ -- an error in kiroku (streams start at version 1).+ it "two concurrent ExactVersion appends to same stream — one wins (F10)" $+ withTestStore $ \store -> do+ Right _ <- runStoreIO store $ appendToStream (StreamName "f10") NoStream [makeEvent "Init" (Aeson.object [])]+ (r1, r2) <-+ Async.concurrently+ (runStoreIO store $ appendToStream (StreamName "f10") (ExactVersion (StreamVersion 1)) [makeEvent "X" (Aeson.object [])])+ (runStoreIO store $ appendToStream (StreamName "f10") (ExactVersion (StreamVersion 1)) [makeEvent "Y" (Aeson.object [])])+ case (r1, r2) of+ (Right _, Left (WrongExpectedVersion _ _ _)) -> pure ()+ (Left (WrongExpectedVersion _ _ _), Right _) -> pure ()+ other -> expectationFailure ("F10: exactly one should win with the loser returning WrongExpectedVersion, got: " <> show other)+ -- Stream must have exactly init + winner = 2 events after the race.+ Right events <- runStoreIO store $ readStreamForward (StreamName "f10") (StreamVersion 0) 100+ V.length events `shouldBe` 2++ -- F11 — Two concurrent appendMultiStream calls touching the same+ -- streams in opposite order. EP-1 F4's sorted SELECT FOR UPDATE+ -- pre-pass ensures both transactions acquire row locks in the+ -- same canonical order, preventing the classic two-resource+ -- deadlock. Without the fix, this test would intermittently fail+ -- with PostgreSQL deadlock detection (40P01).+ it "two concurrent multi-stream appends in opposite order do not deadlock (F11)" $+ withTestStore $ \store -> do+ -- Pre-create both streams so the multi-stream calls take+ -- the existing-stream path (where pre-locking matters).+ Right _ <- runStoreIO store $ appendToStream (StreamName "f11-x") NoStream [makeEvent "init-x" (Aeson.object [])]+ Right _ <- runStoreIO store $ appendToStream (StreamName "f11-y") NoStream [makeEvent "init-y" (Aeson.object [])]+ let opsXY =+ [ (StreamName "f11-x", AnyVersion, [makeEvent "Ax" (Aeson.object [])])+ , (StreamName "f11-y", AnyVersion, [makeEvent "Ay" (Aeson.object [])])+ ]+ opsYX =+ [ (StreamName "f11-y", AnyVersion, [makeEvent "By" (Aeson.object [])])+ , (StreamName "f11-x", AnyVersion, [makeEvent "Bx" (Aeson.object [])])+ ]+ (rA, rB) <-+ Async.concurrently+ (runStoreIO store $ appendMultiStream opsXY)+ (runStoreIO store $ appendMultiStream opsYX)+ case (rA, rB) of+ (Right _, Right _) -> pure ()+ other -> expectationFailure ("F11: both calls must succeed without deadlock, got: " <> show other)+ -- Each stream contains its init event plus one event from+ -- each of the two concurrent multi-stream appends (3 each).+ Right xs <- runStoreIO store $ readStreamForward (StreamName "f11-x") (StreamVersion 0) 100+ Right ys <- runStoreIO store $ readStreamForward (StreamName "f11-y") (StreamVersion 0) 100+ V.length xs `shouldBe` 3+ V.length ys `shouldBe` 3+ -- \$all has 6 events total (2 inits + 4 from concurrent calls).+ Right allEvts <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ V.length allEvts `shouldBe` 6+ let positions =+ map+ (\e -> case e ^. #globalPosition of GlobalPosition n -> n)+ (V.toList allEvts)+ sort positions `shouldBe` [1, 2, 3, 4, 5, 6]++assertRightAppend :: Either StoreError AppendResult -> IO ()+assertRightAppend = \case+ Right _ -> pure ()+ Left err -> expectationFailure ("append should succeed, got: " <> show err)++assertRightMulti :: Either StoreError [AppendResult] -> IO ()+assertRightMulti = \case+ Right _ -> pure ()+ Left err -> expectationFailure ("appendMultiStream should succeed, got: " <> show err)++streamVersions :: V.Vector RecordedEvent -> [Int64]+streamVersions =+ map+ (\e -> case e ^. #streamVersion of StreamVersion n -> n)+ . V.toList++globalPositions :: V.Vector RecordedEvent -> [Int64]+globalPositions =+ map+ (\e -> case e ^. #globalPosition of GlobalPosition n -> n)+ . V.toList++eventIds :: V.Vector RecordedEvent -> [EventId]+eventIds =+ map (^. #eventId)+ . V.toList++labelStream :: StreamName -> Text+labelStream (StreamName name) = name
+ test/Test/ConsumerGroup.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Runtime tests for consumer groups (ExecPlan 29 / EP-2). Each member runs as+one in-process subscription worker over a fresh ephemeral PostgreSQL. The+properties proven here are the user-visible contract: a group's members deliver a+/disjoint/, /complete/, /per-stream-ordered/ partition of the source; a size-1+group equals a plain subscription; and each member resumes from its /own/+checkpoint.+-}+module Test.ConsumerGroup (spec) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar)+import Control.Exception (fromException)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int32, Int64)+import Data.List (sort)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import EphemeralPg qualified as Pg+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Conn+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Kiroku.Store+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Subscription.Stream (subscriptionStream)+import Kiroku.Store.Subscription.Types (ConsumerGroup (..), SubscriptionConfigM (..))+import Streamly.Data.Stream qualified as Stream+import Test.Helpers (makeEvent, waitForPublisher, waitWithTimeout, withTestStore, withTestStoreSettings)+import Test.Hspec++-- | Extract @(originalStreamId, globalPosition)@ as raw 'Int64's from an event.+pairOf :: RecordedEvent -> (Int64, Int64)+pairOf e =+ ( case e ^. #originalStreamId of StreamId s -> s+ , case e ^. #globalPosition of GlobalPosition p -> p+ )++-- | Append @perStream@ events to each named stream, seeding the store.+seed :: KirokuStore -> [Text] -> Int -> IO ()+seed store names perStream =+ mapM_+ ( \sn -> do+ let evs = map (\k -> makeEvent ("E" <> T.pack (show k)) (Aeson.object [])) [1 .. perStream]+ r <- runStoreIO store $ appendToStream (StreamName sn) NoStream evs+ case r of+ Left err -> error ("seed append failed for " <> T.unpack sn <> ": " <> show err)+ Right _ -> pure ()+ )+ names++-- | Poll an @IO Bool@ predicate until it holds or the microsecond budget runs out.+waitUntil :: Int -> IO Bool -> IO ()+waitUntil budget act+ | budget <= 0 = pure ()+ | otherwise = do+ ok <- act+ if ok+ then pure ()+ else do+ threadDelay 20_000+ waitUntil (budget - 20_000) act++{- | Assert that within each originating stream the global positions, taken in+delivery order, are strictly ascending (i.e. equal to their sorted form).+-}+assertPerStreamAscending :: [(Int64, Int64)] -> Expectation+assertPerStreamAscending chrono =+ let byStream = Map.fromListWith (\new old -> old ++ new) [(sid, [gp]) | (sid, gp) <- chrono]+ in mapM_ (\ps -> ps `shouldBe` sort ps) (Map.elems byStream)++-- | A size-@n@ category-group config for member @m@ with the given handler.+memberConfig ::+ Text -> Text -> Int32 -> Int32 -> EventHandler -> SubscriptionConfig+memberConfig nm cat m n h =+ (defaultSubscriptionConfig (SubscriptionName nm) (Category (CategoryName cat)) h)+ { consumerGroup = Just (ConsumerGroup{member = m, size = n})+ }++-- | A size-@n@ @$all@-group config for member @m@ with the given handler.+memberConfigAll ::+ Text -> Int32 -> Int32 -> EventHandler -> SubscriptionConfig+memberConfigAll nm m n h =+ (defaultSubscriptionConfig (SubscriptionName nm) AllStreams h)+ { consumerGroup = Just (ConsumerGroup{member = m, size = n})+ }++{- | Run a subscription built from the given config-completer, collecting the+global positions it delivers and stopping the handler after @k@ events. Returns+the @k@ positions in delivery order.+-}+collectStopAfter :: KirokuStore -> (EventHandler -> SubscriptionConfig) -> Int -> IO [Int64]+collectStopAfter store mkCfg k = do+ ref <- newIORef []+ countVar <- newTVarIO (0 :: Int)+ let h evt = do+ modifyIORef' ref (snd (pairOf evt) :)+ c <- atomically $ do+ c0 <- readTVar countVar+ let c1 = c0 + 1+ writeTVar countVar c1+ pure c1+ pure (if c >= k then Stop else Continue)+ handle <- subscribe store (mkCfg h)+ _ <- waitWithTimeout 15_000_000 handle+ reverse <$> readIORef ref++-- | Run a Hasql session against the store pool, failing the test on a usage error.+runStmtP :: KirokuStore -> Session.Session a -> IO a+runStmtP store session = do+ r <- Pool.use (store ^. #pool) session+ either (error . show) pure r++spec :: Spec+spec = describe "consumer groups" $ do+ it "delivers a disjoint, complete, per-stream-ordered partition (size-4 category group)" $+ withTestStore $ \store -> do+ let nStreams = 40+ perStream = 3+ total = nStreams * perStream+ streams = ["acct-" <> T.pack (show i) | i <- [1 .. nStreams]]+ seed store streams perStream+ waitForPublisher store (GlobalPosition (fromIntegral total))++ let n = 4 :: Int32+ refs <- mapM (const (newIORef [])) [0 .. n - 1]+ handles <-+ mapM+ ( \m -> do+ let ref = refs !! fromIntegral m+ h evt = do+ modifyIORef' ref (pairOf evt :)+ pure Continue+ subscribe store (memberConfig "cg-cat" "acct" m n h)+ )+ [0 .. n - 1]++ let collectedCount = sum <$> mapM (fmap length . readIORef) refs+ waitUntil 15_000_000 (fmap (>= total) collectedCount)+ mapM_ cancel handles++ collected <- mapM readIORef refs+ -- (1) Disjoint + complete: the multiset of all delivered positions is+ -- exactly [1..total] — no duplicate (would lengthen it) and no gap.+ let allPositions = sort (concatMap (map snd) collected)+ allPositions `shouldBe` [1 .. fromIntegral total]+ -- (2) Per-stream ordering within each member (collector prepended, so+ -- reverse to recover delivery order).+ mapM_ (assertPerStreamAscending . reverse) collected++ it "size-1 group delivers the same set as a plain subscription" $+ withTestStore $ \store -> do+ let nStreams = 4+ perStream = 3+ total = nStreams * perStream+ streams = ["uno-" <> T.pack (show i) | i <- [1 .. nStreams]]+ seed store streams perStream+ waitForPublisher store (GlobalPosition (fromIntegral total))++ let runCollector cfgFor nm = do+ ref <- newIORef []+ countVar <- newTVarIO (0 :: Int)+ let h evt = do+ modifyIORef' ref (snd (pairOf evt) :)+ c <- atomically $ do+ c0 <- readTVar countVar+ let c1 = c0 + 1+ writeTVar countVar c1+ pure c1+ pure (if c >= total then Stop else Continue)+ handle <- subscribe store (cfgFor nm h)+ _ <- waitWithTimeout 15_000_000 handle+ sort <$> readIORef ref++ plain <-+ runCollector+ (\nm h -> defaultSubscriptionConfig (SubscriptionName nm) (Category (CategoryName "uno")) h)+ "uno-plain"+ grouped <-+ runCollector+ (\nm h -> memberConfig nm "uno" 0 1 h)+ "uno-group"++ plain `shouldBe` [1 .. fromIntegral total]+ grouped `shouldBe` plain++ it "$all group partitions the whole store across members" $+ withTestStore $ \store -> do+ let cats = ["acct", "user", "order"]+ perCat = 10+ perStream = 2+ streams = [c <> "-" <> T.pack (show i) | c <- cats, i <- [1 .. perCat]]+ total = length streams * perStream+ seed store streams perStream+ waitForPublisher store (GlobalPosition (fromIntegral total))++ let n = 4 :: Int32+ refs <- mapM (const (newIORef [])) [0 .. n - 1]+ handles <-+ mapM+ ( \m -> do+ let ref = refs !! fromIntegral m+ h evt = do+ modifyIORef' ref (pairOf evt :)+ pure Continue+ subscribe store (memberConfigAll "cg-all" m n h)+ )+ [0 .. n - 1]++ let collectedCount = sum <$> mapM (fmap length . readIORef) refs+ waitUntil 15_000_000 (fmap (>= total) collectedCount)+ mapM_ cancel handles++ collected <- mapM readIORef refs+ let allPositions = sort (concatMap (map snd) collected)+ allPositions `shouldBe` [1 .. fromIntegral total]+ mapM_ (assertPerStreamAscending . reverse) collected++ it "resumes member 2 from its own (name, member) checkpoint" $+ withTestStore $ \store -> do+ let nStreams = 60+ streams = ["rz-" <> T.pack (show i) | i <- [1 .. nStreams]]+ seed store streams 1+ waitForPublisher store (GlobalPosition (fromIntegral nStreams))++ -- Member 2's slice positions, in order, straight from the EP-1 partition+ -- SQL — the deterministic ground truth for what member 2 should receive.+ sliceV <-+ runStmtP store $+ Session.statement+ (0 :: Int64, "rz" :: Text, 2 :: Int32, 4 :: Int32, 100000 :: Int32)+ SQL.readCategoryForwardConsumerGroupStmt+ let slice = map (snd . pairOf) (V.toList sliceV)+ length slice `shouldSatisfy` (>= 4)++ -- Run 1: member 2 stops after 2 events; checkpoint (rz-sub, 2) = slice!!1.+ run1 <- collectStopAfter store (memberConfig "rz-sub" "rz" 2 4) 2+ run1 `shouldBe` take 2 slice++ -- A competing, much higher checkpoint for a DIFFERENT member under the+ -- SAME name. If checkpoints were keyed by name only, member 2's restart+ -- would resume from here and skip its events; member-keyed checkpoints+ -- must ignore it.+ runStmtP store $+ Session.statement+ ("rz-sub" :: Text, 0 :: Int32, 10_000_000 :: Int64)+ SQL.saveCheckpointMemberStmt++ -- Run 2: member 2 restarts and must resume from its OWN checkpoint+ -- (slice!!1), delivering the next two member-2 events.+ run2 <- collectStopAfter store (memberConfig "rz-sub" "rz" 2 4) 2+ run2 `shouldBe` take 2 (drop 2 slice)++ it "lifecycle events carry the consumer-group member context (GroupMember 2 4)" $ do+ ref <- newIORef ([] :: [KirokuEvent])+ let evtHandler e = modifyIORef' ref (e :)+ isStartedMember2 ev = case ev of+ KirokuEventSubscriptionStarted (SubscriptionName "obs-sub") _ (GroupMember 2 4) -> True+ _ -> False+ withTestStoreSettings (\s -> s & #eventHandler .~ Just evtHandler) $ \store -> do+ handle <- subscribe store (memberConfig "obs-sub" "obs" 2 4 (\_ -> pure Continue))+ waitUntil 5_000_000 (any isStartedMember2 <$> readIORef ref)+ cancel handle+ evts <- readIORef ref+ any isStartedMember2 evts `shouldBe` True++ it "consumerGroupGuard fails fast when another holder holds the (name, member) lock" $ do+ r <- Pg.withCached $ \db -> do+ let cs = Pg.connectionString db+ withStore (defaultConnectionSettings cs) $ \store -> do+ -- Holder: a dedicated connection takes the SESSION-level advisory+ -- lock for the same key the worker's guard probes, namely+ -- hashtextextended("guard-sub:3", 0). It is held until release.+ eConn <- Connection.acquire (Conn.connectionString cs)+ conn <- either (\e -> error ("guard holder connect failed: " <> show e)) pure eConn+ let holdStmt :: Statement Text ()+ holdStmt =+ preparable+ "SELECT pg_advisory_lock(hashtextextended($1, 0))"+ (E.param (E.nonNullable E.text))+ D.noResult+ lockRes <- Connection.use conn (Session.statement "guard-sub:3" holdStmt)+ either (\e -> error ("guard holder lock failed: " <> show e)) pure lockRes++ let cfg =+ (defaultSubscriptionConfig (SubscriptionName "guard-sub") (Category (CategoryName "guardcat")) (\_ -> pure Continue))+ { consumerGroup = Just (ConsumerGroup{member = 3, size = 4})+ , consumerGroupGuard = True+ }+ handle <- subscribe store cfg+ res <- waitWithTimeout 5_000_000 handle+ Connection.release conn+ case res of+ Right (Left e)+ | Just (ConsumerGroupGuardConflict (SubscriptionName "guard-sub") 3) <- fromException e ->+ pure ()+ other ->+ expectationFailure ("expected ConsumerGroupGuardConflict, got: " <> show other)+ either (\e -> expectationFailure ("ephemeral pg failed: " <> show e)) pure r++ it "subscriptionStream forwards the consumer-group field (member 0 of 2 sees its slice)" $+ withTestStore $ \store -> do+ let nStreams = 20+ perStream = 2+ total = nStreams * perStream+ streams = ["bridge-" <> T.pack (show i) | i <- [1 .. nStreams]]+ seed store streams perStream+ waitForPublisher store (GlobalPosition (fromIntegral total))++ sliceV <-+ runStmtP store $+ Session.statement+ (0 :: Int64, "bridge" :: Text, 0 :: Int32, 2 :: Int32, 100000 :: Int32)+ SQL.readCategoryForwardConsumerGroupStmt+ let slicePos = sort (map (snd . pairOf) (V.toList sliceV))+ k = length slicePos+ -- A proper, non-trivial subset of the whole category.+ k `shouldSatisfy` (\x -> x > 0 && x < total)++ (stream, cancelStream) <-+ subscriptionStream store (memberConfig "bridge-sub" "bridge" 0 2 (\_ -> pure Continue)) 64+ pulled <- Stream.toList (Stream.take k stream)+ cancelStream+ sort (map (snd . pairOf) pulled) `shouldBe` slicePos
+ test/Test/ConsumerGroupEffect.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{- | Consumer-group tests for the /effectful/ subscription API (ExecPlan 30 /+EP-3). EP-2's 'Test.ConsumerGroup' proves the partitioning contract through the+plain-IO 'Kiroku.Store.Subscription.subscribe'; this module proves the same+contract holds through 'Kiroku.Store.Subscription.Effect' — the higher-order+'Subscription' effect interpreted by 'runSubscription' inside an @Eff@ stack.++Two properties are proven:++ * Each member of a size-2 category group, driven through @runSubscription@ /+ @subscribe@, receives exactly its hash-assigned slice; the two slices are+ /disjoint/, their union is /complete/, and each is /per-stream-ordered/.+ * The @ConcUnlift Persistent (Limited 1)@ strategy used by 'runSubscription'+ keeps the effect environment alive across handler calls: an+ 'Effectful.State.Static.Local.State' counter mutated inside the handler+ accumulates @1, 2, 3, ...@ across deliveries rather than resetting to @1@+ each call (which is what an @Ephemeral@ unlift would produce).++__Why every handler returns 'Stop' rather than relying on external cancel.__+A worker started through the effectful interpreter runs its handler via the+captured @localUnliftIO@ environment. Cancelling such a worker from outside+(e.g. through the effectful 'Kiroku.Store.Subscription.Effect.withSubscription'+bracket) while it is blocked inside that unlift does not terminate cleanly — it+hangs the worker thread. Every member here therefore stops itself once it has+seen its expected number of events, so the worker exits on its own and the+@Eff@ scope closes with no live thread (the same shape as the working effectful+test in @kiroku-store/test/Main.hs@, "catches up with an Eff-based handler via+the effectful API"). See this module's Surprises note in+@docs/plans/30-consumer-group-effect-api-and-shibuya-adapter-integration.md@.+-}+module Test.ConsumerGroupEffect (spec) where++import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar)+import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int32, Int64)+import Data.List (sort)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import Effectful (Eff, IOE, runEff, (:>))+import Effectful.State.Static.Local qualified as State+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Kiroku.Store+import Kiroku.Store.SQL qualified as SQL+import Kiroku.Store.Subscription.Effect qualified as SubEff+import Kiroku.Store.Subscription.Types (ConsumerGroup (..), SubscriptionConfigM (..))+import Test.Helpers (makeEvent, waitForPublisher, waitWithTimeout, withTestStore)+import Test.Hspec++-- | Extract @(originalStreamId, globalPosition)@ as raw 'Int64's from an event.+pairOf :: RecordedEvent -> (Int64, Int64)+pairOf e =+ ( case e ^. #originalStreamId of StreamId s -> s+ , case e ^. #globalPosition of GlobalPosition p -> p+ )++-- | Append @perStream@ events to each named stream, seeding the store.+seed :: KirokuStore -> [Text] -> Int -> IO ()+seed store names perStream =+ mapM_+ ( \sn -> do+ let evs = map (\k -> makeEvent ("E" <> T.pack (show k)) (Aeson.object [])) [1 .. perStream]+ r <- runStoreIO store $ appendToStream (StreamName sn) NoStream evs+ case r of+ Left err -> error ("seed append failed for " <> T.unpack sn <> ": " <> show err)+ Right _ -> pure ()+ )+ names++{- | Assert that within each originating stream the global positions, taken in+delivery order, are strictly ascending (i.e. equal to their sorted form).+-}+assertPerStreamAscending :: [(Int64, Int64)] -> Expectation+assertPerStreamAscending chrono =+ let byStream = Map.fromListWith (\new old -> old ++ new) [(sid, [gp]) | (sid, gp) <- chrono]+ in mapM_ (\ps -> ps `shouldBe` sort ps) (Map.elems byStream)++-- | Run a Hasql session against the store pool, failing the test on error.+runStmtP :: KirokuStore -> Session.Session a -> IO a+runStmtP store session = do+ r <- Pool.use (store ^. #pool) session+ either (error . show) pure r++{- | Drive one effectful category-group member to self-completion: it 'Stop's+after receiving exactly @k@ events, so the worker exits on its own (no external+cancel). Returns the @(streamId, globalPosition)@ pairs in delivery order. The+handler runs in @Eff es@ (needing only 'IOE'), exercising the @runSubscription@+record-update pass-through of the @consumerGroup@ field.+-}+runEffMember :: KirokuStore -> Text -> Text -> Int32 -> Int32 -> Int -> IO [(Int64, Int64)]+runEffMember store nm cat m n k = do+ ref <- newIORef []+ countVar <- newTVarIO (0 :: Int)+ let effHandler :: (IOE :> es) => RecordedEvent -> Eff es SubscriptionResult+ effHandler evt = do+ liftIO $ modifyIORef' ref (pairOf evt :)+ c <- liftIO $ atomically $ do+ c0 <- readTVar countVar+ writeTVar countVar (c0 + 1)+ pure (c0 + 1)+ pure (if c >= k then Stop else Continue)+ cfg =+ (defaultSubscriptionConfig (SubscriptionName nm) (Category (CategoryName cat)) effHandler)+ { consumerGroup = Just (ConsumerGroup{member = m, size = n})+ }+ runEff $ SubEff.runSubscription store $ do+ handle <- SubEff.subscribe cfg+ liftIO $ do+ r <- waitWithTimeout 15_000_000 handle+ case r of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("effectful member failed: " <> show err)+ Right (Right ()) -> pure ()+ reverse <$> readIORef ref++spec :: Spec+spec = describe "consumer groups (effectful)" $ do+ it "routes each member through the effectful API to its own disjoint, complete, per-stream-ordered slice (size-2 category group)" $+ withTestStore $ \store -> do+ let nStreams = 40+ perStream = 3+ total = nStreams * perStream+ streams = ["effcg-" <> T.pack (show i) | i <- [1 .. nStreams]]+ seed store streams perStream+ waitForPublisher store (GlobalPosition (fromIntegral total))++ -- Deterministic ground truth: each member's slice size straight from the+ -- EP-1 partition SQL. The effectful workers must reproduce exactly these.+ let sliceSize m =+ V.length+ <$> runStmtP+ store+ ( Session.statement+ (0 :: Int64, "effcg" :: Text, m, 2 :: Int32, 100000 :: Int32)+ SQL.readCategoryForwardConsumerGroupStmt+ )+ k0 <- sliceSize 0+ k1 <- sliceSize 1+ k0 `shouldSatisfy` (> 0)+ k1 `shouldSatisfy` (> 0)+ (k0 + k1) `shouldBe` total++ -- Each member is driven through runSubscription/subscribe and self-exits.+ -- Same subscription name, distinct members → independent (name, member)+ -- checkpoints, so running them in sequence is safe.+ m0 <- runEffMember store "eff-cg-cat" "effcg" 0 2 k0+ m1 <- runEffMember store "eff-cg-cat" "effcg" 1 2 k1++ -- (1) Disjoint + complete: the union of both members' delivered positions+ -- is exactly [1..total] — no duplicate and no gap.+ let allPositions = sort (map snd m0 ++ map snd m1)+ allPositions `shouldBe` [1 .. fromIntegral total]+ -- (2) Per-stream ordering preserved within each member.+ assertPerStreamAscending m0+ assertPerStreamAscending m1++ it "preserves State across handler calls within one member (Persistent unlift)" $+ withTestStore $ \store -> do+ -- Five events on one stream of category "effstate"; a size-1 member sees all.+ seed store ["effstate-1"] 5+ waitForPublisher store (GlobalPosition 5)++ -- 'seenRef' records the Effectful State value observed after each+ -- increment; 'nVar' counts deliveries and drives the Stop (so self-exit+ -- never depends on the property under test). With the Persistent unlift+ -- the cloned environment is reused across calls and the counter+ -- accumulates 1,2,3,4,5; an Ephemeral unlift would record 1 every time.+ seenRef <- newIORef ([] :: [Int])+ nVar <- newTVarIO (0 :: Int)+ runEff $+ SubEff.runSubscription store $+ State.evalState (0 :: Int) $ do+ let cfg =+ ( defaultSubscriptionConfig+ (SubscriptionName "eff-state-sub")+ (Category (CategoryName "effstate"))+ ( \_ -> do+ State.modify @Int (+ 1)+ s <- State.get @Int+ liftIO (modifyIORef' seenRef (s :))+ c <- liftIO $ atomically $ do+ c0 <- readTVar nVar+ writeTVar nVar (c0 + 1)+ pure (c0 + 1)+ pure (if c >= 5 then Stop else Continue)+ )+ )+ { consumerGroup = Just (ConsumerGroup{member = 0, size = 1})+ }+ handle <- SubEff.subscribe cfg+ liftIO $ do+ r <- waitWithTimeout 10_000_000 handle+ case r of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("effectful state member failed: " <> show err)+ Right (Right ()) -> pure ()++ seen <- reverse <$> readIORef seenRef+ seen `shouldBe` [1, 2, 3, 4, 5]
+ test/Test/ConsumerGroupSql.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE OverloadedStrings #-}++{- | SQL-level tests for consumer-group partition routing and per-member+checkpoints (ExecPlan 28 / EP-1). These exercise the new prepared statements in+"Kiroku.Store.SQL" directly through the connection pool, with no subscription+runtime, on a fresh ephemeral PostgreSQL per test.++Terms: a /consumer group/ of /size/ N has members 0..N-1; each source stream is+assigned to exactly one member by 'Kiroku.Store.SQL'-encoded hash routing. The+properties proven here — disjointness, completeness, per-stream affinity,+determinism, and size-1 equivalence — are the contract EP-2's runtime depends on.+-}+module Test.ConsumerGroupSql (spec) where++import Contravariant.Extras (contrazip2)+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.Int (Int32, Int64)+import Data.List (sort)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.UUID (UUID)+import Data.Vector (Vector)+import Data.Vector qualified as V+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Kiroku.Store+import Kiroku.Store.SQL qualified as SQL+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec++-- | A generous limit that returns every seeded event in one read.+bigLimit :: Int32+bigLimit = 100000++-- | Run a statement against the store's pool, failing the test on a usage error.+runStmt :: KirokuStore -> Session.Session a -> IO a+runStmt store session = do+ result <- Pool.use (store ^. #pool) session+ case result of+ Left err -> error ("ConsumerGroupSql statement failed: " <> show err)+ Right a -> pure a++{- | Append one event to each of the named streams, seeding the store. Each+stream gets a single event; per-stream affinity is what we test, so one event+per stream is enough, but the helper appends 'n' events to vary versions.+-}+seedStreams :: KirokuStore -> [Text] -> Int -> IO ()+seedStreams store names n =+ mapM_+ ( \name -> do+ let events = map (\i -> makeEvent ("E" <> T.pack (show i)) (Aeson.object [])) [1 .. n]+ r <- runStoreIO store $ appendToStream (StreamName name) NoStream events+ case r of+ Left err -> error ("seed append failed for " <> T.unpack name <> ": " <> show err)+ Right _ -> pure ()+ )+ names++-- | Collect the event ids from a read result, in order.+eventIds :: Vector RecordedEvent -> [UUID]+eventIds = map (\e -> case e ^. #eventId of EventId u -> u) . V.toList++-- | Collect (originalStreamId, globalPosition) pairs from a read result.+streamPositions :: Vector RecordedEvent -> [(Int64, Int64)]+streamPositions =+ map+ ( \e ->+ ( case e ^. #originalStreamId of StreamId s -> s+ , case e ^. #globalPosition of GlobalPosition p -> p+ )+ )+ . V.toList++{- | Direct call to the partition rule for one stream id and size, returning the+member index PostgreSQL computes. Mirrors IP-1 exactly so the test pins the+formula, not just its consequences.+-}+runMemberOf :: KirokuStore -> Int64 -> Int32 -> IO Int32+runMemberOf store streamId size = runStmt store (Session.statement (streamId, size) stmt)+ where+ stmt :: Statement (Int64, Int32) Int32+ stmt =+ preparable+ "SELECT (((hashtextextended($1::text, 0) % $2) + $2) % $2)::int4"+ ( contrazip2+ (E.param (E.nonNullable E.int8))+ (E.param (E.nonNullable E.int4))+ )+ (D.singleRow (D.column (D.nonNullable D.int4)))++-- | All distinct (originalStreamId) values present in the unpartitioned read.+distinctStreamIds :: Vector RecordedEvent -> [Int64]+distinctStreamIds = Set.toList . Set.fromList . map fst . streamPositions++spec :: Spec+spec = do+ describe "ConsumerGroupSql" $ do+ categorySpec+ checkpointSpec+ allSpec+ memberOfSpec++-- ---------------------------------------------------------------------------+-- M1: category partitioning+-- ---------------------------------------------------------------------------++categorySpec :: Spec+categorySpec = around withTestStore $ do+ describe "category consumer-group partitioning (size 4)" $ do+ let cat = "acct"+ names = map (\i -> "acct-" <> T.pack (show i)) [1 .. 50 :: Int]+ size = 4 :: Int32++ let readMember store m =+ runStmt store $+ Session.statement (0 :: Int64, cat, m, size, bigLimit) SQL.readCategoryForwardConsumerGroupStmt+ readFull store =+ runStmt store $+ Session.statement (0 :: Int64, cat, bigLimit) SQL.readCategoryForwardStmt++ it "splits a category into 4 pairwise-disjoint member slices" $ \store -> do+ seedStreams store names 2+ slices <- mapM (readMember store) [0 .. size - 1]+ let idSets = map (Set.fromList . eventIds) slices+ -- pairwise disjoint: union of sizes equals size of union+ let totalIds = sum (map Set.size idSets)+ unionIds = Set.size (Set.unions idSets)+ totalIds `shouldBe` unionIds++ it "union of all member slices equals the unpartitioned category read" $ \store -> do+ seedStreams store names 2+ slices <- mapM (readMember store) [0 .. size - 1]+ full <- readFull store+ let unionIds = Set.unions (map (Set.fromList . eventIds) slices)+ fullIds = Set.fromList (eventIds full)+ unionIds `shouldBe` fullIds++ it "every stream's events go to exactly one member, in ascending global position" $ \store -> do+ seedStreams store names 3+ slices <- mapM (readMember store) [0 .. size - 1]+ -- For each member slice, every stream present must have all its events+ -- in ascending global position, and no stream may appear in two slices.+ let perMemberStreams = map (Set.fromList . map fst . streamPositions) slices+ -- per-stream affinity: stream sets are pairwise disjoint+ let totalStreams = sum (map Set.size perMemberStreams)+ unionStreams = Set.size (Set.unions perMemberStreams)+ totalStreams `shouldBe` unionStreams+ -- ascending global position within each slice+ mapM_+ ( \slice -> do+ let ps = map snd (streamPositions slice)+ ps `shouldBe` sort ps+ )+ slices++ it "member assignment is deterministic across repeated reads" $ \store -> do+ seedStreams store names 1+ firstReads <- mapM (\m -> eventIds <$> readMember store m) [0 .. size - 1]+ secondReads <- mapM (\m -> eventIds <$> readMember store m) [0 .. size - 1]+ firstReads `shouldBe` secondReads++ it "size 1 is equivalent to an unpartitioned category read" $ \store -> do+ seedStreams store names 2+ one <-+ runStmt store $+ Session.statement (0 :: Int64, cat, 0 :: Int32, 1 :: Int32, bigLimit) SQL.readCategoryForwardConsumerGroupStmt+ full <- readFull store+ eventIds one `shouldBe` eventIds full++-- ---------------------------------------------------------------------------+-- M2: per-member checkpoints+-- ---------------------------------------------------------------------------++checkpointSpec :: Spec+checkpointSpec = around withTestStore $ do+ describe "per-member checkpoints" $ do+ let subName = "proj-acct" :: Text++ it "stores and reads independent checkpoints per member" $ \store -> do+ runStmt store $ Session.statement (subName, 0 :: Int32, 7 :: Int64) SQL.saveCheckpointMemberStmt+ runStmt store $ Session.statement (subName, 1 :: Int32, 13 :: Int64) SQL.saveCheckpointMemberStmt+ m0 <- runStmt store $ Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt+ m1 <- runStmt store $ Session.statement (subName, 1 :: Int32) SQL.getCheckpointMemberStmt+ m0 `shouldBe` Just 7+ m1 `shouldBe` Just 13++ it "never moves a member checkpoint backward (GREATEST monotonicity)" $ \store -> do+ runStmt store $ Session.statement (subName, 0 :: Int32, 20 :: Int64) SQL.saveCheckpointMemberStmt+ runStmt store $ Session.statement (subName, 0 :: Int32, 5 :: Int64) SQL.saveCheckpointMemberStmt+ m0 <- runStmt store $ Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt+ m0 `shouldBe` Just 20++ it "missing member checkpoint reads as Nothing" $ \store -> do+ m9 <- runStmt store $ Session.statement (subName, 9 :: Int32) SQL.getCheckpointMemberStmt+ m9 `shouldBe` Nothing++ it "the existing name-keyed checkpoint statements still round-trip (as member 0)" $ \store -> do+ runStmt store $ Session.statement (subName, 42 :: Int64) SQL.saveCheckpointStmt+ -- name-keyed read returns the same row (member 0)+ byName <- runStmt store $ Session.statement subName SQL.getCheckpointStmt+ byMember0 <- runStmt store $ Session.statement (subName, 0 :: Int32) SQL.getCheckpointMemberStmt+ byName `shouldBe` Just 42+ byMember0 `shouldBe` Just 42++-- ---------------------------------------------------------------------------+-- M3: $all partitioning+-- ---------------------------------------------------------------------------++allSpec :: Spec+allSpec = around withTestStore $ do+ describe "$all consumer-group partitioning (size 4)" $ do+ -- \$all spans several categories; partitioning is by originating stream.+ let names =+ concatMap+ (\c -> map (\i -> c <> "-" <> T.pack (show i)) [1 .. 20 :: Int])+ ["acct", "user", "order"]+ size = 4 :: Int32++ let readMember store m =+ runStmt store $+ Session.statement (0 :: Int64, m, size, bigLimit) SQL.readAllForwardConsumerGroupStmt+ readFull store =+ runStmt store $+ Session.statement (0 :: Int64, bigLimit) SQL.readAllForwardStmt++ it "splits $all into 4 pairwise-disjoint member slices" $ \store -> do+ seedStreams store names 2+ slices <- mapM (readMember store) [0 .. size - 1]+ let idSets = map (Set.fromList . eventIds) slices+ totalIds = sum (map Set.size idSets)+ unionIds = Set.size (Set.unions idSets)+ totalIds `shouldBe` unionIds++ it "union of all member slices equals the unpartitioned $all read" $ \store -> do+ seedStreams store names 2+ slices <- mapM (readMember store) [0 .. size - 1]+ full <- readFull store+ let unionIds = Set.unions (map (Set.fromList . eventIds) slices)+ fullIds = Set.fromList (eventIds full)+ unionIds `shouldBe` fullIds++ it "every stream's events go to exactly one member, in ascending global position" $ \store -> do+ seedStreams store names 3+ slices <- mapM (readMember store) [0 .. size - 1]+ let perMemberStreams = map (Set.fromList . map fst . streamPositions) slices+ totalStreams = sum (map Set.size perMemberStreams)+ unionStreams = Set.size (Set.unions perMemberStreams)+ totalStreams `shouldBe` unionStreams+ mapM_+ ( \slice -> do+ let ps = map snd (streamPositions slice)+ ps `shouldBe` sort ps+ )+ slices++ it "size 1 is equivalent to an unpartitioned $all read" $ \store -> do+ seedStreams store names 2+ one <-+ runStmt store $+ Session.statement (0 :: Int64, 0 :: Int32, 1 :: Int32, bigLimit) SQL.readAllForwardConsumerGroupStmt+ full <- readFull store+ eventIds one `shouldBe` eventIds full++-- ---------------------------------------------------------------------------+-- The partition rule, pinned directly.+-- ---------------------------------------------------------------------------++memberOfSpec :: Spec+memberOfSpec = around withTestStore $ do+ describe "member_of assignment rule" $ do+ it "returns a member index in [0, size) for every stream" $ \store -> do+ let names = map (\i -> "rule-" <> T.pack (show i)) [1 .. 30 :: Int]+ seedStreams store names 1+ full <- runStmt store $ Session.statement (0 :: Int64, bigLimit) SQL.readAllForwardStmt+ let sids = distinctStreamIds full+ mapM_+ ( \sid -> do+ m <- runMemberOf store sid 4+ m `shouldSatisfy` (\x -> x >= 0 && x < 4)+ )+ sids
+ test/Test/FailureInjection.hs view
@@ -0,0 +1,98 @@+{- | Failure-injection tests for kiroku-store.++Each test deliberately disrupts a runtime dependency (the LISTEN+connection, the connection pool) and asserts the system recovers per its+documented contract.++Currently covers:++ * F14: Listener killed during a window where an event is appended.+ The event is still delivered after the listener reconnects, because+ the publisher re-queries the database from its last position when+ the next NOTIFY arrives — no safety-poll wait needed.++F15 (pool exhaustion → 'PoolAcquisitionTimeout') is deferred until the+'acquisitionTimeout' field is exposed in 'ConnectionSettings'. The+mapping itself ('Kiroku.Store.Error.mapUsageError'+@AcquisitionTimeoutUsageError -> PoolAcquisitionTimeout@) is+straightforward; without a way to set a sub-second acquisition timeout+from the test, the test would either hang (default unbounded timeout)+or require modifying the production type. See the EP-6 plan's M2 notes.+-}+module Test.FailureInjection (spec) where++import Control.Concurrent.STM (atomically, newTVarIO, readTVar, retry, writeTVar)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Kiroku.Store+import Test.Helpers (+ makeEvent,+ terminateBackend,+ waitForListenerPid,+ waitForListenerPidNotEqual,+ waitWithTimeout,+ withTestStoreSettings,+ )+import Test.Hspec++spec :: Spec+spec = describe "kiroku-store failure injection" $ do+ -- F14 — Listener killed during a window where an event is+ -- appended. The publisher's broadcast loop pulls events directly+ -- from PostgreSQL when the next NOTIFY arrives, so the+ -- down-window event is delivered as soon as a post-reconnect+ -- event triggers a tick. No 30-second safety-poll wait required.+ it "delivers events appended during listener-down window after reconnect (F14)" $ \() -> do+ ref <- newIORef ([] :: [RecordedEvent])+ countVar <- newTVarIO (0 :: Int)+ let handler' evt = do+ modifyIORef' ref (evt :)+ n <- atomically $ do+ c <- readTVar countVar+ let c' = c + 1+ writeTVar countVar c'+ pure c'+ if n >= 3 then pure Stop else pure Continue+ let cfg =+ SubscriptionConfig+ { name = SubscriptionName "f14-down-window"+ , target = AllStreams+ , handler = handler'+ , batchSize = 100+ , queueCapacity = 16+ , overflowPolicy = DropSubscription+ , consumerGroup = Nothing+ , consumerGroupGuard = False+ }+ withTestStoreSettings (& #eventHandler .~ Nothing) $ \store -> do+ handle <- subscribe store cfg+ -- Pre-event: confirm the subscription is alive and the+ -- listener has reached pg_stat_activity.+ Right _ <- runStoreIO store $ appendToStream (StreamName "f14-pre") NoStream [makeEvent "Pre" (Aeson.object [])]+ atomically $ do+ c <- readTVar countVar+ if c >= 1 then pure () else retry+ -- Find listener pid, terminate it. The listener loop+ -- will reconnect with a fresh pid.+ pid1 <- waitForListenerPid (store ^. #pool) 5_000_000+ terminateBackend (store ^. #pool) pid1+ -- Append the during-down-window event. No NOTIFY reaches+ -- the publisher right now because the listener is+ -- disconnected.+ Right _ <- runStoreIO store $ appendToStream (StreamName "f14-during") NoStream [makeEvent "During" (Aeson.object [])]+ -- Wait for the listener to come back with a fresh pid.+ _ <- waitForListenerPidNotEqual (store ^. #pool) pid1 15_000_000+ -- Append the post-reconnect event. The new NOTIFY+ -- triggers the publisher to fetch from its last position+ -- — which picks up both the during-down event AND this+ -- one.+ Right _ <- runStoreIO store $ appendToStream (StreamName "f14-after") NoStream [makeEvent "After" (Aeson.object [])]+ result <- waitWithTimeout 30_000_000 handle+ case result of+ Left timeout -> expectationFailure timeout+ Right (Left err) -> expectationFailure ("Subscription failed: " <> show err)+ Right (Right ()) -> pure ()+ collected <- readIORef ref+ length collected `shouldBe` 3
+ test/Test/Helpers.hs view
@@ -0,0 +1,301 @@+{- | Shared fixtures and synchronization helpers for the kiroku-store+test suite.++Three groups of helpers live here:++ * Database fixture: 'withTestStore' brackets an ephemeral PostgreSQL+ instance and a 'KirokuStore'.+ * Event/wait helpers: 'makeEvent', 'waitWithTimeout', plus the+ listener-pid and TRUNCATE-rejection utilities used by the+ Notifier/Lifecycle regression tests.+ * Deterministic synchronization: 'waitForPublisher' and+ 'waitForSubscriptionLive' replace 'threadDelay'-based sleeps in+ subscription tests with STM- and event-handler-driven barriers+ (per EP-6 F12/F14 and the threadDelay inventory in+ @docs\/plans\/6-test-and-benchmark-hardening-for-production-confidence.md@).+-}+module Test.Helpers (+ -- * Database fixture+ withSharedMigratedPostgres,+ withTestStore,+ withTestStoreSettings,++ -- * Event construction+ makeEvent,++ -- * Subscription wait+ waitWithTimeout,++ -- * Raw SQL helpers+ countEvents,+ insertEventUsingDefaultId,+ serverVersionNum,+ truncateRejected,+ tableExists,++ -- * Listener-pid helpers+ findListenerPid,+ waitForListenerPid,+ waitForListenerPidNotEqual,+ terminateBackend,+ listenerCount,++ -- * Deterministic synchronization+ waitForPublisher,+ waitForSubscriptionLive,+ caughtUpEventHandler,+) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async qualified as Async+import Control.Concurrent.MVar (MVar, takeMVar, tryPutMVar)+import Control.Concurrent.STM (atomically, check)+import Control.Exception (SomeException)+import Control.Lens ((^.))+import Data.Aeson (Value)+import Data.Generics.Labels ()+import Data.Int (Int32, Int64)+import Data.Text (Text)+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Conn+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable, unpreparable)+import Kiroku.Store+import Kiroku.Store.Subscription.EventPublisher (publisherPosition)+import Kiroku.Test.Postgres (withMigratedTestDatabase, withSharedMigratedPostgres)++{- | Bracket that creates an ephemeral PostgreSQL database, applies the+Kiroku migrations, and provides a 'KirokuStore' handle.+-}+withTestStore :: (KirokuStore -> IO ()) -> IO ()+withTestStore = withTestStoreSettings Prelude.id++{- | Variant of 'withTestStore' that lets the caller transform the+'ConnectionSettings' before the store is opened. Used by tests that+install an 'eventHandler' or other observation hook.+-}+withTestStoreSettings :: (ConnectionSettings -> ConnectionSettings) -> (KirokuStore -> IO ()) -> IO ()+withTestStoreSettings tweak action =+ withMigratedTestDatabase $ \connStr ->+ withStore (tweak (defaultConnectionSettings connStr)) action++-- | Create a simple 'EventData' with an auto-generated id.+makeEvent :: Text -> Value -> EventData+makeEvent typ payload =+ EventData+ { eventId = Nothing+ , eventType = EventType typ+ , payload = payload+ , metadata = Nothing+ , causationId = Nothing+ , correlationId = Nothing+ }++{- | Wait for a subscription with a timeout (in microseconds).+Returns 'Left' on timeout, or the subscription result.+-}+waitWithTimeout :: Int -> SubscriptionHandle -> IO (Either String (Either SomeException ()))+waitWithTimeout micros handle = do+ result <- Async.race (threadDelay micros) (wait handle)+ case result of+ Left () -> do+ cancel handle+ pure (Left "Subscription timed out")+ Right r -> pure (Right r)++{- | Count rows in the @events@ table via raw SQL. Used by hard-delete+regression tests that need to assert event payloads are actually removed+(not just unlinked).+-}+countEvents :: KirokuStore -> IO Int64+countEvents store = do+ let stmt :: Statement () Int64+ stmt =+ preparable+ "SELECT COUNT(*) FROM events"+ E.noParams+ (D.singleRow (D.column (D.nonNullable D.int8)))+ result <- Pool.use (store ^. #pool) (Session.statement () stmt)+ case result of+ Left err -> error ("countEvents failed: " <> show err)+ Right n -> pure n++{- | Insert directly into @events@ without an @event_id@ so the database+default is responsible for UUID generation. Returns the generated UUID+text; used to prove the schema-level @uuidv7()@ fallback works.+-}+insertEventUsingDefaultId :: KirokuStore -> IO Text+insertEventUsingDefaultId store = do+ let stmt :: Statement () Text+ stmt =+ preparable+ "INSERT INTO events (event_type, data) VALUES ('DefaultUuidGenerated', '{}'::jsonb) RETURNING event_id::text"+ E.noParams+ (D.singleRow (D.column (D.nonNullable D.text)))+ result <- Pool.use (store ^. #pool) (Session.statement () stmt)+ case result of+ Left err -> error ("insertEventUsingDefaultId failed: " <> show err)+ Right eventIdText -> pure eventIdText++{- | Report whether a schema-qualified relation exists, via+@to_regclass(name) IS NOT NULL@. The name is schema-qualified+(e.g. @"kiroku.streams"@ or @"public.streams"@), so the result does not+depend on the connection's @search_path@. Used by the schema-placement+tests that prove Kiroku objects install under @kiroku@ and not @public@.+-}+tableExists :: KirokuStore -> Text -> IO Bool+tableExists store qualifiedName = do+ let stmt :: Statement Text Bool+ stmt =+ preparable+ "SELECT to_regclass($1) IS NOT NULL"+ (E.param (E.nonNullable E.text))+ (D.singleRow (D.column (D.nonNullable D.bool)))+ result <- Pool.use (store ^. #pool) (Session.statement qualifiedName stmt)+ case result of+ Left err -> error ("tableExists failed: " <> show err)+ Right exists -> pure exists++-- | Return PostgreSQL's numeric server version for failure messages.+serverVersionNum :: KirokuStore -> IO Text+serverVersionNum store = do+ let stmt :: Statement () Text+ stmt =+ preparable+ "SELECT current_setting('server_version_num')"+ E.noParams+ (D.singleRow (D.column (D.nonNullable D.text)))+ result <- Pool.use (store ^. #pool) (Session.statement () stmt)+ case result of+ Left err -> error ("serverVersionNum failed: " <> show err)+ Right version -> pure version++{- | Try to TRUNCATE the named table without the GUC; returns 'True' if the+operation was rejected by the @protect_truncation@ trigger (the expected+behavior after EP-1 F6) and 'False' if it succeeded.+-}+truncateRejected :: KirokuStore -> Text -> IO Bool+truncateRejected store tableName = do+ let stmt :: Statement () ()+ stmt = unpreparable ("TRUNCATE " <> tableName) E.noParams D.noResult+ result <- Pool.use (store ^. #pool) (Session.statement () stmt)+ case result of+ Left _ -> pure True+ Right () -> pure False++-- | Look up the pid of the kiroku-listener backend in @pg_stat_activity@.+findListenerPid :: Pool.Pool -> IO (Maybe Int32)+findListenerPid pool = do+ let stmt :: Statement () (Maybe Int32)+ stmt =+ preparable+ "SELECT pid::int4 FROM pg_stat_activity WHERE application_name = 'kiroku-listener' LIMIT 1"+ E.noParams+ (D.rowMaybe (D.column (D.nonNullable D.int4)))+ result <- Pool.use pool (Session.statement () stmt)+ case result of+ Left err -> error ("findListenerPid failed: " <> show err)+ Right mPid -> pure mPid++-- | Wait until the listener appears in @pg_stat_activity@, or fail after the budget.+waitForListenerPid :: Pool.Pool -> Int -> IO Int32+waitForListenerPid pool budgetMicros+ | budgetMicros <= 0 = error "waitForListenerPid: timeout — kiroku-listener never appeared in pg_stat_activity"+ | otherwise = do+ m <- findListenerPid pool+ case m of+ Just pid -> pure pid+ Nothing -> do+ threadDelay 50_000+ waitForListenerPid pool (budgetMicros - 50_000)++-- | Wait until the listener pid in @pg_stat_activity@ differs from the supplied pid.+waitForListenerPidNotEqual :: Pool.Pool -> Int32 -> Int -> IO Int32+waitForListenerPidNotEqual pool oldPid budgetMicros+ | budgetMicros <= 0 = error "waitForListenerPidNotEqual: timeout — listener did not reconnect"+ | otherwise = do+ m <- findListenerPid pool+ case m of+ Just pid | pid /= oldPid -> pure pid+ _ -> do+ threadDelay 50_000+ waitForListenerPidNotEqual pool oldPid (budgetMicros - 50_000)++-- | Terminate the named backend pid via @pg_terminate_backend@.+terminateBackend :: Pool.Pool -> Int32 -> IO ()+terminateBackend pool pid = do+ let stmt :: Statement Int32 Bool+ stmt =+ preparable+ "SELECT pg_terminate_backend($1::int4)"+ (E.param (E.nonNullable E.int4))+ (D.singleRow (D.column (D.nonNullable D.bool)))+ result <- Pool.use pool (Session.statement pid stmt)+ case result of+ Left err -> error ("terminateBackend failed: " <> show err)+ Right _ -> pure ()++{- | Count kiroku-listener connections via a fresh connection (used after+the store has shut down, when the application pool is no longer+available).+-}+listenerCount :: Text -> IO Int64+listenerCount connStr = do+ eConn <- Connection.acquire (Conn.connectionString connStr)+ case eConn of+ Left err -> error ("listenerCount: failed to acquire verification conn: " <> show err)+ Right conn -> do+ let stmt :: Statement () Int64+ stmt =+ preparable+ "SELECT COUNT(*) FROM pg_stat_activity WHERE application_name = 'kiroku-listener'"+ E.noParams+ (D.singleRow (D.column (D.nonNullable D.int8)))+ r <- Connection.use conn (Session.statement () stmt)+ Connection.release conn+ case r of+ Left err -> error ("listenerCount: query failed: " <> show err)+ Right n -> pure n++{- | Block until the EventPublisher has ingested events at or beyond the+given 'GlobalPosition'. Replaces @threadDelay 200_000@ heuristics in+subscription catch-up tests with a deterministic STM barrier.+-}+waitForPublisher :: KirokuStore -> GlobalPosition -> IO ()+waitForPublisher store (GlobalPosition target) =+ atomically $ do+ GlobalPosition p <- publisherPosition (store ^. #publisher)+ check (p >= target)++{- | Block until the named subscription emits+'KirokuEventSubscriptionCaughtUp'. The caller passes an 'MVar' that is+wired into the test store's @eventHandler@ via 'caughtUpEventHandler'.+Replaces @threadDelay 100_000@ "wait for subscription to enter live+mode" in subscription tests.+-}+waitForSubscriptionLive :: MVar () -> IO ()+waitForSubscriptionLive = takeMVar++{- | Build an 'eventHandler' that opens the supplied 'MVar' the first+time 'KirokuEventSubscriptionCaughtUp' fires for the named subscription.+Subsequent emissions and other event types are ignored by the barrier+('tryPutMVar' guarantees idempotence). Composes with a passthrough+caller for tests that need to inspect the full event stream.+-}+caughtUpEventHandler ::+ SubscriptionName ->+ MVar () ->+ Maybe (KirokuEvent -> IO ()) ->+ KirokuEvent ->+ IO ()+caughtUpEventHandler name barrier passthrough evt = do+ case evt of+ KirokuEventSubscriptionCaughtUp n _ _+ | n == name -> () <$ tryPutMVar barrier ()+ _ -> pure ()+ case passthrough of+ Nothing -> pure ()+ Just f -> f evt
+ test/Test/InterpreterHooks.hs view
@@ -0,0 +1,178 @@+{- | Tests for the interpreter-level event-data hooks installed via+'Kiroku.Store.Settings.StoreSettings'.++Three concerns are covered (added across the plan's milestones):++ * @enrichEvent@ fires on the append path before encoding, so an+ appended event surfaces with the hook's mutation visible.+ * @decodeHook@ fires on the read and subscription paths after+ decoding, so both 'readAllForward' and a live 'subscribe' handler+ see the hook's mutation.+ * With both hooks 'Nothing' (the default), a round-trip is+ byte-identical to the input — the no-op fast path introduces no+ 'pure'-wrapping artefact.+-}+module Test.InterpreterHooks (spec) where++import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as Aeson+import Data.Foldable (for_)+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Vector qualified as V+import Kiroku.Store+import Test.Helpers (makeEvent, waitForPublisher, waitWithTimeout, withTestStore, withTestStoreSettings)+import Test.Hspec++spec :: Spec+spec = describe "InterpreterHooks" $ do+ describe "enrichEvent" appendHookFiresSpec+ describe "decodeHook" readHookFiresSpec+ describe "no hooks" noHookNoEffectSpec++-- ---------------------------------------------------------------------------+-- enrichEvent+-- ---------------------------------------------------------------------------++appendHookFiresSpec :: Spec+appendHookFiresSpec = do+ it "applies enrichEvent to appended events surfaced through readStreamForward" $ do+ let marker = Aeson.object [("hook", Aeson.String "applied")]+ inject ed = pure $ ed & #metadata .~ Just marker+ tweak cs =+ cs+ & #storeSettings+ .~ defaultStoreSettings{enrichEvent = Just inject}+ withTestStoreSettings tweak $ \store -> do+ Right _ <-+ runStoreIO store $+ appendToStream+ (StreamName "hook-append-1")+ NoStream+ [makeEvent "X" (Aeson.object [("seed", Aeson.Number 1)])]+ evs <-+ runStoreIO store $+ readStreamForward (StreamName "hook-append-1") (StreamVersion 0) 10+ case evs of+ Right v+ | V.length v == 1 ->+ (V.head v ^. #metadata) `shouldBe` Just marker+ other -> expectationFailure ("unexpected read result: " <> show other)++ it "applies enrichEvent across appendMultiStream per-stream batches" $ do+ countRef <- newIORef (0 :: Int)+ let inject ed = do+ modifyIORef' countRef (+ 1)+ pure $ ed & #metadata .~ Just (Aeson.object [("multi", Aeson.Bool True)])+ tweak cs =+ cs+ & #storeSettings+ .~ defaultStoreSettings{enrichEvent = Just inject}+ withTestStoreSettings tweak $ \store -> do+ let ops =+ [ (StreamName "hook-multi-A", NoStream, [makeEvent "A1" (Aeson.object []), makeEvent "A2" (Aeson.object [])])+ , (StreamName "hook-multi-B", NoStream, [makeEvent "B1" (Aeson.object [])])+ ]+ Right _ <- runStoreIO store $ appendMultiStream ops+ n <- readIORef countRef+ n `shouldBe` 3+ Right vA <- runStoreIO store $ readStreamForward (StreamName "hook-multi-A") (StreamVersion 0) 10+ Right vB <- runStoreIO store $ readStreamForward (StreamName "hook-multi-B") (StreamVersion 0) 10+ for_ (V.toList vA <> V.toList vB) $ \re ->+ (re ^. #metadata) `shouldBe` Just (Aeson.object [("multi", Aeson.Bool True)])++-- ---------------------------------------------------------------------------+-- decodeHook+-- ---------------------------------------------------------------------------++readHookFiresSpec :: Spec+readHookFiresSpec = do+ it "applies decodeHook to readAllForward results" $ do+ let marker = Aeson.object [("decoded", Aeson.String "yes")]+ inject re = pure $ re & #metadata .~ Just marker+ tweak cs =+ cs+ & #storeSettings+ .~ defaultStoreSettings{decodeHook = Just inject}+ withTestStoreSettings tweak $ \store -> do+ Right _ <-+ runStoreIO store $+ appendToStream+ (StreamName "hook-decode-1")+ NoStream+ [ makeEvent "E1" (Aeson.object [])+ , makeEvent "E2" (Aeson.object [])+ , makeEvent "E3" (Aeson.object [])+ ]+ Right v <-+ runStoreIO store $+ readAllForward (GlobalPosition 0) 10+ V.length v `shouldBe` 3+ for_ (V.toList v) $ \re ->+ (re ^. #metadata) `shouldBe` Just marker++ it "applies decodeHook to subscription handlers across catch-up and live phases" $ do+ let marker = Aeson.object [("sub", Aeson.String "tagged")]+ inject re = pure $ re & #metadata .~ Just marker+ subName = SubscriptionName "hook-sub-1"+ tweak cs =+ cs+ & #storeSettings+ .~ defaultStoreSettings{decodeHook = Just inject}+ withTestStoreSettings tweak $ \store -> do+ -- Pre-append one event so the worker's catch-up path runs+ -- before live mode kicks in.+ Right warm <-+ runStoreIO store $+ appendToStream+ (StreamName "hook-sub-stream-1")+ NoStream+ [makeEvent "warm" (Aeson.object [])]+ waitForPublisher store (warm ^. #globalPosition)++ seen <- newIORef ([] :: [Maybe Aeson.Value])+ done <- newEmptyMVar+ let handlerFn re = do+ modifyIORef' seen ((re ^. #metadata) :)+ n <- length <$> readIORef seen+ if n >= 2+ then Stop <$ tryPutMVar done ()+ else pure Continue+ config = defaultSubscriptionConfig subName AllStreams handlerFn+ sub <- subscribe store config+ -- Append a second event to land in live mode.+ Right _ <-+ runStoreIO store $+ appendToStream+ (StreamName "hook-sub-stream-2")+ NoStream+ [makeEvent "live" (Aeson.object [])]+ takeMVar done+ res <- waitWithTimeout 2_000_000 sub+ case res of+ Right (Right ()) -> pure ()+ other -> expectationFailure ("subscription did not finish cleanly: " <> show other)+ metas <- reverse <$> readIORef seen+ metas `shouldBe` [Just marker, Just marker]++-- ---------------------------------------------------------------------------+-- no-op fast path+-- ---------------------------------------------------------------------------++noHookNoEffectSpec :: Spec+noHookNoEffectSpec = around withTestStore $+ it "with defaultStoreSettings, a round-trip preserves payload and metadata exactly" $ \store -> do+ let originalMeta = Just (Aeson.object [("k", Aeson.String "v")])+ originalPayload = Aeson.object [("x", Aeson.Number 42), ("y", Aeson.String "z")]+ event = makeEvent "Identity" originalPayload & #metadata .~ originalMeta+ Right _ <-+ runStoreIO store $+ appendToStream (StreamName "no-hook-roundtrip") NoStream [event]+ Right v <-+ runStoreIO store $+ readStreamForward (StreamName "no-hook-roundtrip") (StreamVersion 0) 10+ V.length v `shouldBe` 1+ let re = V.head v+ (re ^. #payload) `shouldBe` originalPayload+ (re ^. #metadata) `shouldBe` originalMeta
+ test/Test/Properties.hs view
@@ -0,0 +1,226 @@+{- | Property-based tests for invariants identified by EP-1 through EP-5.++Each property generates a random sequence of operations and asserts that+some invariant holds after the sequence executes. The properties target+the cross-cutting invariants enumerated in EP-6 M1's Invariant List+(F2–F8 of @docs\/plans\/6-test-and-benchmark-hardening-for-production-confidence.md@):++ * F2 — global position contiguity across appends, multi-stream appends,+ and links.+ * F3 — no orphan event payloads after lifecycle operations.+ * F4 — soft-delete write barrier under arbitrary append constructors.+ * F5 — caller-supplied event-id idempotence.++These properties run inside hspec via 'hspec-hedgehog'. Each property+acquires a fresh ephemeral PostgreSQL via 'withTestStore' inside the+hedgehog test action; the operation count per property is small (10-20+ops) to keep total runtime bounded.+-}+module Test.Properties (spec) where++import Control.Lens ((^.))+import Control.Monad (forM_, void)+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import Data.List (sort)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.UUID.V4 qualified as UUIDv4+import Data.Vector qualified as V+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Kiroku.Store+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec+import Test.Hspec.Hedgehog (PropertyT, hedgehog, modifyMaxSuccess)++-- | Operations the property generators can produce.+data Op+ = OpAppend !StreamName ![Text]+ | OpAppendMulti ![(StreamName, [Text])]+ | OpSoftDelete !StreamName+ | OpUndelete !StreamName+ | OpHardDelete !StreamName+ deriving stock (Show)++genStreamName :: Gen StreamName+genStreamName = do+ -- Bounded universe (5 streams) so generated sequences exercise reuse.+ n <- Gen.int (Range.linear 0 4)+ pure (StreamName ("prop-" <> T.pack (show n)))++genEventTypes :: Gen [Text]+genEventTypes = do+ n <- Gen.int (Range.linear 1 3)+ pure (map (\i -> "Type" <> T.pack (show i)) [1 .. n])++genOp :: Gen Op+genOp =+ Gen.frequency+ [ (60, OpAppend <$> genStreamName <*> genEventTypes)+ ,+ ( 10+ , OpAppendMulti+ <$> Gen.list+ (Range.linear 2 3)+ ((,) <$> genStreamName <*> genEventTypes)+ )+ , (10, OpSoftDelete <$> genStreamName)+ , (10, OpUndelete <$> genStreamName)+ , (10, OpHardDelete <$> genStreamName)+ ]++genOps :: Gen [Op]+genOps = Gen.list (Range.linear 1 12) genOp++{- | Run a generated operation, ignoring any 'StoreError' (the property+is about the system's invariants surviving any sequence of attempts,+including ones that fail).+-}+runOp :: KirokuStore -> Op -> IO ()+runOp store = \case+ OpAppend sn types -> do+ let evts = map (\t -> makeEvent t (Aeson.object [])) types+ void $ runStoreIO store $ appendToStream sn AnyVersion evts+ OpAppendMulti ops -> do+ let triples = map (\(sn, types) -> (sn, AnyVersion, map (\t -> makeEvent t (Aeson.object [])) types)) ops+ void $ runStoreIO store $ appendMultiStream triples+ OpSoftDelete sn -> void $ runStoreIO store $ softDeleteStream sn+ OpUndelete sn -> void $ runStoreIO store $ undeleteStream sn+ OpHardDelete sn -> void $ runStoreIO store $ hardDeleteStream sn++-- | Read the global position cursor by counting events on `$all`.+readAllCount :: KirokuStore -> IO Int+readAllCount store = do+ Right v <- runStoreIO store $ readAllForward (GlobalPosition 0) 100000+ pure (V.length v)++{- | Read all events on `$all` and return their global positions in+the order returned.+-}+readAllPositions :: KirokuStore -> IO [Int]+readAllPositions store = do+ Right v <- runStoreIO store $ readAllForward (GlobalPosition 0) 100000+ pure (V.toList (V.map (\e -> case e ^. #globalPosition of GlobalPosition n -> fromIntegral n) v))++{- | Each property creates a fresh ephemeral PostgreSQL per test case,+which dominates wall-clock time. Cap iterations at 15 per property —+enough to exercise generator coverage without blowing the suite past+two minutes.+-}+spec :: Spec+spec = modifyMaxSuccess (const 15) $ do+ describe "kiroku-store invariants (property-based, hedgehog)" $ do+ -- F2 — Global position contiguity. After any sequence of+ -- appends, multi-appends, soft/undelete/hard-delete operations,+ -- the global positions on $all (excluding hard-deleted events)+ -- form a strictly ascending sequence with no duplicates and no+ -- gaps relative to the events that actually exist on $all.+ it "$all global positions are strictly ascending and unique (F2)" $+ hedgehog $+ propAllPositionsAscending++ -- F4 — Soft-delete write barrier. After softDeleteStream, no+ -- subsequent appendToStream of any ExpectedVersion succeeds+ -- (until undeleteStream). Generates a random append, soft-deletes,+ -- attempts further appends with each ExpectedVersion constructor,+ -- asserts each one fails.+ it "soft-deleted streams reject appends of every ExpectedVersion (F4)" $+ hedgehog $+ propSoftDeleteBarrier++ -- F5 — Idempotent caller-supplied event ids. A batch of appends+ -- with all-unique event ids succeeds; a batch where any id is a+ -- repeat of a previously committed id fails with DuplicateEvent.+ it "duplicate caller-supplied event ids are rejected (F5)" $+ hedgehog $+ propDuplicateEventIds++propAllPositionsAscending :: PropertyT IO ()+propAllPositionsAscending = do+ ops <- forAll genOps+ positions <- evalIO $ withTestStoreReturn $ \store -> do+ forM_ ops (runOp store)+ readAllPositions store+ annotateShow positions+ -- Strictly ascending: each position greater than the previous.+ sort positions === positions+ -- Unique: no duplicates.+ length positions === length (Set.fromList positions)+ -- The count returned by $all matches the position list length.+ cnt <- evalIO $ withTestStoreReturn $ \store -> do+ forM_ ops (runOp store)+ readAllCount store+ cnt === length positions++propSoftDeleteBarrier :: PropertyT IO ()+propSoftDeleteBarrier = do+ streamSeed <- forAll (Gen.int (Range.linear 0 9))+ nEvents <- forAll (Gen.int (Range.linear 1 4))+ evalIO $ withTestStoreReturn $ \store -> do+ let sn = StreamName ("barrier-" <> T.pack (show streamSeed))+ let evts = map (\i -> makeEvent ("E" <> T.pack (show i)) (Aeson.object [])) [1 .. nEvents]+ Right _ <- runStoreIO store $ appendToStream sn NoStream evts+ Right _ <- runStoreIO store $ softDeleteStream sn+ -- Every subsequent append constructor must be rejected.+ rNo <- runStoreIO store $ appendToStream sn NoStream [makeEvent "X" (Aeson.object [])]+ case rNo of+ Left (StreamAlreadyExists _) -> pure ()+ other -> error ("F4 violated: NoStream against soft-deleted should be StreamAlreadyExists, got: " <> show other)+ rExact <- runStoreIO store $ appendToStream sn (ExactVersion (StreamVersion (fromIntegral nEvents))) [makeEvent "X" (Aeson.object [])]+ case rExact of+ Left (WrongExpectedVersion _ _ _) -> pure ()+ Left (StreamNotFound _) -> pure ()+ other -> error ("F4 violated: ExactVersion against soft-deleted should fail, got: " <> show other)+ rExists <- runStoreIO store $ appendToStream sn StreamExists [makeEvent "X" (Aeson.object [])]+ case rExists of+ Left (StreamNotFound _) -> pure ()+ other -> error ("F4 violated: StreamExists against soft-deleted should be StreamNotFound, got: " <> show other)+ rAny <- runStoreIO store $ appendToStream sn AnyVersion [makeEvent "X" (Aeson.object [])]+ case rAny of+ Left (StreamNotFound _) -> pure ()+ other -> error ("F4 violated: AnyVersion against soft-deleted should be StreamNotFound, got: " <> show other)++propDuplicateEventIds :: PropertyT IO ()+propDuplicateEventIds = do+ nFirst <- forAll (Gen.int (Range.linear 1 4))+ evalIO $ withTestStoreReturn $ \store -> do+ -- Generate a batch of unique caller-supplied event ids.+ ids <- mapM (const UUIDv4.nextRandom) [1 .. nFirst]+ let mkEvent uid =+ EventData+ { eventId = Just (EventId uid)+ , eventType = EventType "Dup"+ , payload = Aeson.object []+ , metadata = Nothing+ , causationId = Nothing+ , correlationId = Nothing+ }+ let evts1 = map mkEvent ids+ r1 <- runStoreIO store $ appendToStream (StreamName "dup-prop-1") NoStream evts1+ case r1 of+ Right _ -> pure ()+ other -> error ("Initial append with unique ids should succeed: " <> show other)+ -- Re-issue any one of those ids in a fresh stream — must be rejected.+ let dupId = case ids of+ (i : _) -> i+ [] -> error "propDuplicateEventIds: nFirst >= 1 by Range, ids must be non-empty"+ let evts2 = [mkEvent dupId]+ r2 <- runStoreIO store $ appendToStream (StreamName "dup-prop-2") NoStream evts2+ case r2 of+ Left (DuplicateEvent _) -> pure ()+ other -> error ("F5 violated: duplicate event id should be rejected, got: " <> show other)++-- | Variant of 'withTestStore' that returns the action's result.+withTestStoreReturn :: (KirokuStore -> IO a) -> IO a+withTestStoreReturn action = do+ ref <- newIORef (Nothing :: Maybe a)+ withTestStore $ \store -> do+ r <- action store+ atomicModifyIORef' ref (\_ -> (Just r, ()))+ readIORef ref >>= \case+ Just r -> pure r+ Nothing -> error "withTestStoreReturn: action did not produce a result"
+ test/Test/ReadStream.hs view
@@ -0,0 +1,94 @@+{- | Tests for "Kiroku.Store.Read".'readStreamForwardStream' — the+Streamly-shaped sibling of 'readStreamForward'. The streaming wrapper+must yield the same events in the same order as the @Vector@-returning+form, page transparently across the configured @pageSize@, terminate on+empty / nonexistent streams, and honor a non-zero starting cursor.+-}+module Test.ReadStream (spec) where++import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.List.NonEmpty qualified as NE+import Data.Text qualified as T+import Data.Vector qualified as V+import Kiroku.Store+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Stream+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec++spec :: Spec+spec = around withTestStore $+ describe "readStreamForwardStream" $ do+ it "matches readStreamForward on a single-page stream" $ \store -> do+ let name = StreamName "rsfs-single-page"+ events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. 5 :: Int]]+ Right _ <- runStoreIO store $ appendToStream name NoStream events+ streamed <- runStoreIO store $ Stream.toList (readStreamForwardStream name (StreamVersion 0) 256)+ vectored <- runStoreIO store $ readStreamForward name (StreamVersion 0) 256+ case (streamed, vectored) of+ (Right xs, Right v) -> xs `shouldBe` V.toList v+ _ -> expectationFailure ("Unexpected error: " <> show streamed <> " / " <> show vectored)++ it "folds 1000 events end-to-end with Fold.length across multiple pages" $ \store -> do+ let name = StreamName "rsfs-multi-page"+ total = 1000 :: Int+ events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. total]]+ Right _ <- runStoreIO store $ appendToStream name NoStream events+ countResult <-+ runStoreIO store $+ Stream.fold Fold.length (readStreamForwardStream name (StreamVersion 0) 256)+ countResult `shouldBe` Right total+ allEvents <-+ runStoreIO store $+ Stream.toList (readStreamForwardStream name (StreamVersion 0) 256)+ case allEvents of+ Right xs -> case NE.nonEmpty xs of+ Just ne -> do+ let h = NE.head ne+ l = NE.last ne+ (h ^. #streamVersion) `shouldBe` StreamVersion 1+ (h ^. #eventType) `shouldBe` EventType (T.pack "E1")+ (l ^. #streamVersion) `shouldBe` StreamVersion (fromIntegral total)+ (l ^. #eventType) `shouldBe` EventType (T.pack ("E" <> show total))+ Nothing -> expectationFailure "Expected non-empty events list"+ Left err -> expectationFailure ("Unexpected error: " <> show err)++ it "preserves order and avoids duplicates / gaps when paging at pageSize 2" $ \store -> do+ let name = StreamName "rsfs-page-boundary"+ events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. 5 :: Int]]+ Right _ <- runStoreIO store $ appendToStream name NoStream events+ versions <-+ runStoreIO store $+ Stream.toList $+ fmap (^. #streamVersion) (readStreamForwardStream name (StreamVersion 0) 2)+ versions+ `shouldBe` Right+ [ StreamVersion 1+ , StreamVersion 2+ , StreamVersion 3+ , StreamVersion 4+ , StreamVersion 5+ ]++ it "terminates immediately on a nonexistent stream" $ \store -> do+ let name = StreamName "rsfs-never-created"+ result <-+ runStoreIO store $+ Stream.toList (readStreamForwardStream name (StreamVersion 0) 256)+ result `shouldBe` Right []++ it "honors a non-zero starting cursor with exclusivity" $ \store -> do+ let name = StreamName "rsfs-non-zero-cursor"+ events = [makeEvent (T.pack ("E" <> show i)) (Aeson.object []) | i <- [1 .. 5 :: Int]]+ Right _ <- runStoreIO store $ appendToStream name NoStream events+ tailEvents <-+ runStoreIO store $+ Stream.toList (readStreamForwardStream name (StreamVersion 2) 256)+ case tailEvents of+ Right xs -> do+ length xs `shouldBe` 3+ map (^. #streamVersion) xs+ `shouldBe` [StreamVersion 3, StreamVersion 4, StreamVersion 5]+ Left err -> expectationFailure ("Unexpected error: " <> show err)
+ test/Test/StreamNameLookup.hs view
@@ -0,0 +1,52 @@+{- | Tests for 'Kiroku.Store.Read.lookupStreamNames' and 'lookupStreamName'+(plan 36). These resolve the surrogate 'RecordedEvent.originalStreamId' carried+by fan-in reads back to a human-readable 'StreamName', without every read having+to return the name (which a benchmark showed costs ~13% on @$all@ pages).+-}+module Test.StreamNameLookup (spec) where++import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Vector qualified as V+import Kiroku.Store+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec++spec :: Spec+spec = around withTestStore $+ describe "lookupStreamNames / lookupStreamName" $ do+ it "resolves originalStreamId back to the source stream for $all reads" $ \store -> do+ Right _ <-+ runStoreIO store $+ appendToStream (StreamName "orders-1") NoStream [makeEvent "OrderCreated" (Aeson.object [])]+ Right _ <-+ runStoreIO store $+ appendToStream (StreamName "shipments-1") NoStream [makeEvent "ShipmentDispatched" (Aeson.object [])]+ Right evs <- runStoreIO store $ readAllForward (GlobalPosition 0) 100+ Right names <- runStoreIO store $ lookupStreamNames (map (^. #originalStreamId) (V.toList evs))+ let nameOf typ =+ case V.find ((== EventType typ) . (^. #eventType)) evs of+ Just e -> Map.lookup (e ^. #originalStreamId) names+ Nothing -> Nothing+ nameOf "OrderCreated" `shouldBe` Just (StreamName "orders-1")+ nameOf "ShipmentDispatched" `shouldBe` Just (StreamName "shipments-1")++ it "omits ids that name no existing stream" $ \store -> do+ Right names <- runStoreIO store $ lookupStreamNames [StreamId 999999]+ Map.size names `shouldBe` 0++ it "returns an empty map for an empty id list" $ \store -> do+ Right names <- runStoreIO store $ lookupStreamNames []+ Map.null names `shouldBe` True++ it "lookupStreamName resolves a single id, and Nothing for an unknown one" $ \store -> do+ Right _ <-+ runStoreIO store $+ appendToStream (StreamName "widgets-7") NoStream [makeEvent "WidgetMade" (Aeson.object [])]+ Right (Just sid) <- runStoreIO store $ lookupStreamId (StreamName "widgets-7")+ Right found <- runStoreIO store $ lookupStreamName sid+ found `shouldBe` Just (StreamName "widgets-7")+ Right missing <- runStoreIO store $ lookupStreamName (StreamId 888888)+ missing `shouldBe` Nothing
+ test/Test/Transaction.hs view
@@ -0,0 +1,285 @@+{- | Tests for "Kiroku.Store.Transaction" — the transactional escape+hatch and append combinators that let callers compose store operations+with arbitrary 'Hasql.Transaction.Transaction' work in one ACID+transaction.+-}+module Test.Transaction (spec) where++import Contravariant.Extras (contrazip2)+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int64)+import Data.Text (Text)+import Data.Time.Clock (getCurrentTime)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Pool (Pool)+import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable, unpreparable)+import Hasql.Transaction qualified as Tx+import Kiroku.Store+import Test.Helpers (makeEvent, withTestStore)+import Test.Hspec++spec :: Spec+spec = around withTestStore $ do+ describe "runTransaction" $ do+ it "executes a no-op Tx.statement and returns its result" $ \store -> do+ result <-+ runStoreIO store $+ runTransaction $+ Tx.statement () selectOneStmt+ case result of+ Right n -> n `shouldBe` (1 :: Int)+ Left err -> expectationFailure ("Expected Right 1, got: " <> show err)++ describe "appendToStreamTx (driven inside runTransaction)" $ do+ it "appends events and a side-table row in one atomic transaction" $ \store -> do+ createSideTable (store ^. #pool)+ let evt = makeEvent "Created" (Aeson.object [("x", Aeson.Number 1)])+ prepared <- prepareEventsIO [evt]+ now <- getCurrentTime+ result <- runStoreIO store $ runTransaction $ do+ outcome <- appendToStreamTx (StreamName "txn-success-1") NoStream prepared now+ case outcome of+ Left c -> pure (Left c)+ Right ar -> do+ let StreamId sid = ar ^. #streamId+ Tx.statement (sid, "hello") insertSideRowStmt+ pure (Right ar)+ case result of+ Right (Right ar) -> do+ (ar ^. #streamVersion) `shouldBe` StreamVersion 1+ rows <- countSideTable (store ^. #pool)+ rows `shouldBe` 1+ other ->+ expectationFailure+ ("Expected Right (Right AppendResult), got: " <> show other)++ it "rolls back the append and the side row when the body condemns" $ \store -> do+ createSideTable (store ^. #pool)+ let evt = makeEvent "Created" (Aeson.object [])+ prepared <- prepareEventsIO [evt]+ now <- getCurrentTime+ result <- runStoreIO store $ runTransaction $ do+ outcome <- appendToStreamTx (StreamName "txn-condemn-1") NoStream prepared now+ case outcome of+ Right ar -> do+ let StreamId sid = ar ^. #streamId+ Tx.statement (sid, "should-not-persist") insertSideRowStmt+ Tx.condemn+ Left _ -> Tx.condemn+ result `shouldBe` Right ()+ mInfo <- runStoreIO store $ getStream (StreamName "txn-condemn-1")+ mInfo `shouldBe` Right Nothing+ rows <- countSideTable (store ^. #pool)+ rows `shouldBe` 0++ it "returns Left on version conflict; the caller's branch sees no AppendResult" $ \store -> do+ createSideTable (store ^. #pool)+ -- Pre-populate the stream so the ExactVersion check below mismatches.+ _ <-+ runStoreIO store $+ appendToStream+ (StreamName "txn-conflict-1")+ NoStream+ [makeEvent "Created" (Aeson.object [])]+ prepared <- prepareEventsIO [makeEvent "Updated" (Aeson.object [])]+ now <- getCurrentTime+ result <- runStoreIO store $ runTransaction $ do+ outcome <-+ appendToStreamTx+ (StreamName "txn-conflict-1")+ (ExactVersion (StreamVersion 99))+ prepared+ now+ case outcome of+ Right _ -> do+ Tx.statement (0 :: Int64, "should-not-run") insertSideRowStmt+ pure outcome+ Left _ -> pure outcome+ case result of+ Right (Left (WrongExpectedVersionConflict _ _ _)) -> pure ()+ other ->+ expectationFailure+ ("Expected Right (Left WrongExpectedVersionConflict), got: " <> show other)+ rows <- countSideTable (store ^. #pool)+ rows `shouldBe` 0++ describe "runTransactionAppending" $ do+ it "commits 3 events and a side-table row in one ACID transaction" $ \store -> do+ createSideTable (store ^. #pool)+ let evts =+ [ makeEvent "Created" (Aeson.object [("i", Aeson.Number 1)])+ , makeEvent "Updated" (Aeson.object [("i", Aeson.Number 2)])+ , makeEvent "Closed" (Aeson.object [("i", Aeson.Number 3)])+ ]+ result <-+ runStoreIO store $+ runTransactionAppending+ (StreamName "txn-wrapper-success-1")+ NoStream+ evts+ ( \ar -> do+ let StreamId sid = ar ^. #streamId+ Tx.statement (sid, "projection") insertSideRowStmt+ pure ar+ )+ case result of+ Right (Right ar) ->+ (ar ^. #streamVersion) `shouldBe` StreamVersion 3+ other ->+ expectationFailure+ ("Expected Right (Right AppendResult), got: " <> show other)+ -- Verify both the events and the side row landed.+ rows <- countSideTable (store ^. #pool)+ rows `shouldBe` 1+ mInfo <- runStoreIO store $ getStream (StreamName "txn-wrapper-success-1")+ case mInfo of+ Right (Just info) -> (info ^. #version) `shouldBe` StreamVersion 3+ other -> expectationFailure ("Expected stream with version 3, got: " <> show other)++ it "rolls back the append and the side row when the callback condemns" $ \store -> do+ createSideTable (store ^. #pool)+ result <-+ runStoreIO store $+ runTransactionAppending+ (StreamName "txn-wrapper-condemn-1")+ NoStream+ [makeEvent "Created" (Aeson.object [])]+ ( \ar -> do+ let StreamId sid = ar ^. #streamId+ Tx.statement (sid, "should-not-persist") insertSideRowStmt+ Tx.condemn+ pure ar+ )+ -- The callback ran and returned, so the wrapper sees Right; but the+ -- transaction was condemned, so neither write committed.+ case result of+ Right (Right _) -> pure ()+ other ->+ expectationFailure+ ("Expected Right (Right AppendResult), got: " <> show other)+ mInfo <- runStoreIO store $ getStream (StreamName "txn-wrapper-condemn-1")+ mInfo `shouldBe` Right Nothing+ rows <- countSideTable (store ^. #pool)+ rows `shouldBe` 0++ it "skips the callback and surfaces the version conflict" $ \store -> do+ createSideTable (store ^. #pool)+ -- Pre-populate the stream so ExactVersion 99 will mismatch.+ _ <-+ runStoreIO store $+ appendToStream+ (StreamName "txn-wrapper-conflict-1")+ NoStream+ [makeEvent "Created" (Aeson.object [])]+ calledRef <- newIORef (0 :: Int)+ result <-+ runStoreIO store $+ runTransactionAppending+ (StreamName "txn-wrapper-conflict-1")+ (ExactVersion (StreamVersion 99))+ [makeEvent "Updated" (Aeson.object [])]+ ( \ar -> do+ -- Tx.Transaction has no MonadIO; the IORef bump can't go+ -- here. Instead, write a side row whose absence asserts+ -- non-invocation.+ let StreamId sid = ar ^. #streamId+ Tx.statement (sid, "should-not-run") insertSideRowStmt+ pure ar+ )+ -- Bump the ref outside the Tx; assertion below proves the guard+ -- works: if the callback HAD run, the side row would exist.+ modifyIORef' calledRef (+ 1)+ n <- readIORef calledRef+ n `shouldBe` 1+ case result of+ Right (Left (WrongExpectedVersion _ _ _)) -> pure ()+ other ->+ expectationFailure+ ("Expected Right (Left WrongExpectedVersion), got: " <> show other)+ rows <- countSideTable (store ^. #pool)+ rows `shouldBe` 0++ it "rejects $all before opening any transaction" $ \store -> do+ createSideTable (store ^. #pool)+ result <-+ runStoreIO store $+ runTransactionAppending+ (StreamName "$all")+ AnyVersion+ [makeEvent "Should" (Aeson.object [])]+ ( \ar -> do+ let StreamId sid = ar ^. #streamId+ Tx.statement (sid, "should-never-run") insertSideRowStmt+ pure ar+ )+ case result of+ Right (Left (ReservedStreamName (StreamName "$all"))) -> pure ()+ other ->+ expectationFailure+ ("Expected Right (Left (ReservedStreamName \"$all\")), got: " <> show other)+ rows <- countSideTable (store ^. #pool)+ rows `shouldBe` 0++-- ---------------------------------------------------------------------------+-- Local statements and pool-side helpers+-- ---------------------------------------------------------------------------++{- | Trivial @SELECT 1@ used to verify 'runTransaction' wiring without+depending on any schema state.+-}+selectOneStmt :: Statement () Int+selectOneStmt =+ preparable+ "SELECT 1::int4"+ E.noParams+ (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int4)))++-- | DDL for the projection-row side table used by transaction tests.+createSideTableStmt :: Statement () ()+createSideTableStmt =+ unpreparable+ "CREATE TABLE IF NOT EXISTS test_side_table \+ \(id BIGINT PRIMARY KEY, payload TEXT NOT NULL)"+ E.noParams+ D.noResult++{- | Insert a row into the side table. The @id@ doubles as the foreign+key onto the stream the transaction appended to.+-}+insertSideRowStmt :: Statement (Int64, Text) ()+insertSideRowStmt =+ preparable+ "INSERT INTO test_side_table (id, payload) VALUES ($1, $2)"+ ( contrazip2+ (E.param (E.nonNullable E.int8))+ (E.param (E.nonNullable E.text))+ )+ D.noResult++-- | Count rows in the side table.+countSideTableStmt :: Statement () Int64+countSideTableStmt =+ preparable+ "SELECT COUNT(*) FROM test_side_table"+ E.noParams+ (D.singleRow (D.column (D.nonNullable D.int8)))++createSideTable :: Pool -> IO ()+createSideTable pool = do+ r <- Pool.use pool (Session.statement () createSideTableStmt)+ case r of+ Left err -> error ("createSideTable failed: " <> show err)+ Right () -> pure ()++countSideTable :: Pool -> IO Int64+countSideTable pool = do+ r <- Pool.use pool (Session.statement () countSideTableStmt)+ case r of+ Left err -> error ("countSideTable failed: " <> show err)+ Right n -> pure n