packages feed

keiro (empty) → 0.2.0.0

raw patch · 48 files changed

+25953/−0 lines, 48 filesdep +aesondep +aeson-casingdep +base

Dependencies added: aeson, aeson-casing, base, bytestring, containers, contravariant-extras, deepseq, effectful, effectful-core, generic-lens, hasql, hasql-pool, hasql-transaction, hs-opentelemetry-api, hs-opentelemetry-exporter-in-memory, hs-opentelemetry-propagator-w3c, hs-opentelemetry-sdk, hs-opentelemetry-semantic-conventions, hspec, keiki, keiki-codec-json, keiro, keiro-core, keiro-test-support, kiroku-store, lens, mmzk-typeid, process, scientific, shibuya-core, stm, streamly, streamly-core, tasty-bench, text, time, unliftio-core, uuid, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,225 @@+# Changelog++All notable changes to the `keiro` library are recorded here. The format follows+[Keep a Changelog](https://keepachangelog.com/), and the project aims to follow+the [Haskell Package Versioning Policy](https://pvp.haskell.org/).++## [Unreleased]++_No unreleased changes._++## 0.2.0.0 — 2026-07-13++### Breaking Changes++- **Keiro's framework tables moved out of the `kiroku` schema into a dedicated+  `keiro` PostgreSQL schema.** Every runtime query is now fully qualified+  (`keiro.keiro_snapshots`, `keiro.keiro_timers`, `keiro.keiro_outbox`, …) and no+  longer depends on `search_path`. Existing databases must run the+  `keiro-migrations` bootstrap that creates the schema and relocates the tables;+  application SQL reading bare `keiro_*` relations must be re-qualified.+- `runCommandWithSql`, `runCommandWithSqlEvents`, `runCommandWithProjections`,+  and the process-manager/router runners now require `KirokuStoreResource` so+  transactional appends can apply Kiroku's configured `enrichEvent` hook. Acquire+  the store with `withKirokuStore` and interpret `Store` with `runStoreResource`;+  plain `runCommand` is unchanged.+- Read-model queries no longer auto-register missing registry rows. Applications+  must call `registerReadModel` at projection startup; unknown models now return+  `ReadModelUnregistered` without mutating the registry.+- `ReadModel` now requires a `strongScope :: StrongScope` field. Use `EntireLog`+  for all-stream subscriptions or `CategoryHead category` for a category+  subscription, so that unrelated traffic cannot hold `Strong` reads behind.+- `ReadModel` now also requires a `schema :: Text` field naming the PostgreSQL+  schema its data table lives in. Keiro does not rewrite `query`; qualify the+  application's SQL with `qualifiedTableName` or `Keiro.Connection.qualifyTable`.+  The field is Haskell-level wiring only and is deliberately not persisted in the+  `keiro.keiro_read_models` registry.+- `AsyncProjection` now requires `readModelName`, naming the registry row that+  fences writes during a rebuild.+- `applyAsyncProjection` now returns `AsyncApplyOutcome` (`AsyncApplied`,+  `AsyncDuplicate`, or `AsyncFenced`) and live workers must not checkpoint a+  fenced event. Rebuild replayers use `applyAsyncProjectionUnfenced` between the+  new atomic `startRebuild` and guarded `finishRebuild` helpers.+- Router deterministic command ids are now derived from the resolved target+  stream name and same-stream occurrence rather than the target's list position+  (`deterministicRouterCommandId`). A transition point-probe recognizes legacy+  positional ids for stable resolver output and may be removed in a later+  release. If both the deployment version and resolver output change between+  attempts, a target command may be dispatched at most one extra time across that+  one-time upgrade window.+- `runWorkflow`, `runWorkflowWith`, and the child-workflow runtime now require+  `Error StoreError` in their effect rows, so post-commit workflow snapshot+  failures can be caught without leaving the typed error channel.+- `HydrationReplayFailed` now carries a typed `HydrationReplayReason` alongside+  the failing stream version. The reasons distinguish no inverting edge, ambiguous+  inversion, queue mismatch, and a truncated multi-event chain. `CommandError`+  also gains `CommandAmbiguous` (matched edge indices) and `HydrationGapDetected`+  (expected and observed stream versions).+- A command matching multiple transitions is now reported as `CommandAmbiguous`+  instead of `CommandRejected`. Process managers and routers halt on this+  aggregate-definition bug, while generated timer dispositions route it through+  their on-error arm rather than benign on-reject handling.+- `PMCommandResult.PMCommandFailed` now carries the target `StreamName` alongside+  its `CommandError`, so worker policy can identify the failing target.+- `WorkerOptions` gains a `rejectedCommandPolicy :: RejectedCommandPolicy` field,+  and `ShardedWorkerOptions` gains `handlerRetryDelay :: RetryDelay` and+  `retryPolicy :: RetryPolicy`. Record construction must supply them; the+  `defaultWorkerOptions` and `defaultShardedWorkerOptions` defaults are unchanged+  in behavior except as noted below.+- The `hydration_replay_failed` telemetry class is replaced by four+  reason-specific `error.type` values, and `command_ambiguous` is new. Dashboards+  keyed on the old hydration class must be updated.+- Stream validation is stricter through the re-exported `keiro-core` contracts.+  Keiki 0.2's head-recoverability, inversion-ambiguity, unguarded-input-read, and+  state-changing-silent-edge checks now reject a stream at `mkEventStream`, and+  `mkEventStreamWith` can no longer disable the head-recoverability or+  state-changing-epsilon checks. Snapshot-enabled streams whose codec cannot+  encode their initial state and registers are rejected at startup. `keiro` now+  requires `keiki >=0.2`, `keiki-codec-json >=0.2`, and `kiroku-store >=0.3`.++### New Features++- New `Keiro.DeadLetter`, `Keiro.DeadLetter.Schema`, and `Keiro.DeadLetter.Replay`+  modules. Process-manager and router workers can now park a rejected dispatch+  instead of halting: `RejectedCommandPolicy` selects `RejectedHalt` (the+  default), `RejectedDeadLetter` (persist a `DispatchDeadLetter` in+  `keiro.keiro_dead_letters` and acknowledge), or `RejectedSkip` (acknowledge and+  count). `recordDispatchDeadLetter` is idempotent under source-event redelivery,+  and `listDispatchDeadLetters` reads one dispatcher's witnesses newest-first.+  `replaySubscriptionDeadLetters` re-runs a caller-supplied handler over the rows+  Kiroku parked in `kiroku.dead_letters`, reporting `ReplayedFresh`,+  `ReplayedDuplicate`, `ReplayFailed`, or `ReplaySourceMissing` without deleting+  or mutating the Kiroku-owned rows.+- New `Keiro.Connection` module for application read-model and projection tables:+  `qualifyTable`, `quoteIdentifier`, `withProjectionSchema`,+  `keiroConnectionSettings`, and the opt-in `ensureProjectionSchema`. The store+  connection's `schema` stays `kiroku` because it drives the `LISTEN`/`NOTIFY`+  channel; a projection schema is reached by qualification and/or+  `extraSearchPath`. `ReadModel.qualifiedTableName` builds the model's+  `"schema"."table"` reference.+- `Keiro.Subscription.Shard.Worker` gains an acknowledgement-aware surface:+  `runShardedSubscriptionGroupAck` with `ShardAck`, `ShardDelivery`, and+  `ShardEventHandler`, plus per-event retry and dead-letter dispositions.+  `runShardedSubscriptionGroup` remains as the `RecordedEvent -> IO ()`+  compatibility wrapper.+- Added `keiro.dispatch.deadlettered` and `keiro.subscription.deadlettered`+  counters. `Keiro.Telemetry.kirokuEventBridge` installs on Kiroku's+  `eventHandler` to observe `KirokuEventSubscriptionDeadLettered`, the terminal+  retry-exhaustion signal, and delegates every event to the application's handler.+- Added `keiro.snapshot.encode.failures`, `keiro.snapshot.decode.failures`,+  `keiro.snapshot.read.hits`, `keiro.snapshot.read.misses`, and+  `keiro.snapshot.apply.divergence`. Snapshot lookup APIs (`lookupSnapshotSeed`,+  `SnapshotLookup`, `SnapshotMissReason`, `encodeSnapshotStrict`,+  `writeSnapshotEncoded`) now retain miss and decode reasons, while compatibility+  wrappers preserve the previous `Maybe` surface.+- `commandErrorClass` exposes a stable error-class string for a `CommandError`.+  `isRejectionClass`, `decideForFailures`, `DispatchFailure`, and+  `confirmBenignDuplicate` are exported from `Keiro.ProcessManager` and+  `Keiro.Router` so that custom workers can reuse the runtime's acknowledgement+  classification. `ReadModel.categoryHeadPosition` reads the latest global+  position originating in a Kiroku category.++### Bug Fixes++- Command hydration now detects stream-version gaps caused by Kiroku per-stream+  truncation, and returns `HydrationGapDetected` unless a snapshot covers the+  hidden prefix.+- Transactional command runners now apply Kiroku's configured `enrichEvent` hook+  before event preparation, so persisted events and the `runCommandWithSqlEvents`+  callback observe the same enriched metadata as plain `runCommand`.+- Router and process-manager duplicate-event rejections are now confirmed against+  the intended target stream before being treated as benign. Unconfirmed+  cross-stream or id-less collisions surface as command failures, causing workers+  to halt instead of silently dropping a dispatch.+- Sharded subscription readers now acknowledge each event only after its handler+  returns, using Kiroku's acknowledgement bridge. A shed or rebalanced bucket's+  checkpoint can no longer cover an unprocessed event, and a synchronous handler+  exception is retried in place under `retryPolicy` before Kiroku dead-letters the+  event; asynchronous exceptions write no acknowledgement, and the event is+  redelivered by the next owner.+- No-op commands now report `CommandResult.globalPosition = Nothing` instead of+  exposing Kiroku's per-stream-read sentinel `GlobalPosition 0`. Appended commands+  continue to report the real store-assigned position.++### Other Changes++- `RunCommandOptions.verifyReplayOnAppend` defaults on. Both command append paths+  replay each just-committed batch from the pre-command state, count an+  unreplayable batch through `keiro.snapshot.apply.divergence`, and attach a+  bounded typed reason to `keiro.replay.divergence` without turning an+  already-committed command into a reported failure.+- Aggregate snapshot encoding is forced before the store write. An `ErrorCall`+  from a partial state encoder or an uninitialized register is swallowed after the+  event append and counted, instead of escaping a successful command.+- Workflow snapshot writes after steps, completion, and continue-as-new rotation+  are advisory: store failures are swallowed and counted after the journal append+  commits.+- Corrected snapshot documentation: version non-regression applies within one+  codec version and shape hash, while an incompatible codec can replace a newer+  row to permit rollback. Upgrade notes cover the full-replay miss caused by+  Keiki EP-78's stable shape hash.+- Documented previously implicit runtime contracts: the inbox deduplication window+  closes when `garbageCollectCompleted` removes a completed row; outbox+  `created_at` is transaction-start time, so `PerKeyHeadOfLine` and+  `PerSourceStream` ordering is best-effort unless the caller serializes same-key+  enqueues; the default timer worker has no attempt ceiling and requeues claims+  left `Firing` for five minutes; and process-manager `correlate` joins across+  streams must be order-insensitive.+- The shared PostgreSQL test fixture now provisions templates through the native+  Kiroku/Keiro migration plan. Codd transition and remediation tests are retained+  behind the manual `legacy-codd-tools` flag.+- Kiroku 0.3, Keiki 0.2, and pg-migrate 1.0 now resolve from Hackage; their+  obsolete Git package overrides and the local Cabal overlay are no longer needed.++## 0.1.0.0 — 2026-07-05++The initial Hackage release of `keiro`, an event-sourcing framework and workflow+engine that composes the kiroku event store, the keiki aggregate core, and the+shibuya worker substrate.++### Breaking Changes++- Command-boundary APIs require `ValidatedEventStream` instead of bare+  `EventStream`: `runCommand`, `runCommandWithSql`, `runCommandWithSqlEvents`,+  `runCommandWithProjections`, `Router.targetEventStream`, and+  `ProcessManager.eventStream` / `targetEventStream`. Build stream definitions+  with `mkEventStream` or `mkEventStreamOrThrow` before wiring them into runners.+  This is source-level only; persisted events, snapshots, stream names, and wire+  formats are unchanged.++### New Features++- Command-side write APIs with optimistic concurrency, idempotent event ids,+  transactional SQL hooks, inline projections, command metadata, and OpenTelemetry+  spans.+- Typed event codecs, schema-version metadata, ordered upcasters, advisory+  snapshots, and replay-safe event-stream validation via `Keiro.EventStream.Validate`.+- Read models with consistency modes, rebuild lifecycle support, async projection+  deduplication, and strong consistency checks.+- Process managers, routers, database-backed timers, shard workers, and worker+  options for retry, halt, duplicate, and poison-message handling.+- Durable integration outbox and idempotent inbox support, including Kafka+  adapters, trace propagation, retry accounting, dead-lettering, and maintenance+  helpers.+- Durable workflow primitives: journaled named steps, sleep, await/signal,+  child workflows, continue-as-new, patching, push wake signals, resume workers,+  instance leasing, garbage collection, snapshots, and workflow telemetry.+- Metrics surfaces for command dispatch, projections, timers, outbox/inbox+  workers, and workflow execution.++### Bug Fixes++- Hardened command retry, snapshot boundary handling, workflow crash windows,+  process-manager/router ack finalization, timer requeueing, shard reader+  recovery, async projection deduplication, and inbox/outbox recovery paths.+- Fixed duplicate-event classification, outbox publish grouping, no-op late+  failure marks, and idempotent runtime release paths.++### Other Changes++- Re-exported the shared contracts from `keiro-core`, including codecs, streams,+  event streams, validation, integration events, and snapshot policies.+- Added user guides, migration notes, Haddock coverage, API references, and+  guide-backed examples for command-side usage, event evolution, snapshots,+  read models, process managers, routers, integration events, and durable+  workflows.
+ README.md view
@@ -0,0 +1,99 @@+# keiro — 経路++keiro is a Haskell library for event sourcing and workflow orchestration. It+combines an append-only event store, a pure functional state machine, and+subscription workers into one library-shaped runtime that an application imports+and runs against PostgreSQL.++## The name++**経路** (*keiro*) means **route**, **path**, or **course** in Japanese: the way+something travels from an origin to a destination.++| Kanji | Reading | Meaning |+|---|---|---|+| 経 | *kei* | to pass through, to elapse, a way, a longitude |+| 路 | *ro* | a road, path, or way |++The name is literal. keiro is about the paths events take through a system:++- an event stream is the route an aggregate's history has taken;+- a subscription follows the route through the global event log;+- a projection routes events into queryable read models;+- a process manager routes source events into commands for another stream;+- a workflow is a durable route through state, timers, and external effects.++The sibling project **keiki** (継起, "successive occurrence") names the+succession of events. **keiro** names the routes those events travel and the+routes downstream processes follow.++## What it provides++The current v1 library provides:++- typed stream names through `Keiro.Stream`;+- event codecs, schema versions, event type validation, and upcasters through+  `Keiro.Codec`;+- the author-facing `EventStream` contract in `Keiro.EventStream`;+- `runCommand` and `runCommandWithSql` in `Keiro.Command` for the canonical+  load, streaming replay, decide, append-event-batch cycle with optimistic+  concurrency;+- advisory snapshots in `Keiro.Snapshot`;+- read models, inline projections, async projection helpers, and rebuild+  metadata in `Keiro.ReadModel` and `Keiro.Projection`;+- event-sourced process managers in `Keiro.ProcessManager`;+- durable timer storage and workers in `Keiro.Timer`.++The stable contracts used by future Keiro packages live in the sibling+`keiro-core` package. The full `keiro` package depends on `keiro-core` and+re-exports those core modules, so existing imports such as `Keiro.Codec`,+`Keiro.EventStream`, `Keiro.Stream`, and `Keiro.Integration.Event` continue to+work for applications that depend on `keiro`.++The top-level `Keiro` module re-exports the core stream, codec, event-stream,+command, and snapshot APIs. Read-model, projection, process-manager, and timer+modules are exposed directly so applications can import them explicitly.++## Runtime stack++keiro is not a server. The `keiro-core` package contains reusable contracts and+pure helpers; the `keiro` package adds the runtime that composes these+dependencies:++- **kiroku** for the PostgreSQL-backed append-only event store;+- **keiki** for the pure `SymTransducer` state-machine core;+- **shibuya** for subscription and worker supervision;+- **hasql** and **effectful** for database access and effect handling;+- **Streamly** for streaming reads and worker loops.++## Development++From the repository root:++```bash+cabal build all+cabal test all+cabal test jitsurei-test+just haskell-verify+```++The package metadata lives in `keiro/keiro.cabal`. The implementation plans and design+history live under `docs/masterplans/`, `docs/plans/`, and `docs/research/`.+User-facing documentation starts at `docs/user/README.md`. Long-form,+guide-backed examples start at `docs/guides/README.md` and use the sibling+`jitsurei` package as their executable source.++## Status++The v1 implementation MasterPlan is complete. The library currently includes+the package scaffold, public `EventStream` and codec contract, command cycle,+snapshots, read models and projections, process managers, and durable timer APIs.++Remaining work is future-facing: the v2 deterministic durable-execution runtime,+exactly-once async projection checkpoint/user-SQL transactions once shibuya+exposes that boundary, and higher-level ergonomic facades over the low-level v1+APIs.++## License++BSD-3-Clause.
+ bench/Main.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE OverloadedRecordDot #-}++module Main (+    main,+)+where++import Control.Concurrent (threadDelay)+import Data.ByteString qualified as BS+import Data.Text qualified as Text+import Data.Time (UTCTime (..), secondsToDiffTime)+import Data.Time.Calendar (Day (ModifiedJulianDay))+import Data.UUID qualified as UUID+import Effectful (Eff, IOE, (:>))+import Effectful.Error.Static (Error)+import Keiro.Inbox (+    InboxDedupePolicy (..),+    InboxPersistence (..),+    InboxResult (..),+    KafkaDeliveryRef (..),+    runInboxTransactionBatch,+    runInboxTransactionWith,+ )+import Keiro.Integration.Event (IntegrationContentType (..), IntegrationEvent (..))+import Keiro.Outbox (+    OutboxId (..),+    OutboxRow,+    PublishOutcome (..),+    countOutboxBacklog,+    defaultPublishOptions,+    enqueueIntegrationEventTx,+    publishClaimedOutbox,+ )+import Keiro.Prelude+import Keiro.Telemetry qualified as Telemetry+import Keiro.Test.Postgres (withFreshStore, withMigratedSuite)+import Kiroku.Store qualified as Store+import Kiroku.Store.Effect (Store)+import OpenTelemetry.MeterProvider (createMeterProvider, defaultSdkMeterProviderOptions)+import OpenTelemetry.Metric.Core (getMeter)+import OpenTelemetry.Resource (emptyMaterializedResources)+import Test.Tasty.Bench (Benchmark, bench, bgroup, defaultMain, nfIO)+import "hasql-transaction" Hasql.Transaction qualified as Tx++workloadSize :: Int+workloadSize = 2000++seedChunkSize :: Int+seedChunkSize = 500++payloadSize :: Int+payloadSize = 1024++maxDrainPasses :: Int+maxDrainPasses = 2000++fixedOccurredAt :: UTCTime+fixedOccurredAt = UTCTime (ModifiedJulianDay 61000) (secondsToDiffTime 0)++data BrokerModel = BrokerModel+    { invocationMicros :: !Int+    , perRecordMicros :: !Int+    }+    deriving stock (Eq, Show)++data OutboxScenario = OutboxScenario+    { scenarioName :: !Text+    , brokerModel :: !BrokerModel+    , messages :: ![(OutboxId, IntegrationEvent)]+    }++data InboxScenario = InboxScenario+    { inboxScenarioName :: !Text+    , inboxMetrics :: !(Maybe Telemetry.KeiroMetrics)+    , inboxPersistence :: !InboxPersistence+    , inboxBatchSize :: !(Maybe Int)+    , inboxMessages :: ![(IntegrationEvent, KafkaDeliveryRef)]+    }++main :: IO ()+main =+    withMigratedSuite \fixture ->+        withFreshStore fixture \store -> do+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            metrics <- Telemetry.newKeiroMetrics meter+            defaultMain (benchmarks store metrics)++benchmarks :: Store.KirokuStore -> Telemetry.KeiroMetrics -> [Benchmark]+benchmarks store metrics =+    [ bgroup+        "outbox"+        [ scenarioBench store hotKey+        , scenarioBench store hotKeyNoLatency+        , scenarioBench store multiKey+        ]+    , bgroup+        "inbox"+        [ inboxScenarioBench store (singleFull metrics)+        , inboxScenarioBench store singleNoMetrics+        , inboxScenarioBench store batch100+        , inboxScenarioBench store singleSlim+        ]+    ]+  where+    hotKey =+        OutboxScenario+            { scenarioName = "hot-key"+            , brokerModel = BrokerModel{invocationMicros = 1000, perRecordMicros = 10}+            , messages = scenarioMessages \_ -> Just "aggregate-hot"+            }+    hotKeyNoLatency =+        OutboxScenario+            { scenarioName = "hot-key-nolatency"+            , brokerModel = BrokerModel{invocationMicros = 0, perRecordMicros = 0}+            , messages = scenarioMessages \_ -> Just "aggregate-hot"+            }+    multiKey =+        OutboxScenario+            { scenarioName = "multi-key"+            , brokerModel = BrokerModel{invocationMicros = 1000, perRecordMicros = 10}+            , messages = scenarioMessages \i -> Just ("aggregate-" <> Text.pack (show (i `mod` 200)))+            }+    singleFull metrics' =+        InboxScenario+            { inboxScenarioName = "single-full"+            , inboxMetrics = Just metrics'+            , inboxPersistence = PersistFullEnvelope+            , inboxBatchSize = Nothing+            , inboxMessages = inboxScenarioMessages+            }+    singleNoMetrics =+        InboxScenario+            { inboxScenarioName = "single-nometrics"+            , inboxMetrics = Nothing+            , inboxPersistence = PersistFullEnvelope+            , inboxBatchSize = Nothing+            , inboxMessages = inboxScenarioMessages+            }+    batch100 =+        InboxScenario+            { inboxScenarioName = "batch-100"+            , inboxMetrics = Nothing+            , inboxPersistence = PersistFullEnvelope+            , inboxBatchSize = Just 100+            , inboxMessages = inboxScenarioMessages+            }+    singleSlim =+        InboxScenario+            { inboxScenarioName = "single-slim"+            , inboxMetrics = Nothing+            , inboxPersistence = PersistDedupeOnly+            , inboxBatchSize = Nothing+            , inboxMessages = inboxScenarioMessages+            }++scenarioBench :: Store.KirokuStore -> OutboxScenario -> Benchmark+scenarioBench store scenario =+    bench (Text.unpack scenario.scenarioName) $+        nfIO (runScenario store scenario)++runScenario :: Store.KirokuStore -> OutboxScenario -> IO ()+runScenario store scenario = do+    runStoreChecked store do+        Store.runTransaction (Tx.sql "TRUNCATE keiro_outbox")+    seedOutbox store scenario.messages+    runStoreChecked store (drainOutbox scenario.brokerModel 0)++inboxScenarioBench :: Store.KirokuStore -> InboxScenario -> Benchmark+inboxScenarioBench store scenario =+    bench (Text.unpack scenario.inboxScenarioName) $+        nfIO (runInboxScenario store scenario)++runInboxScenario :: Store.KirokuStore -> InboxScenario -> IO ()+runInboxScenario store scenario = do+    runStoreChecked store do+        Store.runTransaction (Tx.sql "TRUNCATE keiro_inbox")+    runStoreChecked store $+        case scenario.inboxBatchSize of+            Nothing ->+                traverse_+                    (processInboxDelivery scenario.inboxMetrics scenario.inboxPersistence)+                    scenario.inboxMessages+            Just batchSize ->+                traverse_+                    (processInboxBatch scenario.inboxMetrics scenario.inboxPersistence)+                    (chunksOf batchSize scenario.inboxMessages)++processInboxDelivery ::+    (IOE :> es, Store :> es) =>+    Maybe Telemetry.KeiroMetrics ->+    InboxPersistence ->+    (IntegrationEvent, KafkaDeliveryRef) ->+    Eff es ()+processInboxDelivery mMetrics persistence (event, kafkaRef) = do+    result <- runInboxTransactionWith mMetrics persistence PreferIntegrationMessageId event (Just kafkaRef) (\_ -> pure ())+    case result of+        Right (InboxProcessed ()) -> pure ()+        other -> liftIO (fail ("unexpected inbox benchmark result: " <> show other))++processInboxBatch ::+    (IOE :> es, Store :> es) =>+    Maybe Telemetry.KeiroMetrics ->+    InboxPersistence ->+    [(IntegrationEvent, KafkaDeliveryRef)] ->+    Eff es ()+processInboxBatch mMetrics persistence chunk = do+    results <-+        runInboxTransactionBatch+            mMetrics+            3+            PreferIntegrationMessageId+            persistence+            [(event, Just kafkaRef) | (event, kafkaRef) <- chunk]+            (\_ -> pure ())+    for_ results \case+        Right (InboxProcessed ()) -> pure ()+        other -> liftIO (fail ("unexpected inbox batch benchmark result: " <> show other))++seedOutbox :: Store.KirokuStore -> [(OutboxId, IntegrationEvent)] -> IO ()+seedOutbox store messages =+    traverse_ seedChunk (chunksOf seedChunkSize messages)+  where+    seedChunk chunk =+        runStoreChecked store $+            Store.runTransaction $+                traverse_ (uncurry enqueueIntegrationEventTx) chunk++drainOutbox :: (IOE :> es, Store :> es) => BrokerModel -> Int -> Eff es ()+drainOutbox broker passes = do+    backlog <- countOutboxBacklog+    if backlog == 0+        then pure ()+        else do+            when (passes >= maxDrainPasses) $+                liftIO (fail ("outbox benchmark exceeded safety cap of " <> show maxDrainPasses <> " passes"))+            void (publishClaimedOutbox (simulatedPublish broker) defaultPublishOptions Nothing)+            drainOutbox broker (passes + 1)++simulatedPublish :: (IOE :> es) => BrokerModel -> [OutboxRow] -> Eff es [(OutboxId, PublishOutcome)]+simulatedPublish broker rows = do+    let totalMicros = broker.invocationMicros + broker.perRecordMicros * length rows+    when (totalMicros > 0) $+        liftIO (threadDelay totalMicros)+    pure [(row ^. #outboxId, PublishSucceeded) | row <- rows]++scenarioMessages :: (Int -> Maybe Text) -> [(OutboxId, IntegrationEvent)]+scenarioMessages keyFor =+    [ (OutboxId (UUID.fromWords64 0x018f0f1800007000 (0x8000000000000000 + fromIntegral i)), integrationEvent i (keyFor i))+    | i <- [1 .. workloadSize]+    ]++integrationEvent :: Int -> Maybe Text -> IntegrationEvent+integrationEvent i key =+    IntegrationEvent+        { messageId = "bench-msg-" <> Text.pack (show i)+        , source = "bench.outbox"+        , destination = "bench.outbox.events.v1"+        , key+        , eventType = "BenchEvent"+        , schemaVersion = 1+        , contentType = ApplicationJson+        , schemaReference = Nothing+        , sourceEventId = Nothing+        , sourceGlobalPosition = Nothing+        , payloadBytes = BS.replicate payloadSize 65+        , occurredAt = fixedOccurredAt+        , causationId = Nothing+        , correlationId = Nothing+        , traceContext = Nothing+        , attributes = Nothing+        }++inboxScenarioMessages :: [(IntegrationEvent, KafkaDeliveryRef)]+inboxScenarioMessages =+    [ ( integrationEvent i (Just ("inbox-key-" <> Text.pack (show i)))+            & #messageId+            .~ ("bench-inbox-msg-" <> Text.pack (show i))+            & #source+            .~ "bench.inbox"+            & #destination+            .~ "bench.inbox.events.v1"+      , KafkaDeliveryRef "bench.inbox.events.v1" 0 (fromIntegral i)+      )+    | i <- [1 .. workloadSize]+    ]++chunksOf :: Int -> [a] -> [[a]]+chunksOf n xs+    | n <= 0 = error "chunksOf: non-positive chunk size"+    | otherwise =+        case splitAt n xs of+            ([], _) -> []+            (chunk, rest) -> chunk : chunksOf n rest++runStoreChecked :: Store.KirokuStore -> Eff [Store, Error Store.StoreError, IOE] a -> IO a+runStoreChecked store action = do+    result <- Store.runStoreIO store action+    case result of+        Left err -> fail (show err)+        Right value -> pure value
+ keiro.cabal view
@@ -0,0 +1,190 @@+cabal-version:   3.0+name:            keiro+version:         0.2.0.0+synopsis:        Event sourcing framework and workflow engine+description:+  A library that composes kiroku, keiki, and shibuya into an+  event-sourcing and workflow-orchestration framework.++license:         BSD-3-Clause+author:          Nadeem Bitar+maintainer:      nadeem@gmail.com+copyright:       2026 Nadeem Bitar+category:        Control+homepage:        https://github.com/shinzui/keiro#readme+bug-reports:     https://github.com/shinzui/keiro/issues+build-type:      Simple+tested-with:     GHC >=9.12 && <9.13+extra-doc-files:+  CHANGELOG.md+  README.md++source-repository head+  type:     git+  location: https://github.com/shinzui/keiro.git++common warnings+  ghc-options:+    -Wall -Wcompat -Widentities -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++common shared+  default-language:   GHC2024+  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    MultilineStrings+    OverloadedLabels+    OverloadedStrings+    PackageImports++library+  import:             warnings, shared+  exposed-modules:+    Keiro+    Keiro.Command+    Keiro.Connection+    Keiro.DeadLetter+    Keiro.DeadLetter.Replay+    Keiro.DeadLetter.Schema+    Keiro.Inbox+    Keiro.Inbox.Kafka+    Keiro.Inbox.Schema+    Keiro.Inbox.Types+    Keiro.Outbox+    Keiro.Outbox.Kafka+    Keiro.Outbox.Schema+    Keiro.Outbox.Types+    Keiro.ProcessManager+    Keiro.Projection+    Keiro.ReadModel+    Keiro.ReadModel.Rebuild+    Keiro.ReadModel.Schema+    Keiro.Router+    Keiro.Snapshot+    Keiro.Snapshot.Codec+    Keiro.Snapshot.Schema+    Keiro.Subscription.Shard+    Keiro.Subscription.Shard.Schema+    Keiro.Subscription.Shard.Worker+    Keiro.Telemetry+    Keiro.Timer+    Keiro.Timer.Schema+    Keiro.Timer.Types+    Keiro.Wake+    Keiro.Workflow+    Keiro.Workflow.Awakeable+    Keiro.Workflow.Awakeable.Schema+    Keiro.Workflow.Child+    Keiro.Workflow.Child.Schema+    Keiro.Workflow.Gc+    Keiro.Workflow.Instance+    Keiro.Workflow.Resume+    Keiro.Workflow.Schema+    Keiro.Workflow.Sleep+    Keiro.Workflow.Snapshot+    Keiro.Workflow.Types++  reexported-modules:+    keiro-core:Keiro.Codec,+    keiro-core:Keiro.EventStream,+    keiro-core:Keiro.EventStream.Validate,+    keiro-core:Keiro.Integration.Event,+    keiro-core:Keiro.Prelude,+    keiro-core:Keiro.Snapshot.Policy,+    keiro-core:Keiro.Stream++  hs-source-dirs:     src+  build-depends:+    , aeson                                  >=2.2+    , aeson-casing                           >=0.2+    , base                                   >=4.21     && <5+    , bytestring                             >=0.11+    , containers                             >=0.6+    , contravariant-extras                   >=0.3+    , deepseq                                >=1.5+    , effectful                              >=2.6+    , effectful-core                         >=2.6+    , generic-lens                           >=2.2+    , hasql                                  >=1.10+    , hasql-pool                             >=1.2+    , hasql-transaction                      >=1.1+    , hs-opentelemetry-api                   >=1.0      && <1.1+    , hs-opentelemetry-propagator-w3c        >=1.0      && <1.1+    , hs-opentelemetry-semantic-conventions  >=1.40     && <2+    , keiki                                  >=0.2      && <0.3+    , keiki-codec-json                       >=0.2      && <0.3+    , keiro-core                             ^>=0.2.0.0+    , kiroku-store                           >=0.3      && <0.4+    , lens                                   >=5.2+    , mmzk-typeid                            >=0.7+    , scientific                             >=0.3+    , shibuya-core                           >=0.8.0.1  && <0.9+    , stm                                    >=2.5+    , streamly                               >=0.11+    , streamly-core                          >=0.3+    , text                                   >=2.1+    , time                                   >=1.12+    , unliftio-core                          >=0.2+    , uuid                                   >=1.3+    , vector                                 >=0.13++test-suite keiro-test+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Main.hs+  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  build-depends:+    , aeson                                  >=2.2+    , base                                   >=4.21    && <5+    , bytestring                             >=0.11+    , containers                             >=0.6+    , contravariant-extras                   >=0.3+    , effectful                              >=2.6+    , effectful-core                         >=2.6+    , hasql                                  >=1.10+    , hasql-pool                             >=1.2+    , hasql-transaction                      >=1.1+    , hs-opentelemetry-api                   >=1.0     && <1.1+    , hs-opentelemetry-exporter-in-memory    >=1.0     && <1.1+    , hs-opentelemetry-propagator-w3c        >=1.0     && <1.1+    , hs-opentelemetry-sdk                   >=1.0     && <1.1+    , hs-opentelemetry-semantic-conventions  >=1.40    && <2+    , hspec                                  >=2.11+    , keiki+    , keiki-codec-json+    , keiro+    , keiro-test-support+    , kiroku-store                           >=0.3     && <0.4+    , process                                >=1.6+    , shibuya-core                           >=0.8.0.1 && <0.9+    , stm                                    >=2.5+    , streamly-core                          >=0.3+    , text                                   >=2.1+    , time                                   >=1.12+    , unliftio-core                          >=0.2+    , uuid                                   >=1.3+    , vector                                 >=0.13++benchmark keiro-bench+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: bench+  main-is:        Main.hs+  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  build-depends:+    , base                  >=4.21     && <5+    , bytestring            >=0.11+    , effectful             >=2.6+    , hasql-transaction     >=1.1+    , hs-opentelemetry-api  >=1.0      && <1.1+    , hs-opentelemetry-sdk  >=1.0      && <1.1+    , keiro+    , keiro-core            ^>=0.2.0.0+    , keiro-test-support+    , kiroku-store          >=0.3      && <0.4+    , tasty-bench           >=0.4+    , text                  >=2.1+    , time                  >=1.12+    , uuid                  >=1.3
+ src/Keiro.hs view
@@ -0,0 +1,57 @@+{- | Umbrella entry point for the Keiro event-sourcing framework.++Importing @Keiro@ brings the everyday command-side surface into scope in+one go: the command runner ("Keiro.Command"), event 'Codec's+("Keiro.Codec"), the 'EventStream' definition and its snapshot policy+("Keiro.EventStream"), the content-based 'Router' ("Keiro.Router"),+snapshot helpers ("Keiro.Snapshot"), and typed 'Stream' handles+("Keiro.Stream").++The more specialized subsystems are not re-exported here and are imported+directly when needed: read models ("Keiro.ReadModel"), projections+("Keiro.Projection"), process managers ("Keiro.ProcessManager"), the+integration in/outbox ("Keiro.Inbox", "Keiro.Outbox"), timers+("Keiro.Timer"), and telemetry ("Keiro.Telemetry").++Known limit: Keiro currently uses kiroku's PostgreSQL event store, whose append+path serializes all writers through the @$all@ stream row while assigning the+global event order. That makes the global position simple and deterministic,+but it is a throughput ceiling for very high write rates across many unrelated+streams. This production-readiness hardening pass documents the limit rather+than redesigning it; applications that outgrow the single-row global append+lock need a future event-store migration plan.+-}+module Keiro (+    -- * Library version+    version,++    -- * Command side+    module Keiro.Command,+    module Keiro.Codec,++    -- * Stream definitions+    EventStream (..),+    Terminality (..),+    SnapshotPolicy (..),+    StateCodec (..),+    module Keiro.EventStream.Validate,+    module Keiro.Stream,++    -- * Routing and snapshots+    module Keiro.Router,+    module Keiro.Snapshot,+)+where++import Keiro.Codec+import Keiro.Command+import Keiro.EventStream+import Keiro.EventStream.Validate+import Keiro.Prelude+import Keiro.Router+import Keiro.Snapshot+import Keiro.Stream++-- | The Keiro library version, as a 'Text' for display and telemetry.+version :: Text+version = "0.1.0.0"
+ src/Keiro/Command.hs view
@@ -0,0 +1,900 @@+{- | The command side of the framework: hydrate an aggregate, transduce, append.++Running a command against an 'EventStream' follows one pipeline:++1. /Hydrate/ — replay the stream's stored events (optionally fast-forwarding+   from a snapshot) through the keiki transducer to recover the current+   @(state, registers)@ and stream version.+2. /Transduce/ — step the transducer with the command. A rejected transition+   yields 'CommandRejected', while multiple matching transitions yield+   'CommandAmbiguous'; a transition that emits no events yields a no-op+   'CommandResult'.+3. /Append/ — encode the emitted events with the stream's 'Codec' and append+   them at the expected version. An optimistic-concurrency conflict is+   retried up to 'retryLimit' times by rehydrating and replaying; exhausting+   the budget yields 'RetryExhausted'.++Three runners expose this pipeline at increasing levels of integration:++* 'runCommand' — append only.+* 'runCommandWithSql' — run an extra @afterAppend@ action in the /same/+  transaction as the append (e.g. update an inline read model).+* 'runCommandWithSqlEvents' — same, but the callback also receives the+  emitted events paired with their 'RecordedEvent's. This is the primitive+  the projection, process-manager, and router layers build on.++The transactional runners apply Kiroku's configured @enrichEvent@ hook before+event preparation, exactly like 'runCommand'. They therefore require a+'KirokuStoreResource' in the effect stack; install it with @withKirokuStore@+and interpret 'Store' with @runStoreResource@.++Per-stream hydration honors Kiroku's stream-truncation marker. A retained+snapshot must cover every hidden event (snapshot version at least marker minus+one); otherwise hydration fails with 'HydrationGapDetected'. A marker above+the stream head can instead appear as an empty stream and repeated append+conflicts end in 'ConflictFixpoint'. Keiro never truncates streams itself.+Kiroku's @$all@ and category/subscription reads are unaffected by per-stream+truncation: the marker hides events from stream reads rather than deleting+them from the global log.++Every successful append is replayed immediately from its pre-command state so+an unreplayable batch is witnessed at the moment it poisons the stream. The+post-commit witness is counted and attached to the command span without+changing the successful result. The same replay fold feeds transparent+snapshot writes when the stream's 'Keiro.EventStream.SnapshotPolicy' fires;+post-commit snapshot failures are likewise swallowed and counted. Every runner+accepts a tracer for optional OpenTelemetry spans.+-}+module Keiro.Command (+    -- * Results and errors+    CommandResult (..),+    CommandError (..),+    HydrationReplayReason (..),+    commandErrorClass,++    -- * Options+    RunCommandOptions (..),+    defaultRunCommandOptions,++    -- * Running commands+    runCommand,+    runCommandWithSql,+    runCommandWithSqlEvents,+)+where++import Control.Concurrent (threadDelay)+import Data.Functor (($>))+import Data.Int (Int32)+import Data.Text qualified as Text+import Effectful (Eff, IOE, (:>))+import Effectful.Error.Static (Error, tryError)+import GHC.Clock (getMonotonicTimeNSec)+import GHC.Stack (HasCallStack)+import Keiki.Core (BoolAlg, RegFile)+import Keiki.Core qualified as Keiki+import Keiro.Codec (Codec, CodecError, decodeRecorded, encodeForAppendWithMetadata)+import Keiro.EventStream (EventStream, Terminality (..))+import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated)+import Keiro.Prelude+import Keiro.Snapshot (+    SnapshotLookup (..),+    SnapshotMissReason (..),+    encodeSnapshotStrict,+    lookupSnapshotSeed,+    writeSnapshotEncoded,+ )+import Keiro.Snapshot.Policy (shouldSnapshotSpan)+import Keiro.Stream (Stream)+import Keiro.Telemetry (+    KeiroMetrics,+    keiro_events_appended,+    keiro_replay_divergence,+    keiro_retry_attempt,+    recordCommandConflicts,+    recordCommandDuplicates,+    recordCommandRetries,+    recordSnapshotApplyDivergence,+    recordSnapshotDecodeFailures,+    recordSnapshotEncodeFailures,+    recordSnapshotReadHits,+    recordSnapshotReadMisses,+    recordSnapshotWriteFailures,+    withCommandSpan,+ )+import Kiroku.Store.Append (appendToStream)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Effect.Resource (KirokuStoreResource, getKirokuStore)+import Kiroku.Store.Error (StoreError (..))+import Kiroku.Store.Read (readStreamForwardStream)+import Kiroku.Store.Transaction (+    PreparedEvent,+    appendConflictToStoreError,+    appendToStreamTx,+    enrichEventsIO,+    prepareEventsIO,+    runTransaction,+ )+import Kiroku.Store.Types (+    AppendResult,+    EventData,+    EventId (..),+    ExpectedVersion (..),+    GlobalPosition (..),+    RecordedEvent (..),+    StreamName (..),+    StreamVersion (..),+ )+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.SemanticConventions (db_system_name, error_type)+import OpenTelemetry.Trace.Core (Span, SpanStatus (..), Tracer, addAttribute, setStatus)+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Streamly+import "hasql-transaction" Hasql.Transaction qualified as Tx+import Prelude qualified++{- | The outcome of a successfully handled command.++Reports the target 'Stream', the stream version after the command, the global+log position only when this command appended and the store assigned a real+one, and how many events were appended. A no-op reports @0@ events and+@Nothing@ for its global position because per-stream reads cannot recover a+true global position.+-}+data CommandResult target = CommandResult+    { target :: !(Stream target)+    , streamVersion :: !StreamVersion+    , globalPosition :: !(Maybe GlobalPosition)+    -- ^ 'Just' only when this command appended; 'Nothing' for a no-op.+    , eventsAppended :: !Int+    }+    deriving stock (Generic, Eq, Show)++-- | Why a command did not complete.+data CommandError+    = -- | A stored event could not be decoded while rehydrating the aggregate.+      HydrationDecodeFailed !CodecError+    | {- | Replay of the stored events through the transducer stalled. The+      version identifies the failing stored event; for+      'HydrationTruncatedChain' it identifies the last stored event, after+      which the expected multi-event chain remained incomplete.+      -}+      HydrationReplayFailed !StreamVersion !HydrationReplayReason+    | {- | Hydration observed a non-contiguous stream version. Carries the+      expected version followed by the observed version. The store writes+      contiguous versions, so this indicates that stream truncation hid+      events not covered by the hydration seed. Restore visibility with+      @clearStreamTruncateBefore@ or provide a covering snapshot before+      retrying the command.+      -}+      HydrationGapDetected !StreamVersion !StreamVersion+    | -- | No transducer edge matched the command in the hydrated state.+      CommandRejected+    | {- | Two or more transducer edges matched the command in the hydrated+      state. This is a deterministic aggregate-definition bug rather than a+      business rejection; the list contains the zero-based matched edge+      indices in declaration order.+      -}+      CommandAmbiguous ![Int]+    | -- | An emitted event could not be encoded for append.+      EncodeFailed !CodecError+    | -- | The underlying store rejected the append.+      StoreFailed !StoreError+    | {- | Optimistic-concurrency retries were exhausted (carries the total+      attempts made and the last store error).+      -}+      RetryExhausted !Int !StoreError+    | {- | Retrying after a 'StreamAlreadyExists' conflict re-observed the same+      stream version: the store says the stream exists but reading it shows no+      progress. The typical cause is a soft-deleted stream, where reads return+      nothing but appends still collide. Carries the observed version and the+      conflict.+      -}+      ConflictFixpoint !StreamVersion !StoreError+    deriving stock (Generic, Eq, Show)++{- | Why replay of stored events stalled, projected from keiki's structured+failure types onto a monomorphic vocabulary suitable for 'CommandError'.+-}+data HydrationReplayReason+    = -- | No edge's first output template could have produced the event.+      HydrationNoInvertingEdge+    | -- | More than one edge could have produced the event.+      HydrationAmbiguousInversion+    | -- | An event did not match the next expected event in a chain.+      HydrationQueueMismatch+    | -- | The stream ended in the middle of a multi-event chain.+      HydrationTruncatedChain+    deriving stock (Generic, Eq, Show)++{- | Knobs controlling a single command invocation.++* 'retryLimit' — how many times to rehydrate-and-replay after an+  optimistic-concurrency conflict before giving up with 'RetryExhausted'.+* 'pageSize' — batch size when reading the stream during hydration.+* 'eventIds' — caller-supplied ids assigned to the emitted events in order;+  the basis for deterministic, idempotent appends (see 'Keiro.Router' and+  'Keiro.ProcessManager').+* 'beforeAppend' — a hook run immediately before each append attempt,+  primarily a test seam for injecting concurrent writes.+* 'retryBackoffMicros' — base delay before the k-th OCC retry, capped at+  100 ms and jittered. Set to 0 to disable backoff.+* 'metrics' — optional metrics handle for command and snapshot counters.+* 'verifyReplayOnAppend' — replay every just-appended batch from the+  pre-command state. Divergence is a post-commit advisory: it is counted and+  attached to the command span, but the already-successful command still+  succeeds. Snapshot-enabled streams always run the fold because snapshots+  consume its result.+-}+data RunCommandOptions = RunCommandOptions+    { retryLimit :: !Int+    , pageSize :: !Int32+    , eventIds :: ![EventId]+    , beforeAppend :: !(IO ())+    , retryBackoffMicros :: !Int+    , metrics :: !(Maybe KeiroMetrics)+    , verifyReplayOnAppend :: !Bool+    , tracer :: !(Maybe Tracer)+    {- ^ Optional OpenTelemetry tracer. When 'Just', the command runner+    opens an 'Internal'-kind span around each invocation, named after+    the resolved stream identifier and decorated with the messaging /+    error semantic-conventions attributes audited in+    'docs/research/opentelemetry-semconv-audit.md'. When 'Nothing',+    the runner emits no spans.+    -}+    , metadata :: !(Maybe Value)+    {- ^ Optional JSON merged into every event's metadata for this command+    invocation. Carries ambient context such as actor type, agent id,+    and session id. The codec always adds a @schemaVersion@ key; the+    keys here are merged on top (see 'Keiro.Codec.metadataFor'). When+    'Nothing', events carry only the schema-version marker, exactly as+    before this field existed.+    -}+    }+    deriving stock (Generic)++{- | Sensible defaults: 3 retries, 256-event read pages, no caller-assigned+event ids, a no-op pre-append hook, 5ms retry backoff, no metrics, post-append+replay verification enabled, no tracer, and no extra metadata.+-}+defaultRunCommandOptions :: RunCommandOptions+defaultRunCommandOptions =+    RunCommandOptions+        { retryLimit = 3+        , pageSize = 256+        , eventIds = []+        , beforeAppend = pure ()+        , retryBackoffMicros = 5000+        , metrics = Nothing+        , verifyReplayOnAppend = True+        , tracer = Nothing+        , metadata = Nothing+        }++data Hydrated rs s = Hydrated+    { state :: !s+    , registers :: !(RegFile rs)+    , streamVersion :: !StreamVersion+    }+    deriving stock (Generic)++data CommandPlan target rs s co+    = CommandNoOp !(CommandResult target)+    | CommandAppend !(Hydrated rs s) ![co] ![EventData]+    deriving stock (Generic)++hydrate ::+    forall phi rs s ci co es.+    (HasCallStack, IOE :> es, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+    RunCommandOptions ->+    EventStream phi rs s ci co ->+    Stream (EventStream phi rs s ci co) ->+    Eff es (Either CommandError (Hydrated rs s))+hydrate options eventStream targetStream =+    snapshotSeed >>= \case+        Nothing -> hydrateFull options eventStream targetStream+        Just seed -> do+            replayed <-+                hydrateSeeded+                    options+                    eventStream+                    targetStream+                    (seed ^. #state)+                    (seed ^. #registers)+                    (seed ^. #streamVersion)+            case replayed of+                Left _ -> hydrateFull options eventStream targetStream+                Right hydrated -> pure (Right hydrated)+  where+    snapshotSeed =+        case eventStream ^. #stateCodec of+            Nothing -> pure Nothing+            Just codec -> do+                lookupSnapshotSeed ((eventStream ^. #resolveStreamName) targetStream) codec >>= \case+                    SnapshotHit seed -> do+                        recordSnapshotReadHits (options ^. #metrics) 1+                        pure (Just seed)+                    SnapshotUnavailable reason -> do+                        recordSnapshotReadMisses (options ^. #metrics) 1+                        case reason of+                            SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1+                            _ -> pure ()+                        pure Nothing++hydrateFull ::+    forall phi rs s ci co es.+    (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+    RunCommandOptions ->+    EventStream phi rs s ci co ->+    Stream (EventStream phi rs s ci co) ->+    Eff es (Either CommandError (Hydrated rs s))+hydrateFull options eventStream targetStream =+    hydrateSeeded+        options+        eventStream+        targetStream+        (eventStream ^. #initialState)+        (eventStream ^. #initialRegisters)+        (StreamVersion 0)++{- | Replay a stored stream from an arbitrary snapshot or initial-state seed.++The store stream is grouped into bounded lists and each decoded prefix is+handed to keiki's 'Keiki.replayEvents'. Decoding stops at the first bad event in+a group, but the valid prefix is replayed first so an earlier replay failure+retains precedence over a later codec failure.+-}+hydrateSeeded ::+    forall phi rs s ci co es.+    (HasCallStack, Store :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+    RunCommandOptions ->+    EventStream phi rs s ci co ->+    Stream (EventStream phi rs s ci co) ->+    s ->+    RegFile rs ->+    StreamVersion ->+    Eff es (Either CommandError (Hydrated rs s))+hydrateSeeded options eventStream targetStream seedState seedRegisters seedVersion = do+    replayed <-+        Streamly.fold+            (Fold.foldlM' replayPage (pure (Right initialReplay)))+            recordedPages+    pure (finishReplay replayed)+  where+    readPageSize = Prelude.max 1 (options ^. #pageSize)+    groupSize = Prelude.fromIntegral readPageSize+    recordedPages =+        Streamly.foldMany+            (Fold.take groupSize Fold.toList)+            (readStreamForwardStream resolvedName seedVersion readPageSize)+    resolvedName = (eventStream ^. #resolveStreamName) targetStream+    initialReplay = (Keiki.Settled seedState, seedRegisters, Nothing)++    replayPage ::+        Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent) ->+        [RecordedEvent] ->+        Eff es (Either CommandError (Keiki.InFlight s co, RegFile rs, Maybe RecordedEvent))+    replayPage (Left err) _ = pure (Left err)+    replayPage (Right (wrapper, registers, previousRecorded)) page =+        pure $ case Keiki.replayEvents (eventStream ^. #transducer) (wrapper, registers) decodedEvents of+            Left replayFailure ->+                Left (hydrationReplayError previousRecorded decodedRecorded replayFailure)+            Right (nextWrapper, nextRegisters) ->+                case pendingInputFailure of+                    Just err -> Left err+                    Nothing ->+                        Right+                            ( nextWrapper+                            , nextRegisters+                            , latestRecorded decodedRecorded previousRecorded+                            )+      where+        (decodedRecorded, decodedEvents, pendingInputFailure) = decodePrefix previousRecorded page++    decodePrefix :: Maybe RecordedEvent -> [RecordedEvent] -> ([RecordedEvent], [co], Maybe CommandError)+    decodePrefix previousRecorded = go [] [] startingVersion+      where+        startingVersion = maybe seedVersion (^. #streamVersion) previousRecorded++        go recordedAcc eventAcc lastSeen = \case+            [] -> (Prelude.reverse recordedAcc, Prelude.reverse eventAcc, Nothing)+            recorded : rest ->+                let observed = recorded ^. #streamVersion+                    expected = nextStreamVersion lastSeen+                 in if observed /= expected+                        then+                            ( Prelude.reverse recordedAcc+                            , Prelude.reverse eventAcc+                            , Just (HydrationGapDetected expected observed)+                            )+                        else case decodeRecorded (eventStream ^. #eventCodec) recorded of+                            Left err ->+                                ( Prelude.reverse recordedAcc+                                , Prelude.reverse eventAcc+                                , Just (HydrationDecodeFailed err)+                                )+                            Right event ->+                                go (recorded : recordedAcc) (event : eventAcc) observed rest++        nextStreamVersion (StreamVersion version) = StreamVersion (version Prelude.+ 1)++    hydrationReplayError ::+        Maybe RecordedEvent ->+        [RecordedEvent] ->+        Keiki.ReplayFailure s co ->+        CommandError+    hydrationReplayError previousRecorded decodedRecorded replayFailure =+        HydrationReplayFailed failureVersion (toHydrationReason (Keiki.replayFailureReason replayFailure))+      where+        failureVersion =+            maybe seedVersion (^. #streamVersion) failureRecorded+        failureRecorded =+            case Keiki.replayFailureReason replayFailure of+                Keiki.ReplayLogTruncated{} -> latestRecorded decodedRecorded previousRecorded+                Keiki.ReplayEventFailed{} ->+                    case recordedAt (Keiki.replayFailedIndex replayFailure) decodedRecorded of+                        Just recorded -> Just recorded+                        Nothing -> latestRecorded decodedRecorded previousRecorded++    finishReplay = \case+        Left err -> Left err+        Right (wrapper, finalRegisters, lastRecorded) ->+            case wrapper of+                Keiki.Settled finalState ->+                    Right+                        Hydrated+                            { state = finalState+                            , registers = finalRegisters+                            , streamVersion = maybe seedVersion (^. #streamVersion) lastRecorded+                            }+                Keiki.InFlight{} ->+                    Left+                        ( HydrationReplayFailed+                            (maybe seedVersion (^. #streamVersion) lastRecorded)+                            HydrationTruncatedChain+                        )++    toHydrationReason = \case+        Keiki.ReplayEventFailed stepFailure -> case stepFailure of+            Keiki.ReplayNoInvertingEdge{} -> HydrationNoInvertingEdge+            Keiki.ReplayAmbiguousInversions{} -> HydrationAmbiguousInversion+            Keiki.ReplayQueueMismatch{} -> HydrationQueueMismatch+        Keiki.ReplayLogTruncated{} -> HydrationTruncatedChain++    latestRecorded recorded fallback =+        case lastMaybe recorded of+            Just latest -> Just latest+            Nothing -> fallback++    lastMaybe = \case+        [] -> Nothing+        first : rest -> Just (Prelude.foldl (\_ current -> current) first rest)++    recordedAt eventIndex recorded =+        case Prelude.drop eventIndex recorded of+            found : _ -> Just found+            [] -> Nothing++{- | Hydrate the target stream, transduce the command, and append any emitted+events. Retries optimistic-concurrency conflicts up to 'retryLimit'. This+is the plain runner with no in-transaction side effects.+-}+runCommand ::+    forall phi rs s ci co es.+    (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+    RunCommandOptions ->+    ValidatedEventStream phi rs s ci co ->+    Stream (EventStream phi rs s ci co) ->+    ci ->+    Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co)))+runCommand options validatedEventStream targetStream command =+    withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do+        (result, attemptNo) <- attempt mSpan 1 Nothing+        recordCommandOutcome mSpan (^. #eventsAppended) attemptNo result+        pure result+  where+    eventStream = unvalidated validatedEventStream++    attempt mSpan attemptNo lastConflict = do+        hydrated <- hydrate options eventStream targetStream+        either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated++    runPlan mSpan attemptNo lastConflict current =+        case conflictFixpoint lastConflict (current ^. #streamVersion) of+            Just err -> pure (Left err, attemptNo)+            Nothing ->+                case prepareCommandPlan options eventStream targetStream current command of+                    Left err -> pure (Left err, attemptNo)+                    Right (CommandNoOp result) -> pure (Right result, attemptNo)+                    Right (CommandAppend current' events encoded) ->+                        appendOnce mSpan attemptNo current' events encoded++    appendOnce mSpan attemptNo current events encoded = do+        liftIO (options ^. #beforeAppend)+        appended <-+            tryError @StoreError+                $ appendToStream+                    ((eventStream ^. #resolveStreamName) targetStream)+                    (expectedVersion (current ^. #streamVersion))+                    encoded+        case appended of+            Right appendResult -> do+                verifyAndSnapshot options mSpan eventStream current events appendResult+                pure (Right (appendedResult targetStream appendResult (Prelude.length encoded)), attemptNo)+            Left (_, storeError) ->+                retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError++{- | Like 'runCommand', but run @afterAppend@ inside the /same/ transaction+as the append, so a read-model write commits atomically with the events.+The callback's result is returned as @Just@ on append (and 'Nothing' for a+no-op command that appended nothing).++Requires 'KirokuStoreResource' so the transactional append applies the+configured @enrichEvent@ hook. See 'runCommandWithSqlEvents' for the callback's+locking and latency implications.+-}+runCommandWithSql ::+    forall phi rs s ci co a es.+    (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+    RunCommandOptions ->+    ValidatedEventStream phi rs s ci co ->+    Stream (EventStream phi rs s ci co) ->+    ci ->+    (AppendResult -> Tx.Transaction a) ->+    Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a))+runCommandWithSql options eventStream targetStream command afterAppend =+    runCommandWithSqlEvents options eventStream targetStream command (\_ appendResult -> afterAppend appendResult)++{- | The most general runner: like 'runCommandWithSql', but the+in-transaction callback also receives every emitted event paired with the+'RecordedEvent' the store persisted for it, in append order. Inline+projections, process managers, and routers are all built on this.++The runner requires 'KirokuStoreResource' and applies the configured+@enrichEvent@ hook before preparing the append. The callback therefore sees+the enriched metadata that was persisted.++The append updates Kiroku's global @$all@ stream and holds its PostgreSQL row+lock until this transaction commits. Every SQL operation in the callback+therefore extends the store-wide append serialization window. Keep the+callback small: precompute outside the transaction where possible, batch+writes, and minimize database round trips.+-}+runCommandWithSqlEvents ::+    forall phi rs s ci co a es.+    (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+    RunCommandOptions ->+    ValidatedEventStream phi rs s ci co ->+    Stream (EventStream phi rs s ci co) ->+    ci ->+    ([(co, RecordedEvent)] -> AppendResult -> Tx.Transaction a) ->+    Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co), Maybe a))+runCommandWithSqlEvents options validatedEventStream targetStream command afterAppend =+    withCommandSpan (options ^. #tracer) (resolvedStreamName eventStream targetStream) Nothing $ \mSpan -> do+        (result, attemptNo) <- attempt mSpan 1 Nothing+        recordCommandOutcome mSpan (\(r, _) -> r ^. #eventsAppended) attemptNo result+        pure result+  where+    eventStream = unvalidated validatedEventStream++    attempt mSpan attemptNo lastConflict = do+        hydrated <- hydrate options eventStream targetStream+        either (\err -> pure (Left err, attemptNo)) (runPlan mSpan attemptNo lastConflict) hydrated++    runPlan mSpan attemptNo lastConflict current =+        case conflictFixpoint lastConflict (current ^. #streamVersion) of+            Just err -> pure (Left err, attemptNo)+            Nothing ->+                case prepareCommandPlan options eventStream targetStream current command of+                    Left err -> pure (Left err, attemptNo)+                    Right (CommandNoOp result) -> pure (Right (result, Nothing), attemptNo)+                    Right (CommandAppend current' events encoded) ->+                        appendWithSqlOnce mSpan attemptNo current' events encoded++    appendWithSqlOnce mSpan attemptNo current events encoded = do+        liftIO (options ^. #beforeAppend)+        store <- getKirokuStore+        enriched <- liftIO (enrichEventsIO store encoded)+        prepared <- prepareEventsIO enriched+        now <- liftIO getCurrentTime+        let streamName = (eventStream ^. #resolveStreamName) targetStream+            expected = expectedVersion (current ^. #streamVersion)+            body = do+                appended <- appendToStreamTx streamName expected prepared now+                case appended of+                    Left conflict ->+                        Tx.condemn $> Left (appendConflictToStoreError conflict)+                    Right appendResult -> do+                        let recordeds = reconstructRecorded appendResult now prepared+                        userValue <- afterAppend (Prelude.zip events recordeds) appendResult+                        pure (Right (appendResult, userValue))+        outcome <- tryError @StoreError (runTransaction body)+        case outcome of+            Right (Right (appendResult, userValue)) -> do+                verifyAndSnapshot options mSpan eventStream current events appendResult+                pure (Right (appendedResult targetStream appendResult (Prelude.length encoded), Just userValue), attemptNo)+            Right (Left storeError) ->+                retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError+            Left (_, storeError) ->+                retryOrFail options (attempt mSpan) attemptNo (current ^. #streamVersion) storeError++prepareCommandPlan ::+    (BoolAlg phi (RegFile rs, ci)) =>+    RunCommandOptions ->+    EventStream phi rs s ci co ->+    Stream (EventStream phi rs s ci co) ->+    Hydrated rs s ->+    ci ->+    Either CommandError (CommandPlan (EventStream phi rs s ci co) rs s co)+prepareCommandPlan options eventStream targetStream current command =+    case evaluateCommand eventStream current command of+        Left err -> Left err+        Right events -> toPlan events+  where+    toPlan [] =+        Right (CommandNoOp (noOpResult targetStream current))+    toPlan events =+        CommandAppend current events+            . assignEventIds (options ^. #eventIds)+            <$> encodeEvents (eventStream ^. #eventCodec) (options ^. #metadata) events++{- | Render the stream that the command targets as plain 'Text', for use+as a span name.+-}+resolvedStreamName ::+    EventStream phi rs s ci co ->+    Stream (EventStream phi rs s ci co) ->+    Text+resolvedStreamName eventStream targetStream =+    case (eventStream ^. #resolveStreamName) targetStream of+        StreamName n -> n++{- | Attach the command-span outcome attributes after the runner returns.++On success: 'db.system.name' and 'keiro.events.appended'.+On failure: 'error.type' (low-cardinality classifier) and span status+'Error' (carrying the rendered 'CommandError' as the description).++Pure no-op when no span is active ('Nothing' tracer, etc).+-}+recordCommandOutcome ::+    (IOE :> es) =>+    Maybe Span ->+    (a -> Int) ->+    Int ->+    Either CommandError a ->+    Eff es ()+recordCommandOutcome Nothing _ _ _ = pure ()+recordCommandOutcome (Just sp) eventsOf attemptNo result = do+    addAttribute sp (unkey db_system_name) ("postgresql" :: Text)+    addAttribute sp (unkey keiro_retry_attempt) (Prelude.fromIntegral attemptNo :: Int64)+    case result of+        Right v ->+            addAttribute sp (unkey keiro_events_appended) (Prelude.fromIntegral (eventsOf v) :: Int64)+        Left err -> do+            addAttribute sp (unkey error_type) (commandErrorClass err)+            setStatus sp (Error (Text.take 256 (Text.pack (show err))))++{- | Low-cardinality classifier for a 'CommandError'. Used as the+@error.type@ attribute value on the command span.+-}+commandErrorClass :: CommandError -> Text+commandErrorClass = \case+    HydrationDecodeFailed{} -> "hydration_decode_failed"+    HydrationReplayFailed _ HydrationNoInvertingEdge -> "hydration_replay_no_inverting_edge"+    HydrationReplayFailed _ HydrationAmbiguousInversion -> "hydration_replay_ambiguous_inversion"+    HydrationReplayFailed _ HydrationQueueMismatch -> "hydration_replay_queue_mismatch"+    HydrationReplayFailed _ HydrationTruncatedChain -> "hydration_replay_truncated_chain"+    HydrationGapDetected{} -> "hydration_gap_detected"+    CommandRejected -> "command_rejected"+    CommandAmbiguous{} -> "command_ambiguous"+    EncodeFailed{} -> "encode_failed"+    StoreFailed{} -> "store_failed"+    RetryExhausted{} -> "retry_exhausted"+    ConflictFixpoint{} -> "conflict_fixpoint"++verifyAndSnapshot ::+    forall phi rs s ci co es.+    (BoolAlg phi (RegFile rs, ci), IOE :> es, Store :> es, Error StoreError :> es, Eq co) =>+    RunCommandOptions ->+    Maybe Span ->+    EventStream phi rs s ci co ->+    Hydrated rs s ->+    [co] ->+    AppendResult ->+    Eff es ()+verifyAndSnapshot options mSpan eventStream current events appendResult+    | Prelude.not (options ^. #verifyReplayOnAppend)+    , Nothing <- eventStream ^. #stateCodec =+        pure ()+    | otherwise =+        case Keiki.applyEventsEither (eventStream ^. #transducer) (state current, registers current) events of+            Left failure -> do+                recordSnapshotApplyDivergence (options ^. #metrics) 1+                for_ mSpan $ \sp ->+                    addAttribute+                        sp+                        (unkey keiro_replay_divergence)+                        (Text.take 256 (renderReplayFailure failure))+            Right finalState ->+                case eventStream ^. #stateCodec of+                    Nothing -> pure ()+                    Just codec -> do+                        let finalVersion = appendResult ^. #streamVersion+                            terminality =+                                if Keiki.isFinal (eventStream ^. #transducer) (Prelude.fst finalState)+                                    then Terminal+                                    else NotTerminal+                        when (shouldSnapshotSpan (eventStream ^. #snapshotPolicy) terminality finalState (current ^. #streamVersion) finalVersion)+                            $ do+                                encoded <- liftIO (encodeSnapshotStrict codec finalState)+                                case encoded of+                                    Left _ -> recordSnapshotEncodeFailures (options ^. #metrics) 1+                                    Right value -> do+                                        outcome <- tryError @StoreError (writeSnapshotEncoded (appendResult ^. #streamId) finalVersion codec value)+                                        case outcome of+                                            Right () -> pure ()+                                            Left _ -> recordSnapshotWriteFailures (options ^. #metrics) 1++renderReplayFailure :: Keiki.ReplayFailure s co -> Text+renderReplayFailure failure =+    "event_index="+        <> Text.pack (show (Keiki.replayFailedIndex failure))+        <> ";reason="+        <> case Keiki.replayFailureReason failure of+            Keiki.ReplayEventFailed stepFailure -> case stepFailure of+                Keiki.ReplayNoInvertingEdge{} -> "no_inverting_edge"+                Keiki.ReplayAmbiguousInversions{} -> "ambiguous_inversions"+                Keiki.ReplayQueueMismatch{} -> "queue_mismatch"+            Keiki.ReplayLogTruncated{} -> "log_truncated"++retryOrFail ::+    (IOE :> es) =>+    RunCommandOptions ->+    (Int -> Maybe (StoreError, StreamVersion) -> Eff es (Either CommandError a, Int)) ->+    Int ->+    StreamVersion ->+    StoreError ->+    Eff es (Either CommandError a, Int)+retryOrFail options retry attemptNo observedVersion storeError+    | isRetryableConflict storeError+    , attemptNo <= options ^. #retryLimit = do+        recordCommandConflicts (options ^. #metrics) 1+        backoffDelay options attemptNo+        recordCommandRetries (options ^. #metrics) 1+        retry (attemptNo Prelude.+ 1) (Just (storeError, observedVersion))+    | isRetryableConflict storeError = do+        recordCommandConflicts (options ^. #metrics) 1+        pure (Left (RetryExhausted attemptNo storeError), attemptNo)+    | otherwise = do+        case storeError of+            DuplicateEvent{} -> recordCommandDuplicates (options ^. #metrics) 1+            _ -> pure ()+        pure (Left (StoreFailed storeError), attemptNo)++backoffDelay :: (IOE :> es) => RunCommandOptions -> Int -> Eff es ()+backoffDelay options attemptNo+    | base <= 0 = pure ()+    | otherwise = do+        nanos <- liftIO getMonotonicTimeNSec+        let exponential = min 100000 (base Prelude.* (2 Prelude.^ (attemptNo Prelude.- 1 :: Int)))+            jitter =+                Prelude.fromIntegral (nanos `Prelude.mod` Prelude.fromIntegral exponential)+                    Prelude.- (exponential `Prelude.div` 2)+        liftIO (threadDelay (max 0 (exponential Prelude.+ jitter)))+  where+    base = options ^. #retryBackoffMicros++conflictFixpoint :: Maybe (StoreError, StreamVersion) -> StreamVersion -> Maybe CommandError+conflictFixpoint (Just (previousError@StreamAlreadyExists{}, previousVersion)) currentVersion+    | currentVersion == previousVersion = Just (ConflictFixpoint currentVersion previousError)+conflictFixpoint _ _ = Nothing++evaluateCommand ::+    (BoolAlg phi (RegFile rs, ci)) =>+    EventStream phi rs s ci co ->+    Hydrated rs s ->+    ci ->+    Either CommandError [co]+evaluateCommand eventStream current command =+    case Keiki.stepEither (eventStream ^. #transducer) (state current, registers current) command of+        Left Keiki.NoOutgoingEdges{} -> Left CommandRejected+        Left Keiki.NoMatchingEdge{} -> Left CommandRejected+        Left (Keiki.AmbiguousEdges _ matches) ->+            Left+                ( CommandAmbiguous+                    [ Keiki.edgeIndex (Keiki.matchedEdge matched)+                    | matched <- matches+                    ]+                )+        Right (_, _, events) -> Right events++encodeEvents :: Codec co -> Maybe Value -> [co] -> Either CommandError [EventData]+encodeEvents codec md =+    Prelude.mapM (mapLeft EncodeFailed . encodeForAppendWithMetadata codec md)++assignEventIds :: [EventId] -> [EventData] -> [EventData]+assignEventIds [] events = events+assignEventIds _ [] = []+assignEventIds (supplied : suppliedRest) (event : eventRest) =+    (event & #eventId .~ Just supplied) : assignEventIds suppliedRest eventRest++expectedVersion :: StreamVersion -> ExpectedVersion+expectedVersion (StreamVersion 0) = NoStream+expectedVersion version = ExactVersion version++noOpResult ::+    Stream target ->+    Hydrated rs s ->+    CommandResult target+noOpResult targetStream current =+    CommandResult+        { target = targetStream+        , streamVersion = current ^. #streamVersion+        , globalPosition = Nothing+        , eventsAppended = 0+        }++appendedResult ::+    Stream target ->+    AppendResult ->+    Int ->+    CommandResult target+appendedResult targetStream appendResult count =+    CommandResult+        { target = targetStream+        , streamVersion = appendResult ^. #streamVersion+        , globalPosition = Just (appendResult ^. #globalPosition)+        , eventsAppended = count+        }++{- | Rebuild the per-event 'RecordedEvent' values for a just-appended batch.++The store assigns each event in a batch a contiguous stream version and+global position: event @i@ (1-based) gets @last - count + i@ for both+counters, where @last@ is the position the 'AppendResult' reports for the+final event and @count@ is the batch size. (The kiroku append SQL numbers+events with @WITH ORDINALITY@ and inserts @initial + idx@; see EP-27's+Surprises & Discoveries.) We therefore reconstruct each 'RecordedEvent'+exactly, rather than reading the batch back. The @createdAt@ is the same+timestamp 'prepareEventsIO'/'appendToStreamTx' used for the insert.++This is a source append (events are written to their own stream), so+@streamVersion == originalVersion@ and @originalStreamId@ is the appended+stream's id, per the 'RecordedEvent' contract.+-}+reconstructRecorded :: AppendResult -> UTCTime -> [PreparedEvent] -> [RecordedEvent]+reconstructRecorded appendResult now prepared =+    Prelude.zipWith mk [0 ..] prepared+  where+    count = Prelude.length prepared+    StreamVersion lastSv = appendResult ^. #streamVersion+    GlobalPosition lastGp = appendResult ^. #globalPosition+    firstSv = lastSv Prelude.- Prelude.fromIntegral count Prelude.+ 1+    firstGp = lastGp Prelude.- Prelude.fromIntegral count Prelude.+ 1+    mk :: Int64 -> PreparedEvent -> RecordedEvent+    mk i prepared' =+        RecordedEvent+            { eventId = EventId (prepared' ^. #peEventId)+            , eventType = prepared' ^. #peEventType+            , streamVersion = StreamVersion (firstSv Prelude.+ i)+            , globalPosition = GlobalPosition (firstGp Prelude.+ i)+            , originalStreamId = appendResult ^. #streamId+            , originalVersion = StreamVersion (firstSv Prelude.+ i)+            , payload = prepared' ^. #pePayload+            , metadata = prepared' ^. #peMetadata+            , causationId = prepared' ^. #peCausationId+            , correlationId = prepared' ^. #peCorrelationId+            , createdAt = now+            }++isRetryableConflict :: StoreError -> Bool+isRetryableConflict = \case+    WrongExpectedVersion{} -> True+    StreamAlreadyExists{} -> True+    _ -> False++mapLeft :: (e -> e') -> Either e a -> Either e' a+mapLeft f = \case+    Left err -> Left (f err)+    Right value -> Right value
+ src/Keiro/Connection.hs view
@@ -0,0 +1,100 @@+{- | Schema-resolution helpers for application read-model and projection tables.++Keiro's own framework tables live in the dedicated @keiro@ schema and its+runtime queries are fully qualified there. This module is about the /third/+layer: where an application's read-model /data/ tables live, and how the+application declares and reaches that location.++A PostgreSQL /schema/ is a namespace of tables inside one database. Because+Keiro opens its database pool through kiroku's connection settings — whose+@search_path@ starts with the event store's private @kiroku@ schema — an+unqualified @CREATE TABLE my_read_model (...)@ would land the table inside the+@kiroku@ event-store schema. To place it elsewhere, the application must+qualify at least its @CREATE TABLE@ as @schema.table@ (an unqualified create+always lands in the first @search_path@ entry). Qualifying the read/write SQL+too makes everything correct regardless of @search_path@ — the robust default.++This module gives applications exactly one convention:++* 'qualifyTable' builds a double-quoted, schema-qualified table reference to+  interpolate into projection SQL.+* 'withProjectionSchema' / 'keiroConnectionSettings' wire the store connection+  so a chosen projection schema also /resolves/ on the pool (via kiroku's+  @extraSearchPath@), for applications that also want unqualified SQL to work.+* 'ensureProjectionSchema' is an opt-in @CREATE SCHEMA IF NOT EXISTS@ helper for+  development, tests, and worked examples; Keiro never calls it automatically.++The kiroku store connection's @schema@ field stays @kiroku@ and is never+repointed: it also drives the @<schema>.events@ @LISTEN@/@NOTIFY@ channel, so+changing it would break subscription wake-ups. The projection schema is reached+only by qualification and\/or @extraSearchPath@.+-}+module Keiro.Connection (+    qualifyTable,+    quoteIdentifier,+    withProjectionSchema,+    keiroConnectionSettings,+    ensureProjectionSchema,+)+where++import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Effectful (Eff, (:>))+import Keiro.Prelude+import Kiroku.Store.Connection (ConnectionSettings, defaultConnectionSettings)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import "hasql-transaction" Hasql.Transaction qualified as Tx++{- | Build a double-quoted, schema-qualified table reference @"schema"."table"@,+doubling any embedded double quotes (the same identifier quoting kiroku uses).+Interpolate the result directly into projection SQL, e.g.++@+"SELECT ... FROM " <> qualifyTable "app" "orders" <> " WHERE ..."+@+-}+qualifyTable :: Text -> Text -> Text+qualifyTable schema table = quoteIdentifier schema <> "." <> quoteIdentifier table++{- | Double-quote a single SQL identifier, doubling any embedded double quotes+(the same identifier quoting kiroku uses). Useful for building qualified names+or a @CREATE SCHEMA "<name>"@ statement.+-}+quoteIdentifier :: Text -> Text+quoteIdentifier ident = "\"" <> T.replace "\"" "\"\"" ident <> "\""++{- | Append @projectionSchema@ to a settings value's @extraSearchPath@ so a+pooled connection can /resolve/ (read\/write) application tables in that schema.+Idempotent: the schema is appended only if not already present. The store's+@schema@ field is left untouched (stays @kiroku@).+-}+withProjectionSchema :: Text -> ConnectionSettings -> ConnectionSettings+withProjectionSchema projectionSchema settings =+    settings & #extraSearchPath %~ appendUnique projectionSchema+  where+    appendUnique s xs+        | s `elem` xs = xs+        | otherwise = xs <> [s]++{- | kiroku's default connection settings (@schema = "kiroku"@) with+@projectionSchema@ added to @extraSearchPath@, so unqualified application+data-manipulation SQL resolves on the store pool while the store @schema@ stays+@kiroku@ (honoring the NOTIFY-channel constraint). This does /not/ bake Keiro's+own @keiro@ schema into @extraSearchPath@: Keiro's runtime queries are already+fully qualified and must not depend on @search_path@.+-}+keiroConnectionSettings :: Text -> Text -> ConnectionSettings+keiroConnectionSettings connString projectionSchema =+    withProjectionSchema projectionSchema (defaultConnectionSettings connString)++{- | Run @CREATE SCHEMA IF NOT EXISTS "<schema>"@ in a transaction. This is+opt-in: Keiro never calls it automatically. Use it in development, tests, and+worked examples where the application (not a production migration tool) owns+schema creation.+-}+ensureProjectionSchema :: (Store :> es) => Text -> Eff es ()+ensureProjectionSchema projectionSchema =+    runTransaction $+        Tx.sql (TE.encodeUtf8 ("CREATE SCHEMA IF NOT EXISTS " <> quoteIdentifier projectionSchema))
+ src/Keiro/DeadLetter.hs view
@@ -0,0 +1,35 @@+{- | Durable records for process-manager and router dispatches rejected by a+target state machine.++Use 'recordDispatchDeadLetter' from a worker before acknowledging its source+event, and 'listDispatchDeadLetters' to inspect the durable witnesses for one+dispatcher. Inserts are idempotent under source-event redelivery.+-}+module Keiro.DeadLetter (+    DispatcherKind (..),+    DispatchDeadLetter (..),+    DispatchDeadLetterRecord (..),+    recordDispatchDeadLetter,+    listDispatchDeadLetters,+)+where++import Effectful (Eff, (:>))+import Keiro.DeadLetter.Schema (+    DispatchDeadLetter (..),+    DispatchDeadLetterRecord (..),+    DispatcherKind (..),+    listDispatchDeadLettersTx,+    recordDispatchDeadLetterTx,+ )+import Keiro.Prelude+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)++-- | Idempotently persist one rejected dispatch.+recordDispatchDeadLetter :: (Store :> es) => DispatchDeadLetter -> Eff es ()+recordDispatchDeadLetter = runTransaction . recordDispatchDeadLetterTx++-- | List one dispatcher's rejected dispatches, newest first.+listDispatchDeadLetters :: (Store :> es) => Text -> Eff es [DispatchDeadLetterRecord]+listDispatchDeadLetters = runTransaction . listDispatchDeadLettersTx
+ src/Keiro/DeadLetter/Replay.hs view
@@ -0,0 +1,148 @@+{- | Operator replay for source events parked in Kiroku's+@kiroku.dead_letters@ table.++The rows remain Kiroku-owned: replay neither deletes nor marks them. Instead it+re-runs a caller-supplied handler and relies on that handler's idempotency. This+is safe for "Keiro.ProcessManager" and "Keiro.Router" handlers because their+writes use deterministic event identifiers derived from the source event;+already-applied writes collapse to duplicate outcomes on every later replay.++Kiroku exposes dead-letter rows by event id and global position, but does not+currently expose an exact point-read by either value. Global positions are+opaque cursors and must never be decremented. 'replaySubscriptionDeadLetters'+therefore scans the global stream backward using only @0@ and cursors returned+by Kiroku, matches both event id and position, and scans once for the whole+batch. A source event removed by hard deletion is reported as+'ReplaySourceMissing' and is not handed to the caller.++A process-manager handler normally decodes the recorded event, calls+@runProcessManagerOnce@, and classifies a result whose manager state and every+target command are duplicates as 'ReplayedDuplicate'; any append makes it+'ReplayedFresh'. Return @Left detail@ for a decode or command failure. For+example, the classification has this shape:++> case result of+>   Left err -> Left (showText err)+>   Right pmResult+>     | managerAndEveryCommandAreDuplicates pmResult -> Right ReplayedDuplicate+>     | otherwise -> Right ReplayedFresh++Because rows are retained, an operator may safely run the same replay command+again after a partial failure or uncertain client disconnect.+-}+module Keiro.DeadLetter.Replay (+    ReplayOutcome (..),+    ReplayResult (..),+    DeadLetterRecord (..),+    listSubscriptionDeadLetters,+    replaySubscriptionDeadLetters,+)+where++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 Vector+import Effectful (Eff, (:>))+import Keiro.Prelude+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Read (readAllBackward)+import Kiroku.Store.SQL (DeadLetterRecord (..), readDeadLettersStmt)+import Kiroku.Store.Subscription.Types (SubscriptionName (..))+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (EventId (..), GlobalPosition (..), RecordedEvent)+import "hasql-transaction" Hasql.Transaction qualified as Tx++data ReplayOutcome = ReplayOutcome+    { replayGlobalPosition :: !GlobalPosition+    , replayEventId :: !EventId+    , replayResult :: !ReplayResult+    }+    deriving stock (Generic, Eq, Show)++data ReplayResult+    = ReplayedFresh+    | ReplayedDuplicate+    | ReplayFailed !Text+    | ReplaySourceMissing+    deriving stock (Generic, Eq, Show)++-- | List one Kiroku subscription member's dead letters, newest first.+listSubscriptionDeadLetters ::+    (Store :> es) => SubscriptionName -> Int32 -> Eff es (Vector DeadLetterRecord)+listSubscriptionDeadLetters (SubscriptionName name) member =+    runTransaction (Tx.statement (name, member) readDeadLettersStmt)++{- | Replay every dead letter currently listed for one subscription member.++The handler controls domain-specific decoding and decides whether its writes+were fresh or duplicates. A @Left detail@ is recorded in the corresponding+'ReplayOutcome' as 'ReplayFailed'; replay continues with later rows. Store+errors still surface through the surrounding Kiroku 'Store' interpreter.+-}+replaySubscriptionDeadLetters ::+    (Store :> es) =>+    SubscriptionName ->+    Int32 ->+    (RecordedEvent -> Eff es (Either Text ReplayResult)) ->+    Eff es [ReplayOutcome]+replaySubscriptionDeadLetters subscriptionName member handler = do+    rows <- listSubscriptionDeadLetters subscriptionName member+    sources <- findSources rows+    traverse (replayOne sources) (Vector.toList rows)+  where+    replayOne sources row = do+        let position = deadLetterPosition row+            eventId = deadLetterEventIdValue row+        result <- case Map.lookup eventId sources of+            Just event+                | event ^. #globalPosition == position -> do+                    handled <- handler event+                    pure (either ReplayFailed id handled)+            _ -> pure ReplaySourceMissing+        pure+            ReplayOutcome+                { replayGlobalPosition = position+                , replayEventId = eventId+                , replayResult = result+                }++-- Scan once for the complete replay batch. Pages are descending, and the next+-- cursor is always a position Kiroku returned; no global-position arithmetic.+findSources ::+    (Store :> es) => Vector DeadLetterRecord -> Eff es (Map EventId RecordedEvent)+findSources rows = go (GlobalPosition 0) Map.empty+  where+    wanted =+        Map.fromList+            [ (deadLetterEventIdValue row, deadLetterPosition row)+            | row <- Vector.toList rows+            ]++    go cursor found+        | Map.size found == Map.size wanted = pure found+        | otherwise = do+            page <- readAllBackward cursor replayReadPageSize+            if Vector.null page+                then pure found+                else do+                    let found' = Vector.foldl' remember found page+                        nextCursor = Vector.last page ^. #globalPosition+                    go nextCursor found'++    remember found event =+        case Map.lookup (event ^. #eventId) wanted of+            Just expectedPosition+                | event ^. #globalPosition == expectedPosition ->+                    Map.insert (event ^. #eventId) event found+            _ -> found++replayReadPageSize :: Int32+replayReadPageSize = 256++deadLetterPosition :: DeadLetterRecord -> GlobalPosition+deadLetterPosition row = GlobalPosition (row ^. #deadLetterGlobalPosition)++deadLetterEventIdValue :: DeadLetterRecord -> EventId+deadLetterEventIdValue row = EventId (row ^. #deadLetterEventId)
+ src/Keiro/DeadLetter/Schema.hs view
@@ -0,0 +1,171 @@+{- | SQL storage for rejected process-manager and router dispatches.++The @keiro.keiro_dead_letters@ table records a dispatched command that a+target state machine rejected. It is deliberately separate from Kiroku's+subscription dead-letter table: a row here describes one failed dispatch,+while the source subscription event is considered handled and may advance its+checkpoint.+-}+module Keiro.DeadLetter.Schema (+    DispatcherKind (..),+    DispatchDeadLetter (..),+    DispatchDeadLetterRecord (..),+    recordDispatchDeadLetterTx,+    listDispatchDeadLettersTx,+)+where++import Contravariant.Extras (contrazip10)+import Data.Int (Int32)+import Data.Text qualified as Text+import Data.UUID (UUID)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Prelude+import Kiroku.Store.Types (EventId (..), GlobalPosition (..), StreamName (..))+import "hasql-transaction" Hasql.Transaction qualified as Tx+import Prelude (fromIntegral)++-- | Which coordination primitive attempted the rejected dispatch.+data DispatcherKind+    = DispatcherProcessManager+    | DispatcherRouter+    deriving stock (Generic, Eq, Ord, Show)++-- | Fields persisted for one rejected dispatch.+data DispatchDeadLetter = DispatchDeadLetter+    { dispatcherKind :: !DispatcherKind+    , dispatcherName :: !Text+    , correlationId :: !Text+    , sourceEventId :: !EventId+    , sourceGlobalPosition :: !GlobalPosition+    , emitIndex :: !Int+    , targetStreamName :: !StreamName+    , errorClass :: !Text+    , errorDetail :: !Text+    , attemptCount :: !Int+    }+    deriving stock (Generic, Eq, Show)++-- | A persisted rejected dispatch, including database-managed identity and time.+data DispatchDeadLetterRecord = DispatchDeadLetterRecord+    { deadLetterId :: !Int64+    , dispatcherKind :: !DispatcherKind+    , dispatcherName :: !Text+    , correlationId :: !Text+    , sourceEventId :: !EventId+    , sourceGlobalPosition :: !GlobalPosition+    , emitIndex :: !Int+    , targetStreamName :: !StreamName+    , errorClass :: !Text+    , errorDetail :: !Text+    , attemptCount :: !Int+    , createdAt :: !UTCTime+    }+    deriving stock (Generic, Eq, Show)++{- | Insert a rejected dispatch inside the caller's transaction. Redelivery is+idempotent: a duplicate @(dispatcher_name, source_event_id, emit_index)@ is a+no-op. Error detail is bounded here so every caller gets the same 1024-character+storage contract.+-}+recordDispatchDeadLetterTx :: DispatchDeadLetter -> Tx.Transaction ()+recordDispatchDeadLetterTx deadLetter =+    Tx.statement (dispatchDeadLetterParams deadLetter) insertDispatchDeadLetterStmt++-- | List one dispatcher's records, newest first.+listDispatchDeadLettersTx :: Text -> Tx.Transaction [DispatchDeadLetterRecord]+listDispatchDeadLettersTx dispatcher =+    Tx.statement dispatcher listDispatchDeadLettersStmt++insertDispatchDeadLetterStmt :: Statement (Text, Text, Text, UUID, Int64, Int32, Text, Text, Text, Int32) ()+insertDispatchDeadLetterStmt =+    preparable+        """+        INSERT INTO keiro.keiro_dead_letters+          (dispatcher_kind, dispatcher_name, correlation_id, source_event_id,+           source_global_position, emit_index, target_stream_name, error_class,+           error_detail, attempt_count)+        VALUES+          ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10)+        ON CONFLICT (dispatcher_name, source_event_id, emit_index) DO NOTHING+        """+        ( contrazip10+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.int4))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+        )+        D.noResult++listDispatchDeadLettersStmt :: Statement Text [DispatchDeadLetterRecord]+listDispatchDeadLettersStmt =+    preparable+        """+        SELECT dead_letter_id, dispatcher_kind, dispatcher_name, correlation_id,+               source_event_id, source_global_position, emit_index,+               target_stream_name, error_class, error_detail, attempt_count,+               created_at+        FROM keiro.keiro_dead_letters+        WHERE dispatcher_name = $1+        ORDER BY created_at DESC, dead_letter_id DESC+        """+        (E.param (E.nonNullable E.text))+        (D.rowList dispatchDeadLetterRecordDecoder)++dispatchDeadLetterRecordDecoder :: D.Row DispatchDeadLetterRecord+dispatchDeadLetterRecordDecoder =+    DispatchDeadLetterRecord+        <$> D.column (D.nonNullable D.int8)+        <*> D.column (D.nonNullable (D.refine dispatcherKindFromText D.text))+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> (EventId <$> D.column (D.nonNullable D.uuid))+        <*> (GlobalPosition <$> D.column (D.nonNullable D.int8))+        <*> (fromIntegral <$> D.column (D.nonNullable D.int4))+        <*> (StreamName <$> D.column (D.nonNullable D.text))+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> (fromIntegral <$> D.column (D.nonNullable D.int4))+        <*> D.column (D.nonNullable D.timestamptz)++dispatchDeadLetterParams :: DispatchDeadLetter -> (Text, Text, Text, UUID, Int64, Int32, Text, Text, Text, Int32)+dispatchDeadLetterParams deadLetter =+    ( dispatcherKindToText (deadLetter ^. #dispatcherKind)+    , deadLetter ^. #dispatcherName+    , deadLetter ^. #correlationId+    , eventIdToUuid (deadLetter ^. #sourceEventId)+    , globalPositionToInt64 (deadLetter ^. #sourceGlobalPosition)+    , fromIntegral (deadLetter ^. #emitIndex)+    , streamNameToText (deadLetter ^. #targetStreamName)+    , deadLetter ^. #errorClass+    , Text.take 1024 (deadLetter ^. #errorDetail)+    , fromIntegral (deadLetter ^. #attemptCount)+    )++dispatcherKindToText :: DispatcherKind -> Text+dispatcherKindToText = \case+    DispatcherProcessManager -> "process-manager"+    DispatcherRouter -> "router"++dispatcherKindFromText :: Text -> Either Text DispatcherKind+dispatcherKindFromText = \case+    "process-manager" -> Right DispatcherProcessManager+    "router" -> Right DispatcherRouter+    other -> Left ("unknown keiro_dead_letters.dispatcher_kind: " <> other)++eventIdToUuid :: EventId -> UUID+eventIdToUuid (EventId uuid) = uuid++globalPositionToInt64 :: GlobalPosition -> Int64+globalPositionToInt64 (GlobalPosition position) = position++streamNameToText :: StreamName -> Text+streamNameToText (StreamName name) = name
+ src/Keiro/Inbox.hs view
@@ -0,0 +1,426 @@+{- | Idempotent inbox for cross-bounded-context integration events.++The inbox lives in the consuming bounded context. When a Kafka consumer+receives an integration event, the inbox records the event's stable+external identity and runs the local handler in the same Postgres+transaction. Duplicate redeliveries (Kafka offset retry, rebalance,+producer republish) become observable as duplicates instead of+re-running the handler.++The wrapper is a single-transaction primitive: the completed inbox row+and the handler's local writes commit atomically. If the handler raises+or condemns the transaction, the inbox row never appears and the next+delivery starts fresh.++Completed-row retention defines the deduplication window. After+'garbageCollectCompleted' removes a row, a later delivery of the same key is+processed again. A concurrent GC can also delete a conflicting completed row+between the insert attempt and its lookup; the handler then commits without a+replacement deduplication row, so a later redelivery can run it again. These+cases preserve at-least-once delivery, not permanent exactly-once processing;+size retention beyond the maximum redelivery delay and keep handlers+idempotent.+-}+module Keiro.Inbox (+    -- * Re-exports+    module Keiro.Inbox.Types,++    -- * Storage primitives+    lookupInbox,+    listInbox,+    garbageCollectCompleted,+    countInboxBacklog,+    markFailedTx,++    -- * Transactional handler wrapper+    runInboxTransaction,+    runInboxTransactionWith,+    runInboxTransactionWithKey,+    runInboxTransactionWithRetries,+    runInboxTransactionWithRetriesWith,+    runInboxTransactionWithRetriesKey,+    runInboxTransactionBatch,+    sampleInboxBacklog,+)+where++import Data.Map.Strict qualified as Map+import Data.Maybe (listToMaybe, mapMaybe)+import Data.Text qualified as Text+import Effectful (Eff, IOE, (:>))+import Effectful.Exception (displayException, trySync)+import Keiro.Inbox.Schema+import Keiro.Inbox.Types+import Keiro.Integration.Event (IntegrationEvent)+import Keiro.Prelude+import Keiro.Telemetry (+    KeiroMetrics,+    recordInboxBacklog,+    recordInboxDuplicates,+    recordInboxFailed,+    recordInboxPoisoned,+    recordInboxProcessed,+ )+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import "hasql-transaction" Hasql.Transaction qualified as Tx++data BatchPlan+    = BatchKeyError !InboxError+    | BatchDuplicate+    | BatchWork !Text !Text !IntegrationEvent !(Maybe KafkaDeliveryRef)++{- | Run @handler@ at most once for each @(source, dedupe_key)@.++Computes the dedupe key from @policy@ and @kafka@, then in one+transaction:++* Inserts the inbox row with status @completed@.+* If the row already exists, branches on its status: 'InboxCompleted'+  → 'InboxDuplicate'; 'InboxProcessing' → 'InboxInProgress';+  'InboxFailed' → 'InboxPreviouslyFailed'.+* Otherwise runs @handler@; the row commits only if the handler succeeds.++The handler is invoked with the decoded 'IntegrationEvent' so it does+not need to redecode bytes. On exception or 'Tx.condemn' the whole+transaction rolls back, including the inbox row insert — the next+delivery sees no row and can retry.+-}+runInboxTransaction ::+    forall a es.+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    InboxDedupePolicy ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    (IntegrationEvent -> Tx.Transaction a) ->+    Eff es (Either InboxError (InboxResult a))+runInboxTransaction mMetrics policy event kafka handler =+    runInboxTransactionWith mMetrics PersistFullEnvelope policy event kafka handler++{- | Variant of 'runInboxTransaction' that controls success-path+envelope persistence.++'PersistDedupeOnly' keeps enough columns for dedupe and operator+correlation but stores an empty payload and omits schema, trace, and+attribute columns for successfully processed rows.+-}+runInboxTransactionWith ::+    forall a es.+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    InboxPersistence ->+    InboxDedupePolicy ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    (IntegrationEvent -> Tx.Transaction a) ->+    Eff es (Either InboxError (InboxResult a))+runInboxTransactionWith mMetrics persistence policy event kafka handler =+    case dedupeKeyFor policy event kafka of+        Left err -> pure (Left err)+        Right dedupe ->+            Right+                <$> runInboxTransactionWithKeyPersist+                    mMetrics+                    persistence+                    (event ^. #source)+                    dedupe+                    event+                    kafka+                    handler++{- | Lower-level variant that takes the dedupe key directly.++Use when the policy is not enough to express the identity scheme — for+example, when the consumer joins fields from multiple headers or+derives the key from the payload itself.+-}+runInboxTransactionWithKey ::+    forall a es.+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    Text ->+    Text ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    (IntegrationEvent -> Tx.Transaction a) ->+    Eff es (InboxResult a)+runInboxTransactionWithKey mMetrics src dedupe event kafka handler =+    runInboxTransactionWithKeyPersist mMetrics PersistFullEnvelope src dedupe event kafka handler++runInboxTransactionWithKeyPersist ::+    forall a es.+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    InboxPersistence ->+    Text ->+    Text ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    (IntegrationEvent -> Tx.Transaction a) ->+    Eff es (InboxResult a)+runInboxTransactionWithKeyPersist mMetrics persistence src dedupe event kafka handler = do+    now <- liftIO getCurrentTime+    result <-+        runTransaction $+            attemptOneTx persistence Nothing src dedupe event kafka now handler+    -- Record the classification counter outside the handler transaction.+    -- Backlog gauge sampling is intentionally scheduled separately via+    -- 'sampleInboxBacklog'.+    recordInboxResult mMetrics Nothing result+    pure result++{- | Run @handler@ with opt-in poison-message accounting.++This wrapper behaves like 'runInboxTransaction' for fresh messages,+duplicates, and in-flight rows, but changes the behavior for handler+exceptions and previously failed rows:++* A synchronous exception from @handler@ rolls back the handler+  transaction, then records a failed attempt in a second transaction and+  returns 'InboxHandlerFailed' with the new attempt count.+* A previously failed row with @attempt_count < ceiling@ is retried.+* A previously failed row with @attempt_count >= ceiling@ returns+  'InboxPreviouslyFailed' without running the handler. The consumer can+  commit its offset and move on; the failed inbox row is the dead-letter+  record for operator review.++'Tx.condemn' is not treated as a handler failure by this wrapper. It+keeps the original rollback semantics from 'runInboxTransaction'.+-}+runInboxTransactionWithRetries ::+    forall a es.+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    Int ->+    InboxDedupePolicy ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    (IntegrationEvent -> Tx.Transaction a) ->+    Eff es (Either InboxError (InboxResult a))+runInboxTransactionWithRetries mMetrics attemptCeiling policy event kafka handler =+    runInboxTransactionWithRetriesWith mMetrics attemptCeiling PersistFullEnvelope policy event kafka handler++-- | Variant of 'runInboxTransactionWithRetries' that controls success-path persistence.+runInboxTransactionWithRetriesWith ::+    forall a es.+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    Int ->+    InboxPersistence ->+    InboxDedupePolicy ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    (IntegrationEvent -> Tx.Transaction a) ->+    Eff es (Either InboxError (InboxResult a))+runInboxTransactionWithRetriesWith mMetrics attemptCeiling persistence policy event kafka handler =+    case dedupeKeyFor policy event kafka of+        Left err -> pure (Left err)+        Right dedupe ->+            Right+                <$> runInboxTransactionWithRetriesKeyPersist+                    mMetrics+                    attemptCeiling+                    persistence+                    (event ^. #source)+                    dedupe+                    event+                    kafka+                    handler++-- | Lower-level retrying variant that takes the dedupe key directly.+runInboxTransactionWithRetriesKey ::+    forall a es.+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    Int ->+    Text ->+    Text ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    (IntegrationEvent -> Tx.Transaction a) ->+    Eff es (InboxResult a)+runInboxTransactionWithRetriesKey mMetrics attemptCeiling src dedupe event kafka handler =+    runInboxTransactionWithRetriesKeyPersist mMetrics attemptCeiling PersistFullEnvelope src dedupe event kafka handler++runInboxTransactionWithRetriesKeyPersist ::+    forall a es.+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    Int ->+    InboxPersistence ->+    Text ->+    Text ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    (IntegrationEvent -> Tx.Transaction a) ->+    Eff es (InboxResult a)+runInboxTransactionWithRetriesKeyPersist mMetrics attemptCeiling persistence src dedupe event kafka handler = do+    now <- liftIO getCurrentTime+    attempted <-+        trySync $+            runTransaction $+                attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler+    result <- case attempted of+        Right ok -> pure ok+        Left err -> do+            failedAt <- liftIO getCurrentTime+            let errMsg = Text.pack (displayException err)+            attempts <-+                runTransaction $+                    recordFailedAttemptTx src dedupe event kafka errMsg failedAt+            pure (InboxHandlerFailed errMsg attempts)+    recordInboxResult mMetrics (Just attemptCeiling) result+    pure result++{- | Process a batch of inbox deliveries with a single transactional fast path.++The fast path computes each @(source, dedupe_key)@, suppresses repeated+keys within the batch as duplicates, then runs all remaining deliveries+in one Postgres transaction. If any handler throws or condemns that+transaction, the whole batch rolls back and every original delivery is+retried through 'runInboxTransactionWithRetries'. That fallback preserves+per-message failure accounting and prevents one poison message from+discarding unrelated batch mates.++'Tx.condemn' rolls the transaction back at commit but returns normally,+so it cannot be observed from the transaction's return value alone.+The batch detects it by re-reading one row it should have committed:+every write in the fast path belongs to a delivery classified+'InboxProcessed' (fresh insert as @completed@ or retry promotion to+@completed@), so if the first such row is not @completed@ after the+transaction returns, the whole batch was condemned and the per-message+fallback runs. A batch with no 'InboxProcessed' rows performed no writes,+so a condemned transaction loses nothing.+-}+runInboxTransactionBatch ::+    forall a es.+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    Int ->+    InboxDedupePolicy ->+    InboxPersistence ->+    [(IntegrationEvent, Maybe KafkaDeliveryRef)] ->+    (IntegrationEvent -> Tx.Transaction a) ->+    Eff es [Either InboxError (InboxResult a)]+runInboxTransactionBatch mMetrics attemptCeiling policy persistence deliveries handler = do+    now <- liftIO getCurrentTime+    let plan = planInboxBatch policy deliveries+    attempted <-+        trySync $+            runTransaction $+                traverse+                    ( \case+                        BatchKeyError err -> pure (Left err)+                        BatchDuplicate -> pure (Right InboxDuplicate)+                        BatchWork src dedupe event kafka ->+                            Right <$> attemptOneTx persistence (Just attemptCeiling) src dedupe event kafka now handler+                    )+                    plan+    case attempted of+        Right results -> do+            committed <- verifyBatchCommitted plan results+            if committed+                then do+                    for_ results $ \case+                        Right result -> recordInboxResult mMetrics (Just attemptCeiling) result+                        Left _ -> pure ()+                    pure results+                else perMessageFallback+        Left _ -> perMessageFallback+  where+    perMessageFallback :: Eff es [Either InboxError (InboxResult a)]+    perMessageFallback =+        traverse+            ( \(event, kafka) ->+                runInboxTransactionWithRetriesWith mMetrics attemptCeiling persistence policy event kafka handler+            )+            deliveries++    -- A condemned transaction returns its results normally but commits+    -- nothing. Re-read the first row the batch claims to have completed;+    -- if it is not @completed@, the transaction rolled back at commit.+    verifyBatchCommitted ::+        [BatchPlan] ->+        [Either InboxError (InboxResult a)] ->+        Eff es Bool+    verifyBatchCommitted plan results =+        case listToMaybe (mapMaybe processedKey (zip plan results)) of+            Nothing -> pure True+            Just (src, dedupe) -> do+                row <- lookupInbox src dedupe+                pure (fmap (^. #status) row == Just InboxCompleted)++    processedKey :: (BatchPlan, Either InboxError (InboxResult a)) -> Maybe (Text, Text)+    processedKey = \case+        (BatchWork src dedupe _ _, Right (InboxProcessed _)) -> Just (src, dedupe)+        _ -> Nothing++attemptOneTx ::+    InboxPersistence ->+    Maybe Int ->+    Text ->+    Text ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    UTCTime ->+    (IntegrationEvent -> Tx.Transaction a) ->+    Tx.Transaction (InboxResult a)+attemptOneTx persistence attemptCeiling src dedupe event kafka now handler = do+    inserted <- tryInsertCompletedTx persistence src dedupe event kafka now+    case inserted of+        Right () -> do+            handled <- handler event+            pure (InboxProcessed handled)+        Left row -> case row ^. #status of+            InboxCompleted -> pure InboxDuplicate+            InboxProcessing -> pure InboxInProgress+            InboxFailed -> case attemptCeiling of+                Nothing -> pure (InboxPreviouslyFailed (row ^. #lastError))+                Just attemptLimit+                    | row ^. #attemptCount >= attemptLimit ->+                        pure (InboxPreviouslyFailed (row ^. #lastError))+                    | otherwise -> do+                        handled <- handler event+                        markCompletedTx src dedupe now+                        pure (InboxProcessed handled)++recordInboxResult :: (IOE :> es) => Maybe KeiroMetrics -> Maybe Int -> InboxResult a -> Eff es ()+recordInboxResult mMetrics attemptCeiling = \case+    InboxProcessed _ -> recordInboxProcessed mMetrics 1+    InboxDuplicate -> recordInboxDuplicates mMetrics 1+    InboxPreviouslyFailed _ -> recordInboxFailed mMetrics 1+    InboxHandlerFailed _ attempts -> do+        recordInboxFailed mMetrics 1+        case attemptCeiling of+            Just attemptLimit | attempts >= attemptLimit -> recordInboxPoisoned mMetrics 1+            _ -> pure ()+    InboxInProgress -> pure ()++planInboxBatch ::+    InboxDedupePolicy ->+    [(IntegrationEvent, Maybe KafkaDeliveryRef)] ->+    [BatchPlan]+planInboxBatch policy = go Map.empty+  where+    go _ [] = []+    go seen ((event, kafka) : rest) =+        case dedupeKeyFor policy event kafka of+            Left err -> BatchKeyError err : go seen rest+            Right dedupe ->+                let key = (event ^. #source, dedupe)+                 in if Map.member key seen+                        then BatchDuplicate : go seen rest+                        else BatchWork (event ^. #source) dedupe event kafka : go (Map.insert key () seen) rest++{- | Count the inbox backlog and record the gauge when metrics are enabled.++The backlog is non-terminal rows: legacy @processing@ rows plus failed rows.+Schedule this on its own interval; it is intentionally not part of the+per-message intake path.+-}+sampleInboxBacklog :: (IOE :> es, Store :> es) => Maybe KeiroMetrics -> Eff es ()+sampleInboxBacklog Nothing = pure ()+sampleInboxBacklog (Just metrics) = do+    backlog <- countInboxBacklog+    recordInboxBacklog (Just metrics) (fromIntegral backlog)
+ src/Keiro/Inbox/Kafka.hs view
@@ -0,0 +1,212 @@+{- | Reconstruct an 'IntegrationEvent' from Kafka payload bytes plus+headers.++This module is the receiving-side counterpart of+'Keiro.Outbox.Kafka.integrationEventToKafkaRecord'. It is pure: the+caller supplies the bytes and the @Text@-keyed header map produced by+its Kafka adapter, and gets back a decoded envelope or a typed error.++@keiro@ itself does not depend on @hw-kafka-client@ or+@shibuya-kafka-adapter@; the consumer adapter in EP-22 bridges the+broker library's header type to @[(Text, Text)]@ before calling+'integrationEventFromKafka'.+-}+module Keiro.Inbox.Kafka (+    KafkaInboundRecord (..),+    KafkaDecodeError (..),+    integrationEventFromKafka,+)+where++import Data.Aeson qualified as Aeson+import Data.ByteString (ByteString)+import Data.Maybe (mapMaybe)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TextEncoding+import Data.Text.Read qualified as TextRead+import Data.Time.Format.ISO8601 (iso8601ParseM)+import Data.UUID qualified as UUID+import Keiro.Inbox.Types (KafkaDeliveryRef (..))+import Keiro.Integration.Event (+    IntegrationContentType (..),+    IntegrationEvent (..),+    SchemaReference (..),+    TraceContext (..),+    headerAttributes,+    headerCausationId,+    headerContentType,+    headerCorrelationId,+    headerDestination,+    headerEventType,+    headerMessageId,+    headerOccurredAt,+    headerSchemaFingerprint,+    headerSchemaId,+    headerSchemaRegistry,+    headerSchemaSubject,+    headerSchemaVersion,+    headerSchemaVersionRef,+    headerSource,+    headerSourceEventId,+    headerSourceGlobalPosition,+    headerTraceParent,+    headerTraceState,+    parseContentType,+ )+import Keiro.Prelude+import Kiroku.Store.Types (EventId (..), GlobalPosition (..))++{- | A Kafka record as seen by the consumer-side adapter, decoupled from+the broker library's record type.+-}+data KafkaInboundRecord = KafkaInboundRecord+    { topic :: !Text+    , partition :: !Int64+    , offset :: !Int64+    , key :: !(Maybe Text)+    , payload :: !ByteString+    , headers :: ![(Text, Text)]+    , receivedAt :: !UTCTime+    }+    deriving stock (Generic, Eq, Show)++-- | Typed failures from 'integrationEventFromKafka'.+data KafkaDecodeError+    = MissingHeader !Text+    | InvalidIntHeader !Text !Text+    | InvalidUuidHeader !Text !Text+    | InvalidTimeHeader !Text !Text+    | InvalidJsonHeader !Text !Text+    deriving stock (Generic, Eq, Show)++{- | Reconstruct a full 'IntegrationEvent' plus the 'KafkaDeliveryRef'+recorded for diagnostics.++The reconstruction is faithful to the canonical header names defined+by 'Keiro.Integration.Event' (e.g. @keiro-message-id@, @keiro-source@,+@traceparent@). Missing required headers (@keiro-source@,+@keiro-destination@, @keiro-event-type@, @keiro-schema-version@,+@content-type@, @keiro-message-id@) produce 'MissingHeader'; malformed+numeric or UUID headers produce 'InvalidIntHeader' / 'InvalidUuidHeader'.+Optional headers are silently absent in the resulting envelope.+-}+integrationEventFromKafka ::+    KafkaInboundRecord ->+    Either KafkaDecodeError (IntegrationEvent, KafkaDeliveryRef)+integrationEventFromKafka record = do+    let hs = record ^. #headers+    source <- requireHeader hs headerSource+    destination <- requireHeader hs headerDestination+    eventType <- requireHeader hs headerEventType+    schemaVersionText <- requireHeader hs headerSchemaVersion+    schemaVersion <- parseInt headerSchemaVersion schemaVersionText+    contentTypeRaw <- requireHeader hs headerContentType+    messageId <- requireHeader hs headerMessageId+    schemaReference <- buildSchemaReference hs+    sourceEventId <- traverseLookup hs headerSourceEventId (fmap EventId . parseUuid headerSourceEventId)+    sourceGlobalPosition <-+        traverseLookup hs headerSourceGlobalPosition (fmap GlobalPosition . parseInt headerSourceGlobalPosition)+    causationId <- traverseLookup hs headerCausationId (fmap EventId . parseUuid headerCausationId)+    correlationId <- traverseLookup hs headerCorrelationId (fmap EventId . parseUuid headerCorrelationId)+    occurredAt <- fromMaybe (record ^. #receivedAt) <$> traverseLookup hs headerOccurredAt (parseTimeHeader headerOccurredAt)+    attributes <- traverseLookup hs headerAttributes (parseJsonHeader headerAttributes)+    let traceContext = case Prelude.lookup headerTraceParent hs of+            Nothing -> Nothing+            Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs))+        event =+            IntegrationEvent+                { messageId+                , source+                , destination+                , key = record ^. #key+                , eventType+                , schemaVersion+                , contentType = parseContentType contentTypeRaw+                , schemaReference+                , sourceEventId+                , sourceGlobalPosition+                , payloadBytes = record ^. #payload+                , occurredAt+                , causationId+                , correlationId+                , traceContext+                , attributes+                }+        kafka =+            KafkaDeliveryRef+                { topic = record ^. #topic+                , partition = record ^. #partition+                , offset = record ^. #offset+                }+    pure (event, kafka)++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++requireHeader :: [(Text, Text)] -> Text -> Either KafkaDecodeError Text+requireHeader hs name = case Prelude.lookup name hs of+    Just v -> Right v+    Nothing -> Left (MissingHeader name)++traverseLookup ::+    [(Text, Text)] ->+    Text ->+    (Text -> Either KafkaDecodeError a) ->+    Either KafkaDecodeError (Maybe a)+traverseLookup hs name parser = case Prelude.lookup name hs of+    Nothing -> Right Nothing+    Just raw -> fmap Just (parser raw)++parseInt :: (Integral a) => Text -> Text -> Either KafkaDecodeError a+parseInt name raw = case TextRead.signed TextRead.decimal raw of+    Right (n, rest) | Text.null rest -> Right n+    _ -> Left (InvalidIntHeader name raw)++parseUuid :: Text -> Text -> Either KafkaDecodeError UUID.UUID+parseUuid name raw = case UUID.fromText raw of+    Just u -> Right u+    Nothing -> Left (InvalidUuidHeader name raw)++parseTimeHeader :: Text -> Text -> Either KafkaDecodeError UTCTime+parseTimeHeader name raw =+    maybe (Left (InvalidTimeHeader name raw)) Right (iso8601ParseM (Text.unpack raw))++parseJsonHeader :: Text -> Text -> Either KafkaDecodeError Value+parseJsonHeader name raw =+    case Aeson.eitherDecodeStrict (TextEncoding.encodeUtf8 raw) of+        Right value -> Right value+        Left _ -> Left (InvalidJsonHeader name raw)++buildSchemaReference ::+    [(Text, Text)] ->+    Either KafkaDecodeError (Maybe SchemaReference)+buildSchemaReference hs = do+    let registry = Prelude.lookup headerSchemaRegistry hs+        subject = Prelude.lookup headerSchemaSubject hs+        fingerprint = Prelude.lookup headerSchemaFingerprint hs+    versionRef <- traverseLookup hs headerSchemaVersionRef (parseInt headerSchemaVersionRef)+    schemaId <- traverseLookup hs headerSchemaId (parseInt headerSchemaId)+    let presentFields =+            mapMaybe id [registry, subject, fmap (Text.pack . show) versionRef, fmap (Text.pack . show) schemaId, fingerprint]+    if null presentFields+        then pure Nothing+        else+            pure+                ( Just+                    ( SchemaReference+                        { registry+                        , subject+                        , version = versionRef+                        , schemaId+                        , fingerprint+                        }+                    )+                )++{- | Silence unused-import warning when 'IntegrationContentType' is+imported only via the open re-export but referenced through+'parseContentType'.+-}+_unusedKeepContentType :: IntegrationContentType -> ()+_unusedKeepContentType _ = ()
+ src/Keiro/Inbox/Schema.hs view
@@ -0,0 +1,613 @@+{-# LANGUAGE ApplicativeDo #-}++{- | Hasql-level storage for the idempotent integration-event inbox.++This module owns the SQL surface that the inbox wrapper+('Keiro.Inbox.runInboxTransaction') and the optional Kafka decoder+('Keiro.Inbox.Kafka') consume.+-}+module Keiro.Inbox.Schema (+    tryInsertCompletedTx,+    markCompletedTx,+    markFailedTx,+    recordFailedAttemptTx,+    lookupInbox,+    listInbox,+    garbageCollectCompleted,+    countInboxBacklog,+)+where++import Contravariant.Extras (contrazip2, contrazip3, contrazip4)+import Data.ByteString (ByteString)+import Data.Functor.Contravariant ((>$<))+import Data.Time.Clock (NominalDiffTime, addUTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.UUID (UUID)+import Effectful (Eff, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Inbox.Types+import Keiro.Integration.Event (+    IntegrationEvent (..),+    SchemaReference (..),+    TraceContext (..),+    contentTypeText,+    parseContentType,+ )+import Keiro.Prelude+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (EventId (..), GlobalPosition (..))+import "hasql-transaction" Hasql.Transaction qualified as Tx++{- | Attempt to insert a new completed row.++Returns 'Left' carrying the existing row if @(source, dedupe_key)@+already exists; returns 'Right ()' if the insert created a new row. The+caller — typically 'Keiro.Inbox.runInboxTransaction' — then either runs+the handler (new) or branches on the existing row's status (duplicate).++The row is inserted as @completed@ before the handler runs, but remains+uncommitted until the handler transaction succeeds. On handler failure the+whole transaction rolls back, so the completed row never becomes visible.++If a concurrent retention job deletes the conflicting row between the+insert attempt and the lookup, this returns 'Right ()'. The handler's effects+then commit without a replacement deduplication row, and a later redelivery+can run the handler again. This preserves at-least-once delivery but not+permanent exactly-once processing. Retention must exceed the maximum tolerated+redelivery delay, and handlers must remain idempotent.+-}+tryInsertCompletedTx ::+    InboxPersistence ->+    Text ->+    Text ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    UTCTime ->+    Tx.Transaction (Either InboxRow ())+tryInsertCompletedTx persistence src dedupe event kafka now = do+    inserted <-+        Tx.statement (toEncodedInsert persistence src dedupe event kafka now) tryInsertStmt+    if inserted+        then pure (Right ())+        else do+            existing <- Tx.statement (src, dedupe) selectByKeyStmt+            case existing of+                Just row -> pure (Left row)+                Nothing -> pure (Right ())++-- | Mark an inbox row completed inside the same transaction as the handler.+markCompletedTx :: Text -> Text -> UTCTime -> Tx.Transaction ()+markCompletedTx src dedupe now =+    Tx.statement (src, dedupe, now) markCompletedStmt++-- | Mark an inbox row failed inside the same transaction as the handler.+markFailedTx :: Text -> Text -> Text -> UTCTime -> Tx.Transaction ()+markFailedTx src dedupe errMsg now =+    Tx.statement (src, dedupe, errMsg, now) markFailedStmt++{- | Record one failed handler attempt for @(source, dedupe_key)@.++Creates a failed row when the handler transaction rolled back the initial+processing insert, or increments the existing failed row's attempt count.+Returns the new attempt count.+-}+recordFailedAttemptTx ::+    Text ->+    Text ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    Text ->+    UTCTime ->+    Tx.Transaction Int+recordFailedAttemptTx src dedupe event kafka errMsg now =+    Tx.statement (toEncodedFailedInsert src dedupe event kafka errMsg now) recordFailedAttemptStmt++-- | Read one inbox row.+lookupInbox :: (Store :> es) => Text -> Text -> Eff es (Maybe InboxRow)+lookupInbox src dedupe =+    runTransaction $+        Tx.statement (src, dedupe) selectByKeyStmt++-- | List inbox rows for a source, ordered by @received_at@. Test helper.+listInbox :: (Store :> es) => Text -> Eff es [InboxRow]+listInbox src =+    runTransaction $+        Tx.statement src listBySourceStmt++{- | Count inbox rows in a non-terminal state (backlog gauge source).++Backlog = rows still @processing@ (in flight) or @failed@ (awaiting a+retry decision). Completed rows are terminal and excluded.+-}+countInboxBacklog :: (Store :> es) => Eff es Int+countInboxBacklog =+    runTransaction (Tx.statement () countInboxBacklogStmt)++{- | Delete completed inbox rows older than @keepFor@ from @now@.++Returns the number of rows deleted. The retention window defines the+duplicate-detection window: a redelivery that arrives after retention+GC has run will be processed again, so the window must exceed the+maximum delivery delay tolerated by the operator. The user guide+recommends 30 days as a default. See 'tryInsertCompletedTx' for the related+concurrent-GC race and its at-least-once consequence.+-}+garbageCollectCompleted ::+    (Store :> es) =>+    NominalDiffTime ->+    UTCTime ->+    Eff es Int+garbageCollectCompleted keepFor now = do+    let cutoff = addUTCTime (negate keepFor) now+    result <-+        runTransaction $+            Tx.statement cutoff gcStmt+    pure (fromIntegral result)++-- ---------------------------------------------------------------------------+-- Encoder support+-- ---------------------------------------------------------------------------++data EncodedInsert = EncodedInsert+    { source :: !Text+    , dedupeKey :: !Text+    , messageId :: !(Maybe Text)+    , sourceEventId :: !(Maybe UUID)+    , sourceGlobalPosition :: !(Maybe Int64)+    , destination :: !(Maybe Text)+    , eventType :: !(Maybe Text)+    , schemaVersion :: !(Maybe Int64)+    , contentType :: !Text+    , schemaRegistry :: !(Maybe Text)+    , schemaSubject :: !(Maybe Text)+    , schemaVersionRef :: !(Maybe Int64)+    , schemaId :: !(Maybe Int64)+    , schemaFingerprint :: !(Maybe Text)+    , causationId :: !(Maybe UUID)+    , correlationId :: !(Maybe UUID)+    , traceparent :: !(Maybe Text)+    , tracestate :: !(Maybe Text)+    , kafkaTopic :: !(Maybe Text)+    , kafkaPartition :: !(Maybe Int64)+    , kafkaOffset :: !(Maybe Int64)+    , payloadBytes :: !ByteString+    , attributes :: !(Maybe Value)+    , occurredAt :: !(Maybe UTCTime)+    , receivedAt :: !UTCTime+    }+    deriving stock (Generic)++data EncodedFailedInsert = EncodedFailedInsert+    { insert :: !EncodedInsert+    , lastError :: !Text+    }+    deriving stock (Generic)++toEncodedInsert ::+    InboxPersistence ->+    Text ->+    Text ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    UTCTime ->+    EncodedInsert+toEncodedInsert persistence src dedupe event kafka now =+    let mref = event ^. #schemaReference+        mtrace = event ^. #traceContext+     in EncodedInsert+            { source = src+            , dedupeKey = dedupe+            , messageId = nullIfEmpty (event ^. #messageId)+            , sourceEventId = fmap unEventId (event ^. #sourceEventId)+            , sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition)+            , destination = nullIfEmpty (event ^. #destination)+            , eventType = nullIfEmpty (event ^. #eventType)+            , schemaVersion = persistedSchema (Just (fromIntegral (event ^. #schemaVersion)))+            , contentType = contentTypeText (event ^. #contentType)+            , schemaRegistry = persistedSchema (mref >>= (^. #registry))+            , schemaSubject = persistedSchema (mref >>= (^. #subject))+            , schemaVersionRef = persistedSchema (fmap fromIntegral (mref >>= (^. #version)))+            , schemaId = persistedSchema (mref >>= (^. #schemaId))+            , schemaFingerprint = persistedSchema (mref >>= (^. #fingerprint))+            , causationId = fmap unEventId (event ^. #causationId)+            , correlationId = fmap unEventId (event ^. #correlationId)+            , traceparent = persistedEnvelope (fmap (^. #traceparent) mtrace)+            , tracestate = persistedEnvelope (mtrace >>= (^. #tracestate))+            , kafkaTopic = fmap (^. #topic) kafka+            , kafkaPartition = fmap (^. #partition) kafka+            , kafkaOffset = fmap (^. #offset) kafka+            , payloadBytes = case persistence of+                PersistFullEnvelope -> event ^. #payloadBytes+                PersistDedupeOnly -> mempty+            , attributes = persistedEnvelope (event ^. #attributes)+            , occurredAt = Just (event ^. #occurredAt)+            , receivedAt = now+            }+  where+    persistedEnvelope :: Maybe x -> Maybe x+    persistedEnvelope value = case persistence of+        PersistFullEnvelope -> value+        PersistDedupeOnly -> Nothing++    persistedSchema :: Maybe x -> Maybe x+    persistedSchema = persistedEnvelope++toEncodedFailedInsert ::+    Text ->+    Text ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    Text ->+    UTCTime ->+    EncodedFailedInsert+toEncodedFailedInsert src dedupe event kafka errMsg now =+    EncodedFailedInsert+        { insert = toEncodedInsert PersistFullEnvelope src dedupe event kafka now+        , lastError = errMsg+        }++nullIfEmpty :: Text -> Maybe Text+nullIfEmpty t = if t == mempty then Nothing else Just t++unEventId :: EventId -> UUID+unEventId (EventId u) = u++unGlobalPosition :: GlobalPosition -> Int64+unGlobalPosition (GlobalPosition i) = i++encodedInsertEncoder :: E.Params EncodedInsert+encodedInsertEncoder =+    mconcat+        [ view #source >$< E.param (E.nonNullable E.text)+        , view #dedupeKey >$< E.param (E.nonNullable E.text)+        , view #messageId >$< E.param (E.nullable E.text)+        , view #sourceEventId >$< E.param (E.nullable E.uuid)+        , view #sourceGlobalPosition >$< E.param (E.nullable E.int8)+        , view #destination >$< E.param (E.nullable E.text)+        , view #eventType >$< E.param (E.nullable E.text)+        , view #schemaVersion >$< E.param (E.nullable E.int8)+        , view #contentType >$< E.param (E.nonNullable E.text)+        , view #schemaRegistry >$< E.param (E.nullable E.text)+        , view #schemaSubject >$< E.param (E.nullable E.text)+        , view #schemaVersionRef >$< E.param (E.nullable E.int8)+        , view #schemaId >$< E.param (E.nullable E.int8)+        , view #schemaFingerprint >$< E.param (E.nullable E.text)+        , view #causationId >$< E.param (E.nullable E.uuid)+        , view #correlationId >$< E.param (E.nullable E.uuid)+        , view #traceparent >$< E.param (E.nullable E.text)+        , view #tracestate >$< E.param (E.nullable E.text)+        , view #kafkaTopic >$< E.param (E.nullable E.text)+        , view #kafkaPartition >$< E.param (E.nullable E.int8)+        , view #kafkaOffset >$< E.param (E.nullable E.int8)+        , view #payloadBytes >$< E.param (E.nonNullable E.bytea)+        , view #attributes >$< E.param (E.nullable E.jsonb)+        , view #occurredAt >$< E.param (E.nullable E.timestamptz)+        , view #receivedAt >$< E.param (E.nonNullable E.timestamptz)+        ]++encodedFailedInsertEncoder :: E.Params EncodedFailedInsert+encodedFailedInsertEncoder =+    (view #insert >$< encodedInsertEncoder)+        <> (view #lastError >$< E.param (E.nonNullable E.text))++-- ---------------------------------------------------------------------------+-- Statements+-- ---------------------------------------------------------------------------++tryInsertStmt :: Statement EncodedInsert Bool+tryInsertStmt =+    preparable+        """+        INSERT INTO keiro.keiro_inbox+          ( source+          , dedupe_key+          , message_id+          , source_event_id+          , source_global_position+          , destination+          , event_type+          , schema_version+          , content_type+          , schema_registry+          , schema_subject+          , schema_version_ref+          , schema_id+          , schema_fingerprint+          , causation_id+          , correlation_id+          , traceparent+          , tracestate+          , kafka_topic+          , kafka_partition+          , kafka_offset+          , payload_bytes+          , attributes+          , occurred_at+          , received_at+          , status+          , completed_at+          )+        VALUES+          ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'completed', $25)+        ON CONFLICT (source, dedupe_key) DO NOTHING+        RETURNING TRUE+        """+        encodedInsertEncoder+        (fmap (fromMaybe False) (D.rowMaybe (D.column (D.nonNullable D.bool))))++markCompletedStmt :: Statement (Text, Text, UTCTime) ()+markCompletedStmt =+    preparable+        """+        UPDATE keiro.keiro_inbox+        SET status = 'completed',+            completed_at = $3,+            last_error = NULL+        WHERE source = $1 AND dedupe_key = $2+        """+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.timestamptz))+        )+        D.noResult++markFailedStmt :: Statement (Text, Text, Text, UTCTime) ()+markFailedStmt =+    preparable+        """+        UPDATE keiro.keiro_inbox+        SET status = 'failed',+            failed_at = $4,+            last_error = $3+        WHERE source = $1 AND dedupe_key = $2+        """+        ( contrazip4+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.timestamptz))+        )+        D.noResult++recordFailedAttemptStmt :: Statement EncodedFailedInsert Int+recordFailedAttemptStmt =+    preparable+        """+        INSERT INTO keiro.keiro_inbox+          ( source+          , dedupe_key+          , message_id+          , source_event_id+          , source_global_position+          , destination+          , event_type+          , schema_version+          , content_type+          , schema_registry+          , schema_subject+          , schema_version_ref+          , schema_id+          , schema_fingerprint+          , causation_id+          , correlation_id+          , traceparent+          , tracestate+          , kafka_topic+          , kafka_partition+          , kafka_offset+          , payload_bytes+          , attributes+          , occurred_at+          , received_at+          , status+          , attempt_count+          , failed_at+          , last_error+          )+        VALUES+          ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22, $23, $24, $25, 'failed', 1, $25, $26)+        ON CONFLICT (source, dedupe_key) DO UPDATE+        SET status = 'failed',+            attempt_count = keiro_inbox.attempt_count + 1,+            last_error = EXCLUDED.last_error,+            failed_at = EXCLUDED.failed_at+        RETURNING attempt_count+        """+        encodedFailedInsertEncoder+        (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8))))++selectByKeyStmt :: Statement (Text, Text) (Maybe InboxRow)+selectByKeyStmt =+    preparable+        (selectAllSql <> " WHERE source = $1 AND dedupe_key = $2")+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        (D.rowMaybe inboxRowDecoder)++listBySourceStmt :: Statement Text [InboxRow]+listBySourceStmt =+    preparable+        (selectAllSql <> " WHERE source = $1 ORDER BY received_at, dedupe_key")+        (E.param (E.nonNullable E.text))+        (D.rowList inboxRowDecoder)++countInboxBacklogStmt :: Statement () Int+countInboxBacklogStmt =+    preparable+        "SELECT COUNT(*)::bigint FROM keiro.keiro_inbox WHERE status IN ('processing', 'failed')"+        E.noParams+        (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8))))++gcStmt :: Statement UTCTime Int64+gcStmt =+    preparable+        """+        WITH deleted AS (+          DELETE FROM keiro.keiro_inbox+          WHERE status = 'completed' AND completed_at < $1+          RETURNING 1+        )+        SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted+        """+        (E.param (E.nonNullable E.timestamptz))+        (D.singleRow (D.column (D.nonNullable D.int8)))++selectAllSql :: Text+selectAllSql =+    """+    SELECT source, dedupe_key, message_id, source_event_id, source_global_position,+           destination, event_type, schema_version, content_type, schema_registry,+           schema_subject, schema_version_ref, schema_id, schema_fingerprint,+           causation_id, correlation_id, traceparent, tracestate, kafka_topic,+           kafka_partition, kafka_offset, payload_bytes, attributes, occurred_at,+           status, attempt_count, received_at, completed_at, failed_at, last_error+    FROM keiro.keiro_inbox+    """++inboxRowDecoder :: D.Row InboxRow+inboxRowDecoder = fmap assembleInboxRow rawDecoder++data RawInbox = RawInbox+    { source :: !Text+    , dedupeKey :: !Text+    , messageId :: !(Maybe Text)+    , sourceEventId :: !(Maybe EventId)+    , sourceGlobalPosition :: !(Maybe GlobalPosition)+    , destination :: !(Maybe Text)+    , eventType :: !(Maybe Text)+    , schemaVersion :: !(Maybe Int)+    , contentType :: !Text+    , schemaRegistry :: !(Maybe Text)+    , schemaSubject :: !(Maybe Text)+    , schemaVersionRef :: !(Maybe Int)+    , schemaId :: !(Maybe Int64)+    , schemaFingerprint :: !(Maybe Text)+    , causationId :: !(Maybe EventId)+    , correlationId :: !(Maybe EventId)+    , traceparent :: !(Maybe Text)+    , tracestate :: !(Maybe Text)+    , kafkaTopic :: !(Maybe Text)+    , kafkaPartition :: !(Maybe Int64)+    , kafkaOffset :: !(Maybe Int64)+    , payloadBytes :: !ByteString+    , attributes :: !(Maybe Value)+    , occurredAt :: !(Maybe UTCTime)+    , status :: !InboxStatus+    , attemptCount :: !Int+    , receivedAt :: !UTCTime+    , completedAt :: !(Maybe UTCTime)+    , failedAt :: !(Maybe UTCTime)+    , lastError :: !(Maybe Text)+    }+    deriving stock (Generic)++rawDecoder :: D.Row RawInbox+rawDecoder =+    RawInbox+        <$> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nullable D.text)+        <*> (fmap EventId <$> D.column (D.nullable D.uuid))+        <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8))+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nullable D.text)+        <*> (fmap fromIntegral <$> D.column (D.nullable D.int8))+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nullable D.text)+        <*> (fmap fromIntegral <$> D.column (D.nullable D.int8))+        <*> D.column (D.nullable D.int8)+        <*> D.column (D.nullable D.text)+        <*> (fmap EventId <$> D.column (D.nullable D.uuid))+        <*> (fmap EventId <$> D.column (D.nullable D.uuid))+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nullable D.int8)+        <*> D.column (D.nullable D.int8)+        <*> D.column (D.nonNullable D.bytea)+        <*> D.column (D.nullable D.jsonb)+        <*> D.column (D.nullable D.timestamptz)+        <*> D.column (D.nonNullable (D.refine parseInboxStatus D.text))+        <*> (fromIntegral <$> D.column (D.nonNullable D.int8))+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nullable D.timestamptz)+        <*> D.column (D.nullable D.timestamptz)+        <*> D.column (D.nullable D.text)++assembleInboxRow :: RawInbox -> InboxRow+assembleInboxRow raw =+    let traceContext = case raw ^. #traceparent of+            Nothing -> Nothing+            Just tp -> Just (TraceContext tp (raw ^. #tracestate))+        schemaReference =+            case ( raw ^. #schemaRegistry+                 , raw ^. #schemaSubject+                 , raw ^. #schemaVersionRef+                 , raw ^. #schemaId+                 , raw ^. #schemaFingerprint+                 ) of+                (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing+                _ ->+                    Just+                        ( SchemaReference+                            (raw ^. #schemaRegistry)+                            (raw ^. #schemaSubject)+                            (raw ^. #schemaVersionRef)+                            (raw ^. #schemaId)+                            (raw ^. #schemaFingerprint)+                        )+        kafka =+            case (raw ^. #kafkaTopic, raw ^. #kafkaPartition, raw ^. #kafkaOffset) of+                (Just t, Just p, Just o) -> Just (KafkaDeliveryRef t p o)+                _ -> Nothing+        event =+            IntegrationEvent+                { messageId = fromMaybe mempty (raw ^. #messageId)+                , source = raw ^. #source+                , destination = fromMaybe mempty (raw ^. #destination)+                , key = Nothing+                , -- @key@ is not part of the inbox primary key and is not+                  -- carried separately on the row — the same partition info+                  -- lives in @kafka@. Receivers that need it can re-derive+                  -- from the payload.+                  eventType = fromMaybe mempty (raw ^. #eventType)+                , schemaVersion = fromMaybe 0 (raw ^. #schemaVersion)+                , contentType = parseContentType (raw ^. #contentType)+                , schemaReference+                , sourceEventId = raw ^. #sourceEventId+                , sourceGlobalPosition = raw ^. #sourceGlobalPosition+                , payloadBytes = raw ^. #payloadBytes+                , occurredAt = fromMaybe defaultEpoch (raw ^. #occurredAt)+                , causationId = raw ^. #causationId+                , correlationId = raw ^. #correlationId+                , traceContext+                , attributes = raw ^. #attributes+                }+     in InboxRow+            { source = raw ^. #source+            , dedupeKey = raw ^. #dedupeKey+            , event+            , kafka+            , status = raw ^. #status+            , attemptCount = raw ^. #attemptCount+            , receivedAt = raw ^. #receivedAt+            , completedAt = raw ^. #completedAt+            , failedAt = raw ^. #failedAt+            , lastError = raw ^. #lastError+            }++{- | Sentinel used when an inbox row was written without an @occurred_at@.++Inbox rows are observability-shaped; consumers that care should+re-read the timestamp from the envelope payload directly.+-}+defaultEpoch :: UTCTime+defaultEpoch = posixSecondsToUTCTime 0
+ src/Keiro/Inbox/Types.hs view
@@ -0,0 +1,198 @@+{- | Shared types for the idempotent integration-event inbox.++The inbox lives in the consuming bounded context. When a Kafka consumer+receives an integration event, the inbox records a stable external+identity for that message and runs the local handler in the same+transaction. Duplicate redeliveries (Kafka offset retry, rebalance,+producer republish) become observable as duplicates instead of+re-running the handler.+-}+module Keiro.Inbox.Types (+    InboxDedupePolicy (..),+    InboxPersistence (..),+    InboxStatus (..),+    InboxResult (..),+    InboxError (..),+    InboxRow (..),+    KafkaDeliveryRef (..),+    inboxStatusText,+    parseInboxStatus,+    dedupeKeyFor,+)+where++import Data.Text qualified as Text+import Data.UUID qualified as UUID+import Keiro.Integration.Event (IntegrationEvent)+import Keiro.Prelude+import Kiroku.Store.Types (EventId (..), GlobalPosition (..))++{- | Which identity is used as the inbox primary key for an+'IntegrationEvent'.++* 'PreferIntegrationMessageId' (default) — use the application-level+  @messageId@ minted at the producer's outbox enqueue. EP-19 / EP-20+  keep this id stable across publish retries, so it is the natural+  primary dedupe key for Kafka-delivered events.+* 'PreferSourceEventIdentity' — use the @sourceEventId@ of the private+  event that produced this integration event. Useful when a producer+  may emit the same logical fact under different @messageId@s (e.g.+  schema-upgrade republish), and the consumer wants those republishes+  collapsed to a single handler run.+* 'KafkaDeliveryIdentity' — use the Kafka topic-partition-offset triple+  as the dedupe key. Fallback only when neither @messageId@ nor source+  identity is available. This identifies one broker delivery, not one+  logical producer message: if a producer republishes the same logical+  message, Kafka assigns a new offset and this policy will not collapse+  the republish.+* 'CustomDedupeKey' — caller supplies the key. Use only when the other+  policies cannot represent the identity scheme; the consuming service+  owns key collision resistance.+-}+data InboxDedupePolicy+    = PreferIntegrationMessageId+    | PreferSourceEventIdentity+    | KafkaDeliveryIdentity+    | CustomDedupeKey !Text+    deriving stock (Generic, Eq, Show)++{- | How much of the integration-event envelope the inbox persists on the+success path.++The failure path always persists the full envelope because a failed+inbox row is the operator's dead-letter record.+-}+data InboxPersistence+    = PersistFullEnvelope+    | PersistDedupeOnly+    deriving stock (Generic, Eq, Show)++{- | Lifecycle state of an inbox row.++* 'InboxProcessing' — legacy on-disk state from older wrappers and+  reserved for future async paths. Current single-transaction intake+  inserts fresh successful rows directly as 'InboxCompleted'.+* 'InboxCompleted' — handler ran to completion; terminal.+* 'InboxFailed' — handler signaled a permanent failure; terminal. The+  caller is responsible for operator action (dead-letter, manual+  retry).+-}+data InboxStatus+    = InboxProcessing+    | InboxCompleted+    | InboxFailed+    deriving stock (Generic, Eq, Show)++{- | The classified outcome of 'Keiro.Inbox.runInboxTransaction'.++* 'InboxProcessed a' — first delivery; handler ran and returned @a@.+* 'InboxDuplicate' — a previous delivery already completed; handler not+  run.+* 'InboxInProgress' — a previous attempt is currently in-flight, or a+  legacy @processing@ row was read. Current single-transaction intake+  does not commit @processing@ rows. Treat as transient.+* 'InboxPreviouslyFailed' — a previous attempt recorded a permanent+  failure. Operator should review before reprocessing.+-}+data InboxResult a+    = InboxProcessed !a+    | InboxDuplicate+    | InboxInProgress+    | InboxPreviouslyFailed !(Maybe Text)+    | InboxHandlerFailed !Text !Int+    deriving stock (Generic, Eq, Show)++{- | Errors surfaced by the inbox wrapper that originate from the inbox+itself rather than from the supplied handler.+-}+data InboxError+    = -- | The integration event lacked the field required by the chosen policy.+      DedupePolicyUnsatisfied !InboxDedupePolicy+    deriving stock (Generic, Eq, Show)++{- | Optional Kafka-delivery metadata recorded alongside an inbox row.++Used by 'KafkaDeliveryIdentity' to compute the dedupe key, and stored on+the row regardless of policy so operators can correlate the inbox+record with Kafka logs. Not part of the EP-19 envelope.+-}+data KafkaDeliveryRef = KafkaDeliveryRef+    { topic :: !Text+    , partition :: !Int64+    , offset :: !Int64+    }+    deriving stock (Generic, Eq, Show)++{- | One row read back from @keiro_inbox@.++Rows written with 'PersistDedupeOnly' decode with an empty+'IntegrationEvent' @payloadBytes@, no attributes, no trace context, and+no schema reference. Identity, routing, source-event ids, occurrence+time, and Kafka delivery metadata are still preserved.+-}+data InboxRow = InboxRow+    { source :: !Text+    , dedupeKey :: !Text+    , event :: !IntegrationEvent+    , kafka :: !(Maybe KafkaDeliveryRef)+    , status :: !InboxStatus+    , attemptCount :: !Int+    , receivedAt :: !UTCTime+    , completedAt :: !(Maybe UTCTime)+    , failedAt :: !(Maybe UTCTime)+    , lastError :: !(Maybe Text)+    }+    deriving stock (Generic, Eq, Show)++inboxStatusText :: InboxStatus -> Text+inboxStatusText = \case+    InboxProcessing -> "processing"+    InboxCompleted -> "completed"+    InboxFailed -> "failed"++parseInboxStatus :: Text -> Either Text InboxStatus+parseInboxStatus = \case+    "processing" -> Right InboxProcessing+    "completed" -> Right InboxCompleted+    "failed" -> Right InboxFailed+    other -> Left ("unknown keiro_inbox.status: " <> other)++{- | Compute the inbox dedupe key for an integration event under the+given policy plus optional Kafka delivery context. Returns 'Left' when+the policy demands a field the envelope does not carry (for example,+'PreferSourceEventIdentity' on an envelope with no+@sourceEventId@).+-}+dedupeKeyFor ::+    InboxDedupePolicy ->+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    Either InboxError Text+dedupeKeyFor policy event kafka = case policy of+    PreferIntegrationMessageId ->+        let mid = event ^. #messageId+         in if Text.null mid+                then Left (DedupePolicyUnsatisfied policy)+                else Right mid+    PreferSourceEventIdentity ->+        case event ^. #sourceEventId of+            Just (EventId u) -> Right (UUID.toText u)+            Nothing ->+                case event ^. #sourceGlobalPosition of+                    Just (GlobalPosition p) -> Right (Text.pack (show p))+                    Nothing -> Left (DedupePolicyUnsatisfied policy)+    KafkaDeliveryIdentity ->+        case kafka of+            Just ref ->+                Right+                    ( (ref ^. #topic)+                        <> ":"+                        <> Text.pack (show (ref ^. #partition))+                        <> ":"+                        <> Text.pack (show (ref ^. #offset))+                    )+            Nothing -> Left (DedupePolicyUnsatisfied policy)+    CustomDedupeKey k ->+        if Text.null k+            then Left (DedupePolicyUnsatisfied policy)+            else Right k
+ src/Keiro/Outbox.hs view
@@ -0,0 +1,553 @@+{- | Durable integration-event outbox.++The outbox decouples "this service has decided to publish an integration+event" from "this service has actually published it". Two surfaces use+it:++* The canonical 'IntegrationProducer' helper maps durable private events+  to public 'Keiro.Integration.Event.IntegrationEvent' values and enqueues+  one outbox row per mapped event. It mints @messageId@ as a prefixed+  UUIDv7 (TypeID) so the id is time-ordered, human-readable, and stable+  across publish retries.+* 'enqueueOutboxTx' is the inline escape hatch for sagas and process+  managers that need to emit an integration event without an intermediate+  private domain event. It runs inside the caller's+  'Hasql.Transaction.Transaction'.++The 'publishClaimedOutbox' worker is transport-neutral. It claims rows+with @FOR UPDATE SKIP LOCKED@ plus the configured 'OrderingPolicy',+hands claimed batches to a caller-supplied publish function, and marks rows+sent, retryable, or dead. The Kafka adapter lives in+'Keiro.Outbox.Kafka'.++Run 'outboxMaintenancePass' on a separate, slower schedule to reclaim rows+left in @publishing@ by crashed workers and to sample the backlog gauge.++The per-key and per-source ordering policies sort by @created_at@, which+PostgreSQL fills at transaction start. The canonical 'IntegrationProducer'+subscription serializes same-key enqueues, so its ordering is stable. Callers+using the inline 'enqueueIntegrationEventTx' escape hatch concurrently for the+same key must serialize those enqueues themselves or accept best-effort order:+two transactions can commit in the opposite order of their @created_at@ values.+-}+module Keiro.Outbox (+    -- * Re-exports+    module Keiro.Outbox.Types,++    -- * Storage primitives (transport-neutral)+    enqueueOutboxTx,+    claimOutboxBatch,+    requeueStuckOutbox,+    markOutboxSent,+    lookupOutbox,+    listOutbox,+    countOutboxBacklog,+    garbageCollectSent,++    -- * Inline escape hatch+    freshOutboxId,+    enqueueIntegrationEventTx,++    -- * Canonical producer-subscription helper+    IntegrationProducer (..),+    IntegrationProducerConfigError (..),+    IntegrationEventDraft (..),+    mkIntegrationProducer,+    mintIntegrationEvent,+    draftToEvent,+    enqueueProducerEventTx,++    -- * Publisher worker+    PublishOutcome (..),+    publishClaimedOutbox,+    outboxMaintenancePass,+    sampleOutboxBacklog,+)+where++import Data.ByteString (ByteString)+import Data.Map.Strict qualified as Map+import Data.Text qualified as Text+import Data.TypeID qualified as TypeID+import Data.UUID.V7 qualified as V7+import Effectful (Eff, IOE, (:>))+import Effectful.Exception (displayException, trySync)+import Keiro.Integration.Event (+    IntegrationContentType,+    IntegrationEvent (..),+    SchemaReference,+    TraceContext,+ )+import Keiro.Outbox.Kafka (outboxRowToKafkaRecord)+import Keiro.Outbox.Schema+import Keiro.Outbox.Types+import Keiro.Prelude+import Keiro.Telemetry (+    KeiroMetrics,+    recordOutboxBacklog,+    recordOutboxDeadlettered,+    recordOutboxPublished,+    recordOutboxReclaimed,+    recordOutboxRetried,+    withProducerSpan,+ )+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (EventId, GlobalPosition, RecordedEvent)+import OpenTelemetry.Attributes.Key (AttributeKey (..), unkey)+import OpenTelemetry.SemanticConventions (error_type)+import OpenTelemetry.Trace.Core (SpanStatus (..), addAttribute, setStatus)+import "hasql-transaction" Hasql.Transaction qualified as Tx++keiro_outbox_batch_size :: AttributeKey Int64+keiro_outbox_batch_size = AttributeKey "keiro.outbox.batch.size"++-- | Mint a fresh time-ordered UUIDv7 for use as an 'OutboxId'.+freshOutboxId :: (IOE :> es) => Eff es OutboxId+freshOutboxId = fmap OutboxId (liftIO V7.genUUID)++{- | Enqueue an 'IntegrationEvent' from a saga or process manager that is+already running inside a 'runCommandWithSqlEvents' transaction. The+caller supplies a stable 'OutboxId' so retried command attempts coalesce+on the @(source, message_id)@ unique constraint.++Ordering caveat: under 'PerKeyHeadOfLine' and 'PerSourceStream', the publisher+orders rows by @created_at@, which PostgreSQL sets to transaction-start time.+If two concurrent transactions enqueue the same key/source and commit in the+opposite order, a publisher can observe that order. Serialize same-key enqueues+when strict order matters.+-}+enqueueIntegrationEventTx ::+    OutboxId ->+    IntegrationEvent ->+    Tx.Transaction ()+enqueueIntegrationEventTx outboxId event =+    enqueueOutboxTx (OutboxMessage{outboxId, event})++-- ---------------------------------------------------------------------------+-- Producer-subscription helper+-- ---------------------------------------------------------------------------++{- | Configuration for the canonical producer subscription.++A service running 'IntegrationProducer' reads its private event stream,+decodes each event with a 'Keiro.Codec.Codec', calls 'mapEvent', and for+each 'Just' result writes one 'keiro_outbox' row. The helper mints+@messageId@ on each insert so the id is stable across publish retries.++* 'name' — subscription name used to checkpoint the producer's cursor+  in the @subscriptions@ table.+* 'source' — value written into @keiro_outbox.source@; identifies the+  producing bounded context.+* 'messageIdPrefix' — TypeID prefix used when minting @messageId@.+  Must be 1-63 lowercase Latin letters (e.g. @\"msg\"@, @\"order\"@).+  Prefer constructing producers with 'mkIntegrationProducer'; an invalid+  prefix passed directly to 'IntegrationProducer' raises when the first+  message id is minted.+* 'mapEvent' — pure mapper from a private 'RecordedEvent' and its+  decoded payload to an 'IntegrationEventDraft'. Returning 'Nothing'+  skips the event without enqueuing a row.+-}+data IntegrationProducer e = IntegrationProducer+    { name :: !Text+    , source :: !Text+    , messageIdPrefix :: !Text+    , mapEvent :: !(RecordedEvent -> e -> Maybe IntegrationEventDraft)+    }+    deriving stock (Generic)++data IntegrationProducerConfigError+    = InvalidMessageIdPrefix !Text !Text+    deriving stock (Generic, Eq, Show)++-- | Validate an integration producer before starting its subscription.+mkIntegrationProducer :: IntegrationProducer e -> Either IntegrationProducerConfigError (IntegrationProducer e)+mkIntegrationProducer producer =+    case TypeID.checkPrefix (producer ^. #messageIdPrefix) of+        Nothing -> Right producer+        Just err ->+            Left+                ( InvalidMessageIdPrefix+                    (producer ^. #messageIdPrefix)+                    (Text.pack (show err))+                )++{- | Everything in 'IntegrationEvent' except 'messageId' and 'source' —+those are filled in by 'mintIntegrationEvent' from the producer+configuration and the freshly minted TypeID.++@sourceEventId@ and @sourceGlobalPosition@ default to the values on the+underlying 'RecordedEvent' (see 'mintIntegrationEvent'); a mapper that+needs to override them can replace the draft fields directly.+-}+data IntegrationEventDraft = IntegrationEventDraft+    { destination :: !Text+    , key :: !(Maybe Text)+    , eventType :: !Text+    , schemaVersion :: !Int+    , contentType :: !IntegrationContentType+    , schemaReference :: !(Maybe SchemaReference)+    , sourceEventId :: !(Maybe EventId)+    , sourceGlobalPosition :: !(Maybe GlobalPosition)+    , payloadBytes :: !ByteString+    , occurredAt :: !UTCTime+    , causationId :: !(Maybe EventId)+    , correlationId :: !(Maybe EventId)+    , traceContext :: !(Maybe TraceContext)+    , attributes :: !(Maybe Value)+    }+    deriving stock (Generic, Eq, Show)++{- | Mint a fresh @messageId@ (TypeID with the producer's prefix) and build+the full 'IntegrationEvent' from the draft. Lives in 'IO' because TypeID+generation reads the global UUIDv7 sequence counter.+-}+mintIntegrationEvent ::+    (IOE :> es) =>+    IntegrationProducer e ->+    IntegrationEventDraft ->+    Eff es IntegrationEvent+mintIntegrationEvent producer draft = do+    typeId <- liftIO (TypeID.genTypeID (producer ^. #messageIdPrefix))+    pure (draftToEvent (producer ^. #source) (TypeID.toText typeId) draft)++-- | Build an 'IntegrationEvent' from a source, a minted message id, and a draft.+draftToEvent :: Text -> Text -> IntegrationEventDraft -> IntegrationEvent+draftToEvent source minted draft =+    IntegrationEvent+        { messageId = minted+        , source+        , destination = draft ^. #destination+        , key = draft ^. #key+        , eventType = draft ^. #eventType+        , schemaVersion = draft ^. #schemaVersion+        , contentType = draft ^. #contentType+        , schemaReference = draft ^. #schemaReference+        , sourceEventId = draft ^. #sourceEventId+        , sourceGlobalPosition = draft ^. #sourceGlobalPosition+        , payloadBytes = draft ^. #payloadBytes+        , occurredAt = draft ^. #occurredAt+        , causationId = draft ^. #causationId+        , correlationId = draft ^. #correlationId+        , traceContext = draft ^. #traceContext+        , attributes = draft ^. #attributes+        }++{- | Enqueue one drafted producer event inside an existing transaction.++This is the primitive a subscription worker calls per event. It mints a+fresh @messageId@ (TypeID), constructs the full envelope, and inserts+the row. The caller supplies the 'OutboxId' so retries from a known+subscription cursor coalesce on @(source, message_id)@.++The TypeID is minted before the insert; if the transaction rolls back+the message id is discarded (no observable effect) and the next attempt+mints a different id. Idempotency at the row level relies on a stable+'OutboxId', not the minted message id.++Ordering caveat: @created_at@ records transaction-start time. Under+'PerKeyHeadOfLine' or 'PerSourceStream', concurrent transactions for the same+key/source can commit in the opposite order and are therefore best-effort+unless the caller serializes them. The canonical producer subscription does+serialize same-key enqueues.+-}+enqueueProducerEventTx ::+    forall e es.+    (IOE :> es) =>+    IntegrationProducer e ->+    OutboxId ->+    IntegrationEventDraft ->+    Eff es (Tx.Transaction ())+enqueueProducerEventTx producer outboxId draft = do+    event <- mintIntegrationEvent producer draft+    pure (enqueueOutboxTx (OutboxMessage{outboxId, event}))++-- ---------------------------------------------------------------------------+-- Publisher worker+-- ---------------------------------------------------------------------------++-- | Result of one publish attempt as reported by the transport-specific publisher.+data PublishOutcome+    = -- | Kafka acknowledged the publish.+      PublishSucceeded+    | -- | Publish failed; will be retried after the configured backoff.+      PublishFailed !Text+    deriving stock (Generic, Eq, Show)++{- | Drain claimed outbox rows by handing the claimed batch to @publish@ and+reflecting the outcomes back into row statuses.++Claims rows in batches of @batchSize@ under the active 'OrderingPolicy',+calls @publish@ with the claimed rows in claim order, and marks every row+sent or — using 'markOutboxFailedTx' — failed/dead. The publish result must+contain one outcome per input row; a missing outcome is treated as+@PublishFailed "publisher returned no outcome"@. If the publisher throws,+every row in that call is treated as failed with the exception text.++For ordered policies, if a row fails then later rows in the same ordered group+are skipped and returned to @failed@ without consuming an attempt; these+skipped rows count as 'OutboxPublishSummary.retried'. A real Kafka transport+must not successfully deliver a later same-key record after reporting an+earlier same-key failure from the same call. On 'StopTheLine', the worker calls+@publish@ with singleton batches and halts after the first failed row, recording+the offending 'OutboxId' in 'haltedOn'.++Returns when one of:++* No rows are claimable.+* The active policy is 'StopTheLine' and a publish failed.++The worker does not loop indefinitely; the application is expected to+schedule it repeatedly (e.g. once per process-compose tick).+-}+publishClaimedOutbox ::+    forall es.+    (IOE :> es, Store :> es) =>+    ([OutboxRow] -> Eff es [(OutboxId, PublishOutcome)]) ->+    OutboxPublishOptions ->+    Maybe KeiroMetrics ->+    Eff es OutboxPublishSummary+publishClaimedOutbox publish options mMetrics = do+    now <- liftIO getCurrentTime+    rows <- claimOutboxBatch (options ^. #orderingPolicy) (options ^. #batchSize) now+    summary <- publishBatch rows+    -- Counters from the aggregated pass summary (each a no-op under 'Nothing';+    -- a zero delta is harmless).+    recordOutboxPublished mMetrics (fromIntegral (summary ^. #published))+    recordOutboxRetried mMetrics (fromIntegral (summary ^. #retried))+    recordOutboxDeadlettered mMetrics (fromIntegral (summary ^. #dead))+    pure summary+  where+    publishBatch :: [OutboxRow] -> Eff es OutboxPublishSummary+    publishBatch [] =+        pure OutboxPublishSummary{claimed = 0, published = 0, retried = 0, dead = 0, haltedOn = Nothing}+    publishBatch batch =+        case options ^. #orderingPolicy of+            StopTheLine -> publishStopTheLine batch batch [] Nothing+            policy -> do+                outcomes <- publishRows batch+                markProcessedOutcomes policy batch outcomes Nothing++    publishStopTheLine ::+        [OutboxRow] ->+        [OutboxRow] ->+        [(OutboxId, PublishOutcome)] ->+        Maybe OutboxId ->+        Eff es OutboxPublishSummary+    publishStopTheLine original [] outcomes halted =+        markProcessedOutcomes StopTheLine original (Map.fromList outcomes) halted+    publishStopTheLine original (row : rest) outcomes _ = do+        result <- publishRows [row]+        let outcome = outcomeFor result row+            outcomes' = outcomes <> [(row ^. #outboxId, outcome)]+        case outcome of+            PublishSucceeded -> publishStopTheLine original rest outcomes' Nothing+            PublishFailed _ -> markProcessedOutcomes StopTheLine original (Map.fromList outcomes') (Just (row ^. #outboxId))++    publishRows :: [OutboxRow] -> Eff es (Map.Map OutboxId PublishOutcome)+    publishRows [] = pure Map.empty+    publishRows batch@(firstRow : _) =+        Map.fromList+            <$> withBatchSpan+                batch+                firstRow+                ( do+                    attempted <- trySync (publish batch)+                    let normalized =+                            case attempted of+                                Left err ->+                                    let errMsg = Text.pack (displayException err)+                                     in [(row ^. #outboxId, PublishFailed errMsg) | row <- batch]+                                Right reported ->+                                    normalizeOutcomes batch reported+                    pure normalized+                )++    withBatchSpan ::+        [OutboxRow] ->+        OutboxRow ->+        Eff es [(OutboxId, PublishOutcome)] ->+        Eff es [(OutboxId, PublishOutcome)]+    withBatchSpan batch firstRow action =+        withProducerSpan+            (options ^. #tracer)+            (firstRow ^. #event)+            (outboxRowToKafkaRecord firstRow)+            $ \mSpan -> do+                for_ mSpan $ \sp ->+                    addAttribute sp (unkey keiro_outbox_batch_size) (fromIntegral (length batch) :: Int64)+                outcomes <- action+                case (mSpan, firstFailure outcomes) of+                    (Just sp, Just errMsg) -> do+                        addAttribute sp (unkey error_type) ("publish_failed" :: Text)+                        setStatus sp (Error errMsg)+                    _ -> pure ()+                pure outcomes++    normalizeOutcomes :: [OutboxRow] -> [(OutboxId, PublishOutcome)] -> [(OutboxId, PublishOutcome)]+    normalizeOutcomes batch reported =+        let reportedMap = Map.fromList reported+         in [ (row ^. #outboxId, outcomeFor reportedMap row)+            | row <- batch+            ]++    outcomeFor :: Map.Map OutboxId PublishOutcome -> OutboxRow -> PublishOutcome+    outcomeFor outcomes row =+        fromMaybe (PublishFailed "publisher returned no outcome") $+            Map.lookup (row ^. #outboxId) outcomes++    firstFailure :: [(OutboxId, PublishOutcome)] -> Maybe Text+    firstFailure [] = Nothing+    firstFailure ((_, PublishSucceeded) : rest) = firstFailure rest+    firstFailure ((_, PublishFailed errMsg) : _) = Just errMsg++    markProcessedOutcomes ::+        OrderingPolicy ->+        [OutboxRow] ->+        Map.Map OutboxId PublishOutcome ->+        Maybe OutboxId ->+        Eff es OutboxPublishSummary+    markProcessedOutcomes policy batch outcomes halted = do+        now <- liftIO getCurrentTime+        let marks = foldMap (groupMarks outcomes) (outcomeGroups policy batch)+            sentIds = marks ^. #sentIds+            failedRows = marks ^. #failedRows+            skippedRows = marks ^. #skippedRows+        failedStatuses <-+            if null failedRows && null skippedRows+                then pure []+                else runTransaction $ do+                    statuses <- traverse (markFailed now) failedRows+                    traverse_ (markSkipped now) skippedRows+                    pure statuses+        _ <- markOutboxSentBatch sentIds now+        let deadCount = length [() | OutboxDead <- failedStatuses]+            retriedFailures = length failedStatuses - deadCount+        pure+            OutboxPublishSummary+                { claimed = length batch+                , published = length sentIds+                , retried = retriedFailures + length skippedRows+                , dead = deadCount+                , haltedOn = halted+                }++    markFailed :: UTCTime -> (OutboxRow, Text) -> Tx.Transaction OutboxStatus+    markFailed now (row, errMsg) =+        markOutboxFailedTx+            (row ^. #outboxId)+            errMsg+            (options ^. #maxAttempts)+            (nextDelay (options ^. #backoff) (row ^. #attemptCount))+            now++    markSkipped :: UTCTime -> OutboxRow -> Tx.Transaction ()+    markSkipped now row =+        markOutboxSkippedTx+            (row ^. #outboxId)+            "skipped: earlier record for the same key failed"+            now++{- | Reclaim crashed publisher rows and record the outbox backlog gauge.++Schedule this pass independently from 'publishClaimedOutbox', typically on a+slower timer. It is the only library worker path that reclaims rows stranded in+@publishing@.+-}+outboxMaintenancePass ::+    (IOE :> es, Store :> es) =>+    OutboxMaintenanceOptions ->+    Maybe KeiroMetrics ->+    Eff es OutboxMaintenanceSummary+outboxMaintenancePass options mMetrics = do+    now <- liftIO getCurrentTime+    (requeued, deadLettered) <-+        requeueStuckOutbox+            (options ^. #maxAttempts)+            (options ^. #publishingTimeout)+            now+    recordOutboxReclaimed mMetrics (fromIntegral requeued)+    recordOutboxDeadlettered mMetrics (fromIntegral deadLettered)+    backlog <- countOutboxBacklog+    recordOutboxBacklog mMetrics (fromIntegral backlog)+    pure OutboxMaintenanceSummary{requeued, deadLettered, backlog}++-- | Count publishable rows and record the outbox backlog gauge when metrics are enabled.+sampleOutboxBacklog :: (IOE :> es, Store :> es) => Maybe KeiroMetrics -> Eff es ()+sampleOutboxBacklog Nothing = pure ()+sampleOutboxBacklog (Just metrics) = do+    backlog <- countOutboxBacklog+    recordOutboxBacklog (Just metrics) (fromIntegral backlog)++data OutcomeMarks = OutcomeMarks+    { sentIds :: ![OutboxId]+    , failedRows :: ![(OutboxRow, Text)]+    , skippedRows :: ![OutboxRow]+    }+    deriving stock (Generic)++instance Semigroup OutcomeMarks where+    left <> right =+        OutcomeMarks+            { sentIds = (left ^. #sentIds) <> (right ^. #sentIds)+            , failedRows = (left ^. #failedRows) <> (right ^. #failedRows)+            , skippedRows = (left ^. #skippedRows) <> (right ^. #skippedRows)+            }++instance Monoid OutcomeMarks where+    mempty = OutcomeMarks{sentIds = [], failedRows = [], skippedRows = []}++groupMarks :: Map.Map OutboxId PublishOutcome -> [OutboxRow] -> OutcomeMarks+groupMarks outcomes = go []+  where+    go sent [] = mempty{sentIds = sent}+    go sent (row : rest) =+        case fromMaybe (PublishFailed "publisher returned no outcome") (Map.lookup (row ^. #outboxId) outcomes) of+            PublishSucceeded -> go (sent <> [row ^. #outboxId]) rest+            PublishFailed errMsg ->+                OutcomeMarks+                    { sentIds = sent+                    , failedRows = [(row, errMsg)]+                    , skippedRows = rest+                    }++data OutcomeGroupKey+    = BatchGroup+    | SourceGroup !Text+    | RowGroup !OutboxId+    | KeyGroup !Text !Text+    deriving stock (Generic, Eq)++data OutcomeGroup = OutcomeGroup+    { groupKey :: !OutcomeGroupKey+    , groupRows :: ![OutboxRow]+    }+    deriving stock (Generic)++outcomeGroups :: OrderingPolicy -> [OutboxRow] -> [[OutboxRow]]+outcomeGroups policy =+    fmap (^. #groupRows) . foldl' addGroup []+  where+    addGroup groups row =+        appendGroup (keyFor row) row groups+    keyFor row =+        case policy of+            -- A claimed batch can hold runs from several independent sources;+            -- a failure in one source's run must not skip another source's rows.+            PerSourceStream -> SourceGroup (row ^. #event . #source)+            -- Deliberately one group: any failure halts the worker, and the+            -- entire remaining batch is skipped without consuming attempts.+            StopTheLine -> BatchGroup+            BestEffort -> RowGroup (row ^. #outboxId)+            _ ->+                case row ^. #event . #key of+                    Nothing -> RowGroup (row ^. #outboxId)+                    Just key -> KeyGroup (row ^. #event . #source) key++appendGroup :: OutcomeGroupKey -> OutboxRow -> [OutcomeGroup] -> [OutcomeGroup]+appendGroup key row [] = [OutcomeGroup{groupKey = key, groupRows = [row]}]+appendGroup key row (group : rest)+    | group ^. #groupKey == key =+        (group & #groupRows %~ (<> [row])) : rest+    | otherwise =+        group : appendGroup key row rest
+ src/Keiro/Outbox/Kafka.hs view
@@ -0,0 +1,70 @@+{- | Transport-neutral Kafka representation for outbox rows.++This module owns the conversion from 'Keiro.Outbox.Types.OutboxRow' to a+neutral 'KafkaProducerRecord' value. It deliberately does not import+@hw-kafka-client@ or @kafka-effectful@: keiro itself remains free of+librdkafka system-library requirements. The integration test package+(EP-22) bridges 'KafkaProducerRecord' to+@Kafka.Producer.Types.ProducerRecord@ from @hw-kafka-client@ inside its+own dependency scope.++A 'KafkaProducerRecord' carries everything the broker layer needs:+topic, optional partition key, the raw payload bytes from the EP-19+envelope, and the canonical header set. Building the record is pure;+publishing is the caller's responsibility.++The outbox worker opens one producer span around each claimed publish batch.+Adapters that need per-record broker visibility should add their own spans+around the actual Kafka produce calls.+-}+module Keiro.Outbox.Kafka (+    KafkaProducerRecord (..),+    outboxRowToKafkaRecord,+    integrationEventToKafkaRecord,+)+where++import Data.ByteString (ByteString)+import Data.Text.Encoding qualified as TE+import Keiro.Integration.Event (IntegrationEvent, integrationHeaders, integrationPayload)+import Keiro.Outbox.Types (OutboxRow (..))+import Keiro.Prelude++{- | A neutral Kafka producer record.++Fields:++* 'topic' — Kafka topic, taken from 'IntegrationEvent.destination'.+* 'key' — partition key bytes (UTF-8 encoded). 'Nothing' means+  Kafka round-robins the record across partitions and skips per-key+  ordering.+* 'payload' — exactly the bytes from+  'Keiro.Integration.Event.integrationPayload'.+* 'headers' — UTF-8 encoded view of+  'Keiro.Integration.Event.integrationHeaders'.++The byte encoding for keys and headers is UTF-8 by convention; Kafka+treats both as opaque bytes, so a future binary-key transport can drop+the encoding by populating 'key' directly.+-}+data KafkaProducerRecord = KafkaProducerRecord+    { topic :: !Text+    , key :: !(Maybe ByteString)+    , payload :: !ByteString+    , headers :: ![(ByteString, ByteString)]+    }+    deriving stock (Generic, Eq, Show)++-- | Build a 'KafkaProducerRecord' from a published outbox row.+outboxRowToKafkaRecord :: OutboxRow -> KafkaProducerRecord+outboxRowToKafkaRecord row = integrationEventToKafkaRecord (row ^. #event)++-- | Build a 'KafkaProducerRecord' directly from an 'IntegrationEvent'.+integrationEventToKafkaRecord :: IntegrationEvent -> KafkaProducerRecord+integrationEventToKafkaRecord event =+    KafkaProducerRecord+        { topic = event ^. #destination+        , key = fmap TE.encodeUtf8 (event ^. #key)+        , payload = integrationPayload event+        , headers = [(TE.encodeUtf8 n, TE.encodeUtf8 v) | (n, v) <- integrationHeaders event]+        }
+ src/Keiro/Outbox/Schema.hs view
@@ -0,0 +1,811 @@+{-# LANGUAGE ApplicativeDo #-}++{- | Hasql-level storage for the durable integration-event outbox.++This module owns the SQL surface that publishers call into. Higher-level+helpers ('Keiro.Outbox') and transport adapters+('Keiro.Outbox.Kafka') consume these primitives.+-}+module Keiro.Outbox.Schema (+    enqueueOutboxTx,+    claimOutboxBatch,+    requeueStuckOutbox,+    markOutboxSent,+    markOutboxSentBatch,+    markOutboxFailedTx,+    markOutboxSkippedTx,+    lookupOutbox,+    listOutbox,+    countOutboxBacklog,+    garbageCollectSent,+)+where++import Contravariant.Extras (contrazip2, contrazip3, contrazip5)+import Data.ByteString (ByteString)+import Data.Functor.Contravariant ((>$<))+import Data.Time.Clock (NominalDiffTime, addUTCTime)+import Data.UUID (UUID)+import Effectful (Eff, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Integration.Event (+    IntegrationEvent (..),+    SchemaReference (..),+    TraceContext (..),+    contentTypeText,+    parseContentType,+ )+import Keiro.Outbox.Types+import Keiro.Prelude+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (EventId (..), GlobalPosition (..))+import "hasql-transaction" Hasql.Transaction qualified as Tx++{- | Enqueue one integration event inside an existing transaction.++The @(source, message_id)@ unique constraint catches duplicate retries+from a saga/process-manager. Callers that mint a fresh @messageId@ per+attempt should also mint a fresh @outboxId@; callers that want+idempotent retries should reuse both.++The row's @created_at@ value is the PostgreSQL transaction-start time. The+per-key and per-source publisher policies therefore provide only best-effort+ordering when concurrent transactions enqueue the same key/source and commit+in the opposite order. Serialize those transactions when strict order matters;+the canonical producer subscription already does so.+-}+enqueueOutboxTx :: OutboxMessage -> Tx.Transaction ()+enqueueOutboxTx message =+    Tx.statement (toEncodedRow message) enqueueOutboxStmt++-- | Read a single outbox row by id. Used by tests and inspection tooling.+lookupOutbox :: (Store :> es) => OutboxId -> Eff es (Maybe OutboxRow)+lookupOutbox outboxId =+    runTransaction $+        Tx.statement (unOutboxId outboxId) lookupOutboxStmt++{- | List outbox rows for a source, ordered by @created_at@. Used by tests;+not intended for application traffic.+-}+listOutbox :: (Store :> es) => Text -> Eff es [OutboxRow]+listOutbox source =+    runTransaction $+        Tx.statement source listOutboxStmt++{- | Count outbox rows awaiting publish (backlog gauge source).++Backlog = rows in a claimable, non-terminal state. Mirrors the claim+query's @status IN ('pending','failed')@ predicate so the gauge measures+exactly the rows a publisher still has to drain (rows held mid-pass in+@publishing@, and the terminal @sent@/@dead@ rows, are excluded).+-}+countOutboxBacklog :: (Store :> es) => Eff es Int+countOutboxBacklog =+    runTransaction (Tx.statement () countBacklogStmt)++{- | Delete @sent@ rows whose @published_at@ is older than @keepFor@ before+@now@.++Returns the number of rows deleted. @dead@ rows are never deleted: they are+operator action items proving an event was not published. The retention window+only bounds how long successful publish history remains queryable; consumer+dedupe lives in the inbox, not here.+-}+garbageCollectSent ::+    (Store :> es) =>+    NominalDiffTime ->+    UTCTime ->+    Eff es Int+garbageCollectSent keepFor now = do+    let cutoff = addUTCTime (negate keepFor) now+    result <-+        runTransaction $+            Tx.statement cutoff gcSentStmt+    pure (fromIntegral result)++{- | Claim up to @limit@ rows ready for publish.++Rows in @pending@ or @failed@ status whose @next_attempt_at@ has passed+become candidates. The selection is filtered by 'OrderingPolicy':++* 'PerKeyHeadOfLine' — a row is claimed only if every earlier+  non-terminal row with the same @(source, message_key)@ is also claimed+  by the same statement. Rows with @message_key IS NULL@ bypass the+  per-key check.+* 'PerSourceStream' — a row is claimed only if every earlier+  non-terminal row in the same @source@ is also claimed by the same+  statement, regardless of key.+* 'StopTheLine' — same as 'PerKeyHeadOfLine' at claim time; the worker+  halts on the first failure (decided at the worker level).+* 'BestEffort' — no head-of-line predicate.++The returned list preserves @(created_at, outbox_id)@ order. Per-key and+per-source subsequences are therefore gapless ordered runs. The @LIMIT@+applies to the locked candidate set before the post-filter; under+concurrent claimers or a limit cut through the middle of a run, a pass+can return fewer than @limit@ rows even when more rows are ready.++Claimed rows are transitioned to @publishing@ and have their+@attempt_count@ incremented atomically.+-}+claimOutboxBatch ::+    (Store :> es) =>+    OrderingPolicy ->+    Int ->+    UTCTime ->+    Eff es [OutboxRow]+claimOutboxBatch policy limit now =+    runTransaction $+        Tx.statement (fromIntegral limit, now) (claimStmt policy)++{- | Reclaim rows stranded in @publishing@ longer than @olderThan@.++Rows whose claim already consumed the attempt budget are dead-lettered; the+rest return to @failed@ so the regular claim query can retry them. Returns+@(requeued, deadLettered)@.+-}+requeueStuckOutbox ::+    (Store :> es) =>+    Int ->+    NominalDiffTime ->+    UTCTime ->+    Eff es (Int, Int)+requeueStuckOutbox maxAttempts olderThan now =+    runTransaction $ do+        let cutoff = addUTCTime (negate olderThan) now+        dead <- Tx.statement (cutoff, fromIntegral maxAttempts, now) deadLetterStuckStmt+        requeued <- Tx.statement (cutoff, fromIntegral maxAttempts, now) requeueStuckStmt+        pure (fromIntegral requeued, fromIntegral dead)++{- | Mark a row as successfully published. Sets @published_at@ and clears+@last_error@. Returns 'False' if the row left @publishing@ before the mark,+for example because a stale-row sweeper or operator changed it while the+transport publish was in flight. The publish may still have happened; callers+must treat this as at-least-once delivery.+-}+markOutboxSent :: (Store :> es) => OutboxId -> UTCTime -> Eff es Bool+markOutboxSent outboxId now =+    runTransaction $+        Tx.statement (unOutboxId outboxId, now) markSentStmt++{- | Mark many rows as successfully published in one statement.++Only rows still in @publishing@ transition. Returns how many rows changed;+callers treat a shortfall as benign because delivery is already at-least-once.+-}+markOutboxSentBatch :: (Store :> es) => [OutboxId] -> UTCTime -> Eff es Int+markOutboxSentBatch [] _ = pure 0+markOutboxSentBatch outboxIds now =+    fromIntegral+        <$> runTransaction+            ( Tx.statement+                (fmap unOutboxId outboxIds, now)+                markSentBatchStmt+            )++{- | Mark a row as failed and decide whether it is retryable or dead.++Reads the current @attempt_count@; if it is greater than or equal to+@maxAttempts@, transitions to 'OutboxDead'. Otherwise transitions to+'OutboxFailed' and sets @next_attempt_at = now + delay@. Returns the+resulting status so the worker can update its summary counters.++Runs inside the caller's transaction to keep "read attempt count → write+status" atomic with respect to other workers.++Only rows still in @publishing@ are updated (matching 'markSentBatchStmt'+and 'markSkippedStmt'): if the row outlived 'publishingTimeout' and+'outboxMaintenancePass' already requeued it — possibly handing it to+another worker — a late failure mark from the original worker must not+flip the re-claimed row mid-publish.+-}+markOutboxFailedTx ::+    OutboxId ->+    Text ->+    Int ->+    NominalDiffTime ->+    UTCTime ->+    Tx.Transaction OutboxStatus+markOutboxFailedTx outboxId errMsg maxAttempts delay now = do+    currentAttempt <- Tx.statement (unOutboxId outboxId) readAttemptCountStmt+    let attempt = fromMaybe 0 currentAttempt+        shouldDie = attempt >= maxAttempts+        nextStatus = if shouldDie then OutboxDead else OutboxFailed+        nextAttempt = addUTCTime delay now+    Tx.statement+        (unOutboxId outboxId, statusText nextStatus, errMsg, nextAttempt, now)+        markFailedStmt+    pure nextStatus++{- | Return a claimed row to @failed@ without consuming an attempt.++Used for rows skipped because an earlier row in the same ordered group failed+inside the same publish batch.+-}+markOutboxSkippedTx :: OutboxId -> Text -> UTCTime -> Tx.Transaction ()+markOutboxSkippedTx outboxId errMsg now =+    Tx.statement (unOutboxId outboxId, errMsg, now) markSkippedStmt++-- ---------------------------------------------------------------------------+-- Encoder support+-- ---------------------------------------------------------------------------++{- | Flattened row used as the encoder input. Field order is locked to+the INSERT statement; the encoder threads each field through a separate+'E.Params' fragment joined by 'mconcat'.+-}+data EncodedRow = EncodedRow+    { outboxId :: !UUID+    , messageId :: !Text+    , source :: !Text+    , destination :: !Text+    , messageKey :: !(Maybe Text)+    , eventType :: !Text+    , schemaVersion :: !Int64+    , contentType :: !Text+    , schemaRegistry :: !(Maybe Text)+    , schemaSubject :: !(Maybe Text)+    , schemaVersionRef :: !(Maybe Int64)+    , schemaId :: !(Maybe Int64)+    , schemaFingerprint :: !(Maybe Text)+    , sourceEventId :: !(Maybe UUID)+    , sourceGlobalPosition :: !(Maybe Int64)+    , causationId :: !(Maybe UUID)+    , correlationId :: !(Maybe UUID)+    , traceparent :: !(Maybe Text)+    , tracestate :: !(Maybe Text)+    , payloadBytes :: !ByteString+    , attributes :: !(Maybe Value)+    , occurredAt :: !UTCTime+    }+    deriving stock (Generic)++toEncodedRow :: OutboxMessage -> EncodedRow+toEncodedRow message =+    let event = message ^. #event+        mref = event ^. #schemaReference+        mtrace = event ^. #traceContext+     in EncodedRow+            { outboxId = unOutboxId (message ^. #outboxId)+            , messageId = event ^. #messageId+            , source = event ^. #source+            , destination = event ^. #destination+            , messageKey = event ^. #key+            , eventType = event ^. #eventType+            , schemaVersion = fromIntegral (event ^. #schemaVersion)+            , contentType = contentTypeText (event ^. #contentType)+            , schemaRegistry = mref >>= (^. #registry)+            , schemaSubject = mref >>= (^. #subject)+            , schemaVersionRef = fmap fromIntegral (mref >>= (^. #version))+            , schemaId = mref >>= (^. #schemaId)+            , schemaFingerprint = mref >>= (^. #fingerprint)+            , sourceEventId = fmap unEventId (event ^. #sourceEventId)+            , sourceGlobalPosition = fmap unGlobalPosition (event ^. #sourceGlobalPosition)+            , causationId = fmap unEventId (event ^. #causationId)+            , correlationId = fmap unEventId (event ^. #correlationId)+            , traceparent = fmap (^. #traceparent) mtrace+            , tracestate = mtrace >>= (^. #tracestate)+            , payloadBytes = event ^. #payloadBytes+            , attributes = event ^. #attributes+            , occurredAt = event ^. #occurredAt+            }++unEventId :: EventId -> UUID+unEventId (EventId u) = u++unGlobalPosition :: GlobalPosition -> Int64+unGlobalPosition (GlobalPosition i) = i++encodedRowEncoder :: E.Params EncodedRow+encodedRowEncoder =+    mconcat+        [ view #outboxId >$< E.param (E.nonNullable E.uuid)+        , view #messageId >$< E.param (E.nonNullable E.text)+        , view #source >$< E.param (E.nonNullable E.text)+        , view #destination >$< E.param (E.nonNullable E.text)+        , view #messageKey >$< E.param (E.nullable E.text)+        , view #eventType >$< E.param (E.nonNullable E.text)+        , view #schemaVersion >$< E.param (E.nonNullable E.int8)+        , view #contentType >$< E.param (E.nonNullable E.text)+        , view #schemaRegistry >$< E.param (E.nullable E.text)+        , view #schemaSubject >$< E.param (E.nullable E.text)+        , view #schemaVersionRef >$< E.param (E.nullable E.int8)+        , view #schemaId >$< E.param (E.nullable E.int8)+        , view #schemaFingerprint >$< E.param (E.nullable E.text)+        , view #sourceEventId >$< E.param (E.nullable E.uuid)+        , view #sourceGlobalPosition >$< E.param (E.nullable E.int8)+        , view #causationId >$< E.param (E.nullable E.uuid)+        , view #correlationId >$< E.param (E.nullable E.uuid)+        , view #traceparent >$< E.param (E.nullable E.text)+        , view #tracestate >$< E.param (E.nullable E.text)+        , view #payloadBytes >$< E.param (E.nonNullable E.bytea)+        , view #attributes >$< E.param (E.nullable E.jsonb)+        , view #occurredAt >$< E.param (E.nonNullable E.timestamptz)+        ]++-- ---------------------------------------------------------------------------+-- Statements+-- ---------------------------------------------------------------------------++enqueueOutboxStmt :: Statement EncodedRow ()+enqueueOutboxStmt =+    preparable+        """+        INSERT INTO keiro.keiro_outbox+          ( outbox_id+          , message_id+          , source+          , destination+          , message_key+          , event_type+          , schema_version+          , content_type+          , schema_registry+          , schema_subject+          , schema_version_ref+          , schema_id+          , schema_fingerprint+          , source_event_id+          , source_global_position+          , causation_id+          , correlation_id+          , traceparent+          , tracestate+          , payload_bytes+          , attributes+          , occurred_at+          )+        VALUES+          ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $20, $21, $22)+        ON CONFLICT (source, message_id) DO NOTHING+        """+        encodedRowEncoder+        D.noResult++claimStmt :: OrderingPolicy -> Statement (Int64, UTCTime) [OutboxRow]+claimStmt policy =+    preparable+        (claimSql (policyPredicates policy))+        ( contrazip2+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.timestamptz))+        )+        (D.rowList claimResultDecoder)++data PolicyPredicates = PolicyPredicates+    { preFilter :: !Text+    , postFilter :: !Text+    }+    deriving stock (Generic)++policyPredicates :: OrderingPolicy -> PolicyPredicates+policyPredicates = \case+    PerKeyHeadOfLine -> perKeyPredicates+    PerSourceStream -> perSourcePredicates+    StopTheLine -> perKeyPredicates+    BestEffort -> PolicyPredicates{preFilter = "TRUE", postFilter = "TRUE"}++perKeyPredicates :: PolicyPredicates+perKeyPredicates =+    PolicyPredicates+        { preFilter =+            """+            ( r.message_key IS NULL OR NOT EXISTS (+                SELECT 1 FROM keiro.keiro_outbox earlier+                WHERE earlier.source = r.source+                  AND earlier.message_key = r.message_key+                  AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id)+                  AND earlier.status NOT IN ('sent', 'dead')+                  AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) ) )+            """+        , postFilter =+            """+            ( c.message_key IS NULL OR NOT EXISTS (+                SELECT 1 FROM keiro.keiro_outbox earlier+                WHERE earlier.source = c.source+                  AND earlier.message_key = c.message_key+                  AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id)+                  AND earlier.status NOT IN ('sent', 'dead')+                  AND NOT EXISTS (+                    SELECT 1 FROM candidate c2+                    WHERE c2.outbox_id = earlier.outbox_id ) ) )+            """+        }++perSourcePredicates :: PolicyPredicates+perSourcePredicates =+    PolicyPredicates+        { preFilter =+            """+            NOT EXISTS (+              SELECT 1 FROM keiro.keiro_outbox earlier+              WHERE earlier.source = r.source+                AND (earlier.created_at, earlier.outbox_id) < (r.created_at, r.outbox_id)+                AND earlier.status NOT IN ('sent', 'dead')+                AND NOT (earlier.status IN ('pending', 'failed') AND earlier.next_attempt_at <= $2) )+            """+        , postFilter =+            """+            NOT EXISTS (+              SELECT 1 FROM keiro.keiro_outbox earlier+              WHERE earlier.source = c.source+                AND (earlier.created_at, earlier.outbox_id) < (c.created_at, c.outbox_id)+                AND earlier.status NOT IN ('sent', 'dead')+                AND NOT EXISTS (+                  SELECT 1 FROM candidate c2+                  WHERE c2.outbox_id = earlier.outbox_id ) )+            """+        }++claimSql :: PolicyPredicates -> Text+claimSql PolicyPredicates{preFilter, postFilter} =+    """+    WITH candidate AS (+      SELECT r.outbox_id, r.source, r.message_key, r.created_at+      FROM keiro.keiro_outbox r+      WHERE r.status IN ('pending', 'failed')+        AND r.next_attempt_at <= $2+        AND (+    """+        <> preFilter+        <> """++           )+             ORDER BY r.created_at, r.outbox_id+             LIMIT $1+             FOR UPDATE SKIP LOCKED+           ),+           ready AS (+           SELECT c.outbox_id, c.created_at AS claim_created_at+           FROM candidate c+           WHERE (+           """+        <> postFilter+        <> """++           )+           ),+           updated AS (+           UPDATE keiro.keiro_outbox kt+           SET status = 'publishing', attempt_count = kt.attempt_count + 1, updated_at = $2+           FROM ready+           WHERE kt.outbox_id = ready.outbox_id+           RETURNING ready.claim_created_at,++           """+        <> rowColumns+        <> """++           )+           SELECT++           """+        <> unqualifiedRowColumns+        <> """++           FROM updated+           ORDER BY claim_created_at, outbox_id+           """++rowColumns :: Text+rowColumns =+    """+    kt.outbox_id, kt.message_id, kt.source, kt.destination, kt.message_key,+    kt.event_type, kt.schema_version, kt.content_type, kt.schema_registry,+    kt.schema_subject, kt.schema_version_ref, kt.schema_id, kt.schema_fingerprint,+    kt.source_event_id, kt.source_global_position, kt.causation_id,+    kt.correlation_id, kt.traceparent, kt.tracestate, kt.payload_bytes,+    kt.attributes, kt.occurred_at, kt.status, kt.attempt_count,+    kt.next_attempt_at, kt.last_error, kt.published_at, kt.created_at,+    kt.updated_at+    """++unqualifiedRowColumns :: Text+unqualifiedRowColumns =+    """+    outbox_id, message_id, source, destination, message_key,+    event_type, schema_version, content_type, schema_registry,+    schema_subject, schema_version_ref, schema_id, schema_fingerprint,+    source_event_id, source_global_position, causation_id,+    correlation_id, traceparent, tracestate, payload_bytes,+    attributes, occurred_at, status, attempt_count,+    next_attempt_at, last_error, published_at, created_at,+    updated_at+    """++claimResultDecoder :: D.Row OutboxRow+claimResultDecoder = outboxRowDecoder++countBacklogStmt :: Statement () Int+countBacklogStmt =+    preparable+        "SELECT COUNT(*)::bigint FROM keiro.keiro_outbox WHERE status IN ('pending', 'failed')"+        E.noParams+        (fmap fromIntegral (D.singleRow (D.column (D.nonNullable D.int8))))++gcSentStmt :: Statement UTCTime Int64+gcSentStmt =+    preparable+        """+        WITH deleted AS (+          DELETE FROM keiro.keiro_outbox+          WHERE status = 'sent' AND published_at < $1+          RETURNING 1+        )+        SELECT COALESCE(COUNT(*), 0)::bigint FROM deleted+        """+        (E.param (E.nonNullable E.timestamptz))+        (D.singleRow (D.column (D.nonNullable D.int8)))++readAttemptCountStmt :: Statement UUID (Maybe Int)+readAttemptCountStmt =+    preparable+        "SELECT attempt_count FROM keiro.keiro_outbox WHERE outbox_id = $1"+        (E.param (E.nonNullable E.uuid))+        (D.rowMaybe (fromIntegral <$> D.column (D.nonNullable D.int8)))++deadLetterStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64+deadLetterStuckStmt =+    preparable+        """+        UPDATE keiro.keiro_outbox+        SET status = 'dead',+            last_error = COALESCE(last_error, 'reclaimed: publisher crashed mid-publish'),+            updated_at = $3+        WHERE status = 'publishing'+          AND updated_at <= $1+          AND attempt_count >= $2+        """+        ( contrazip3+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.timestamptz))+        )+        D.rowsAffected++requeueStuckStmt :: Statement (UTCTime, Int64, UTCTime) Int64+requeueStuckStmt =+    preparable+        """+        UPDATE keiro.keiro_outbox+        SET status = 'failed',+            updated_at = $3+        WHERE status = 'publishing'+          AND updated_at <= $1+          AND attempt_count < $2+        """+        ( contrazip3+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.timestamptz))+        )+        D.rowsAffected++markSentStmt :: Statement (UUID, UTCTime) Bool+markSentStmt =+    preparable+        """+        UPDATE keiro.keiro_outbox+        SET status = 'sent',+            published_at = $2,+            last_error = NULL,+            updated_at = $2+        WHERE outbox_id = $1+          AND status = 'publishing'+        """+        ( contrazip2+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.timestamptz))+        )+        ((> 0) <$> D.rowsAffected)++markSentBatchStmt :: Statement ([UUID], UTCTime) Int64+markSentBatchStmt =+    preparable+        """+        UPDATE keiro.keiro_outbox+        SET status = 'sent',+            published_at = $2,+            last_error = NULL,+            updated_at = $2+        WHERE outbox_id = ANY($1)+          AND status = 'publishing'+        """+        ( contrazip2+            (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid))))+            (E.param (E.nonNullable E.timestamptz))+        )+        D.rowsAffected++markFailedStmt :: Statement (UUID, Text, Text, UTCTime, UTCTime) ()+markFailedStmt =+    preparable+        """+        UPDATE keiro.keiro_outbox+        SET status = $2,+            last_error = $3,+            next_attempt_at = $4,+            updated_at = $5+        WHERE outbox_id = $1+          AND status = 'publishing'+        """+        ( contrazip5+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.timestamptz))+        )+        D.noResult++markSkippedStmt :: Statement (UUID, Text, UTCTime) ()+markSkippedStmt =+    preparable+        """+        UPDATE keiro.keiro_outbox+        SET status = 'failed',+            attempt_count = GREATEST(attempt_count - 1, 0),+            last_error = $2,+            next_attempt_at = $3,+            updated_at = $3+        WHERE outbox_id = $1+          AND status = 'publishing'+        """+        ( contrazip3+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.timestamptz))+        )+        D.noResult++lookupOutboxStmt :: Statement UUID (Maybe OutboxRow)+lookupOutboxStmt =+    preparable+        (selectAllSql <> " WHERE outbox_id = $1")+        (E.param (E.nonNullable E.uuid))+        (D.rowMaybe outboxRowDecoder)++listOutboxStmt :: Statement Text [OutboxRow]+listOutboxStmt =+    preparable+        (selectAllSql <> " WHERE source = $1 ORDER BY created_at, outbox_id")+        (E.param (E.nonNullable E.text))+        (D.rowList outboxRowDecoder)++selectAllSql :: Text+selectAllSql =+    """+    SELECT outbox_id, message_id, source, destination, message_key, event_type,+           schema_version, content_type, schema_registry, schema_subject,+           schema_version_ref, schema_id, schema_fingerprint, source_event_id,+           source_global_position, causation_id, correlation_id, traceparent,+           tracestate, payload_bytes, attributes, occurred_at, status,+           attempt_count, next_attempt_at, last_error, published_at, created_at,+           updated_at+    FROM keiro.keiro_outbox+    """++outboxRowDecoder :: D.Row OutboxRow+outboxRowDecoder = fmap assembleRow rawRowDecoder++data RawRow = RawRow+    { outboxId :: !OutboxId+    , messageId :: !Text+    , source :: !Text+    , destination :: !Text+    , key :: !(Maybe Text)+    , eventType :: !Text+    , schemaVersion :: !Int+    , contentType :: !Text+    , schemaRegistry :: !(Maybe Text)+    , schemaSubject :: !(Maybe Text)+    , schemaVersionRef :: !(Maybe Int)+    , schemaId :: !(Maybe Int64)+    , schemaFingerprint :: !(Maybe Text)+    , sourceEventId :: !(Maybe EventId)+    , sourceGlobalPosition :: !(Maybe GlobalPosition)+    , causationId :: !(Maybe EventId)+    , correlationId :: !(Maybe EventId)+    , traceparent :: !(Maybe Text)+    , tracestate :: !(Maybe Text)+    , payloadBytes :: !ByteString+    , attributes :: !(Maybe Value)+    , occurredAt :: !UTCTime+    , status :: !OutboxStatus+    , attemptCount :: !Int+    , nextAttemptAt :: !UTCTime+    , lastError :: !(Maybe Text)+    , publishedAt :: !(Maybe UTCTime)+    , createdAt :: !UTCTime+    , updatedAt :: !UTCTime+    }+    deriving stock (Generic)++rawRowDecoder :: D.Row RawRow+rawRowDecoder =+    RawRow+        <$> (OutboxId <$> D.column (D.nonNullable D.uuid))+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> (fromIntegral <$> D.column (D.nonNullable D.int8))+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nullable D.text)+        <*> (fmap fromIntegral <$> D.column (D.nullable D.int8))+        <*> D.column (D.nullable D.int8)+        <*> D.column (D.nullable D.text)+        <*> (fmap EventId <$> D.column (D.nullable D.uuid))+        <*> (fmap GlobalPosition <$> D.column (D.nullable D.int8))+        <*> (fmap EventId <$> D.column (D.nullable D.uuid))+        <*> (fmap EventId <$> D.column (D.nullable D.uuid))+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nonNullable D.bytea)+        <*> D.column (D.nullable D.jsonb)+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nonNullable (D.refine parseStatus D.text))+        <*> (fromIntegral <$> D.column (D.nonNullable D.int8))+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nullable D.timestamptz)+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nonNullable D.timestamptz)++assembleRow :: RawRow -> OutboxRow+assembleRow raw =+    let traceContext = case raw ^. #traceparent of+            Nothing -> Nothing+            Just tp -> Just (TraceContext tp (raw ^. #tracestate))+        schemaReference =+            case ( raw ^. #schemaRegistry+                 , raw ^. #schemaSubject+                 , raw ^. #schemaVersionRef+                 , raw ^. #schemaId+                 , raw ^. #schemaFingerprint+                 ) of+                (Nothing, Nothing, Nothing, Nothing, Nothing) -> Nothing+                _ ->+                    Just+                        ( SchemaReference+                            (raw ^. #schemaRegistry)+                            (raw ^. #schemaSubject)+                            (raw ^. #schemaVersionRef)+                            (raw ^. #schemaId)+                            (raw ^. #schemaFingerprint)+                        )+        event =+            IntegrationEvent+                { messageId = raw ^. #messageId+                , source = raw ^. #source+                , destination = raw ^. #destination+                , key = raw ^. #key+                , eventType = raw ^. #eventType+                , schemaVersion = raw ^. #schemaVersion+                , contentType = parseContentType (raw ^. #contentType)+                , schemaReference+                , sourceEventId = raw ^. #sourceEventId+                , sourceGlobalPosition = raw ^. #sourceGlobalPosition+                , payloadBytes = raw ^. #payloadBytes+                , occurredAt = raw ^. #occurredAt+                , causationId = raw ^. #causationId+                , correlationId = raw ^. #correlationId+                , traceContext+                , attributes = raw ^. #attributes+                }+     in OutboxRow+            { outboxId = raw ^. #outboxId+            , event+            , status = raw ^. #status+            , attemptCount = raw ^. #attemptCount+            , nextAttemptAt = raw ^. #nextAttemptAt+            , lastError = raw ^. #lastError+            , publishedAt = raw ^. #publishedAt+            , createdAt = raw ^. #createdAt+            , updatedAt = raw ^. #updatedAt+            }
+ src/Keiro/Outbox/Types.hs view
@@ -0,0 +1,277 @@+{- | Shared types for the durable integration-event outbox.++The outbox is the durable handoff between "this service has decided to+publish this integration event" and "this service has actually published+it". The producer subscription writes one outbox row per mapped private+event; the publisher worker drains rows into Kafka and marks each one+sent, retryable, or dead.+-}+module Keiro.Outbox.Types (+    OutboxId (..),+    OutboxStatus (..),+    OrderingPolicy (..),+    BackoffSchedule (..),+    ExponentialBackoffOptions (..),+    OutboxMessage (..),+    OutboxRow (..),+    OutboxPublishOptions (..),+    OutboxPublishConfigError (..),+    OutboxPublishSummary (..),+    OutboxMaintenanceOptions (..),+    OutboxMaintenanceSummary (..),+    defaultPublishOptions,+    defaultMaintenanceOptions,+    mkOutboxPublishOptions,+    statusText,+    parseStatus,+    nextDelay,+)+where++import Data.Time.Clock (NominalDiffTime)+import Data.UUID (UUID)+import Data.UUID qualified as UUID+import Keiro.Integration.Event (IntegrationEvent)+import Keiro.Prelude+import OpenTelemetry.Trace.Core (Tracer)++-- | Primary key of a 'keiro_outbox' row. Stable across publish retries.+newtype OutboxId = OutboxId {unOutboxId :: UUID}+    deriving stock (Generic, Eq, Ord, Show)++instance ToJSON OutboxId where+    toJSON = toJSON . UUID.toText . unOutboxId++instance FromJSON OutboxId where+    parseJSON v = do+        text <- parseJSON v+        case UUID.fromText text of+            Nothing -> fail ("OutboxId: not a UUID: " <> show text)+            Just uuid -> pure (OutboxId uuid)++{- | Lifecycle state of an outbox row.++* 'OutboxPending' — never attempted.+* 'OutboxPublishing' — currently held by a publisher worker (between+  claim and the call to mark sent/failed/dead). Rows left in this state+  after a worker crash are reclaimed by 'Keiro.Outbox.outboxMaintenancePass'+  after 'publishingTimeout'.+* 'OutboxSent' — Kafka acknowledged the publish; terminal.+* 'OutboxFailed' — last attempt failed; will be retried after+  'next_attempt_at'.+* 'OutboxDead' — terminal failure after 'maxAttempts' consecutive+  failures. Stays in the table for operator inspection.+-}+data OutboxStatus+    = OutboxPending+    | OutboxPublishing+    | OutboxSent+    | OutboxFailed+    | OutboxDead+    deriving stock (Generic, Eq, Show)++{- | Ordering policy enforced by the publisher worker's claim query.++* 'PerKeyHeadOfLine' (default) — within a @source@, a non-terminal row+  with key @k@ blocks every later row with the same key. Rows with+  'Nothing' key bypass the block (Kafka does not promise cross-key order+  for null-keyed records). One stuck aggregate cannot stall traffic on+  other aggregates. Ordering is based on @created_at@, which PostgreSQL+  sets to transaction-start time; callers that concurrently enqueue the+  same key through escape hatches must serialize those enqueues themselves+  if commit order matters.+* 'PerSourceStream' — within a @source@, any non-terminal row blocks+  every later row. Use when ordering matters across keys (rare). This has+  the same @created_at@ concurrency caveat as 'PerKeyHeadOfLine'.+* 'StopTheLine' — any failure halts the worker until operator+  intervention. Use when correctness requires manual review on every+  failure.+* 'BestEffort' — failed rows do not block; explicit opt-in only. Safe+  only when published events have no per-key/causal relationship.+-}+data OrderingPolicy+    = PerKeyHeadOfLine+    | PerSourceStream+    | StopTheLine+    | BestEffort+    deriving stock (Generic, Eq, Show)++-- | Knobs for 'ExponentialBackoff'. @delay = min maxDelay (initial * multiplier ^ (attempt - 1))@.+data ExponentialBackoffOptions = ExponentialBackoffOptions+    { initial :: !NominalDiffTime+    , maxDelay :: !NominalDiffTime+    , multiplier :: !Double+    }+    deriving stock (Generic, Eq, Show)++{- | Backoff curve used to compute 'next_attempt_at' after a failure.++* 'ConstantBackoff' — fixed delay between retries.+* 'ExponentialBackoff' — exponential growth capped at @maxDelay@.+-}+data BackoffSchedule+    = ConstantBackoff !NominalDiffTime+    | ExponentialBackoff !ExponentialBackoffOptions+    deriving stock (Generic, Eq, Show)++{- | Compute the retry delay for an attempt number (1-based: 1 = first+failure, 2 = second failure, …). Used by 'Keiro.Outbox.Schema.markOutboxFailedTx'+to derive @next_attempt_at@.+-}+nextDelay :: BackoffSchedule -> Int -> NominalDiffTime+nextDelay (ConstantBackoff delay) _ = delay+nextDelay (ExponentialBackoff opts) attempt =+    let raw = (opts ^. #initial) * realToFrac ((opts ^. #multiplier) ** fromIntegral (max 0 (attempt - 1)))+     in min (opts ^. #maxDelay) raw++{- | A request to enqueue one integration event into the outbox. Callers+generate 'outboxId' (use a random UUID for ad-hoc enqueues, a+deterministic UUID for idempotent retries from a saga/process manager).+-}+data OutboxMessage = OutboxMessage+    { outboxId :: !OutboxId+    , event :: !IntegrationEvent+    }+    deriving stock (Generic, Eq, Show)++{- | A row read back from @keiro_outbox@. Worker code consumes these to+publish to Kafka; tests use them to assert state transitions.+-}+data OutboxRow = OutboxRow+    { outboxId :: !OutboxId+    , event :: !IntegrationEvent+    , status :: !OutboxStatus+    , attemptCount :: !Int+    , nextAttemptAt :: !UTCTime+    , lastError :: !(Maybe Text)+    , publishedAt :: !(Maybe UTCTime)+    , createdAt :: !UTCTime+    , updatedAt :: !UTCTime+    }+    deriving stock (Generic, Eq, Show)++{- | Knobs that govern one invocation of 'Keiro.Outbox.publishClaimedOutbox'.++The optional 'tracer' field opts the publisher into OpenTelemetry+instrumentation: when present, the publisher opens a @Producer@-kind+span around each publish call, attributing the first row's+'IntegrationEvent.destination' (topic), 'IntegrationEvent.messageId',+and Kafka key per the messaging semantic conventions. When 'tracer' is+'Nothing' (the default) the publisher emits no spans.+-}+data OutboxPublishOptions = OutboxPublishOptions+    { batchSize :: !Int+    , maxAttempts :: !Int+    , backoff :: !BackoffSchedule+    , orderingPolicy :: !OrderingPolicy+    , publishingTimeout :: !NominalDiffTime+    , tracer :: !(Maybe Tracer)+    }+    deriving stock (Generic)++data OutboxPublishConfigError+    = InvalidOutboxBatchSize !Int+    | InvalidOutboxMaxAttempts !Int+    | InvalidOutboxPublishingTimeout !NominalDiffTime+    | InvalidConstantBackoff !NominalDiffTime+    | InvalidExponentialBackoffInitial !NominalDiffTime+    | InvalidExponentialBackoffMultiplier !Double+    | InvalidExponentialBackoffMaxDelay !NominalDiffTime !NominalDiffTime+    deriving stock (Generic, Eq, Show)++{- | Aggregate result of one publisher pass.++@published + retried + dead@ equals the number of rows claimed. 'retried'+includes rows that were skipped because an earlier row in the same ordered+publish group failed; those rows are returned to @failed@ without consuming+an attempt. 'haltedOn' is populated only by 'StopTheLine' policy and names+the failed pivot row, which is already counted in 'retried' or 'dead'.+-}+data OutboxPublishSummary = OutboxPublishSummary+    { claimed :: !Int+    , published :: !Int+    , retried :: !Int+    , dead :: !Int+    , haltedOn :: !(Maybe OutboxId)+    }+    deriving stock (Generic, Eq, Show)++{- | Knobs for 'Keiro.Outbox.outboxMaintenancePass'.++Schedule maintenance less frequently than publish passes; it owns crash+reclamation and backlog gauge sampling.+-}+data OutboxMaintenanceOptions = OutboxMaintenanceOptions+    { maxAttempts :: !Int+    , publishingTimeout :: !NominalDiffTime+    }+    deriving stock (Generic, Eq, Show)++-- | Result of one outbox maintenance pass.+data OutboxMaintenanceSummary = OutboxMaintenanceSummary+    { requeued :: !Int+    , deadLettered :: !Int+    , backlog :: !Int+    }+    deriving stock (Generic, Eq, Show)++{- | Sensible defaults: batch of 32, ten retry attempts, two-second+constant backoff, per-key head-of-line ordering.+-}+defaultPublishOptions :: OutboxPublishOptions+defaultPublishOptions =+    OutboxPublishOptions+        { batchSize = 32+        , maxAttempts = 10+        , backoff = ConstantBackoff 2+        , orderingPolicy = PerKeyHeadOfLine+        , publishingTimeout = 300+        , tracer = Nothing+        }++-- | Maintenance defaults match the publisher's retry ceiling and stale-row timeout.+defaultMaintenanceOptions :: OutboxMaintenanceOptions+defaultMaintenanceOptions =+    OutboxMaintenanceOptions+        { maxAttempts = defaultPublishOptions ^. #maxAttempts+        , publishingTimeout = defaultPublishOptions ^. #publishingTimeout+        }++-- | Validate outbox publisher options before starting a worker.+mkOutboxPublishOptions :: OutboxPublishOptions -> Either OutboxPublishConfigError OutboxPublishOptions+mkOutboxPublishOptions opts+    | opts ^. #batchSize < 1 = Left (InvalidOutboxBatchSize (opts ^. #batchSize))+    | opts ^. #maxAttempts < 1 = Left (InvalidOutboxMaxAttempts (opts ^. #maxAttempts))+    | opts ^. #publishingTimeout <= 0 = Left (InvalidOutboxPublishingTimeout (opts ^. #publishingTimeout))+    | otherwise = opts <$ validateBackoff (opts ^. #backoff)++validateBackoff :: BackoffSchedule -> Either OutboxPublishConfigError ()+validateBackoff = \case+    ConstantBackoff delay+        | delay < 0 -> Left (InvalidConstantBackoff delay)+        | otherwise -> Right ()+    ExponentialBackoff backoff+        | backoff ^. #initial <= 0 -> Left (InvalidExponentialBackoffInitial (backoff ^. #initial))+        | backoff ^. #multiplier < 1 -> Left (InvalidExponentialBackoffMultiplier (backoff ^. #multiplier))+        | backoff ^. #maxDelay < backoff ^. #initial ->+            Left (InvalidExponentialBackoffMaxDelay (backoff ^. #initial) (backoff ^. #maxDelay))+        | otherwise -> Right ()++-- | Wire representation of 'OutboxStatus' used in the @status@ column.+statusText :: OutboxStatus -> Text+statusText = \case+    OutboxPending -> "pending"+    OutboxPublishing -> "publishing"+    OutboxSent -> "sent"+    OutboxFailed -> "failed"+    OutboxDead -> "dead"++-- | Inverse of 'statusText'. Unknown database values are decode failures.+parseStatus :: Text -> Either Text OutboxStatus+parseStatus = \case+    "pending" -> Right OutboxPending+    "publishing" -> Right OutboxPublishing+    "sent" -> Right OutboxSent+    "failed" -> Right OutboxFailed+    "dead" -> Right OutboxDead+    bad -> Left ("unknown keiro_outbox.status: " <> bad)
+ src/Keiro/ProcessManager.hs view
@@ -0,0 +1,731 @@+{- | Stateful coordination across aggregates: the process manager (saga).++A 'ProcessManager' reacts to an incoming event by stepping its /own/ state+machine — a private \"manager\" event stream, keyed by a correlation id — and,+in the same turn, dispatching commands to /target/ aggregates and scheduling+timers. It is the stateful counterpart of "Keiro.Router": where a router+resolves targets from a read model and holds no state, a process manager+folds the events it has seen into durable manager state and decides what to+do next from that state.++Every write — the manager-state append, each dispatched command, each timer+— is keyed by a 'deterministicCommandId' derived from+@(name, correlation, source event id, emit index)@. The manager pre-checks+each id with 'eventAlreadyIn' and folds the store's duplicate rejection into+a benign 'PMCommandDuplicate' \/ 'PMStateDuplicate'. Replaying the same+source event therefore appends nothing new, which is what makes the worker+crash-safe under at-least-once delivery.++Use 'runProcessManagerOnce' to react to a single event, or+'runProcessManagerWorker' to run the manager as a live subscription over a+Shibuya adapter. Worker acks are finalized exactly once: successful and duplicate+dispatches ack 'AckOk', transient store failures retry, systemic deterministic+failures halt, rejection-class failures follow 'RejectedCommandPolicy', and+undecodable messages follow the configured 'PoisonPolicy'.++=== Rejected commands and saga history++'RejectedHalt' is the safe default: the subscription stops without advancing,+so an operator cannot miss the failure. 'RejectedDeadLetter' instead writes a+durable "Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source+event; 'RejectedSkip' acknowledges and records only the metric. Prefer making a+target command total in its Keiki transducer (for example, an explicit no-op+transition for a benign business rejection) so no policy escape hatch is+needed.++For a process manager, dead-lettering a target dispatch creates an important+history split: the manager's own state stream has recorded its reaction, but+the target command never applied. Keiro cannot append a generic correction to+the manager stream because an event unknown to the manager's transducer would+make that stream fail replay. If saga history must reflect the failure, model a+domain-specific @DispatchFailed@-style command and event in the manager and+drive it from 'Keiro.DeadLetter.listDispatchDeadLetters' through an operator+runbook or automation. Otherwise, the dead-letter row is the durable witness.+Manager-state rejection itself has no such split because no manager event was+appended; its record uses emit index @-1@.++=== Bounded retries and source-event dead letters++On a Kiroku-backed Shibuya adapter, a transient failure finalizes 'AckRetry',+but retries are bounded by the Kiroku subscription's @RetryPolicy@. Its+@retryMaxAttempts@ counts total deliveries and defaults to five. When the bound+is exhausted, Kiroku records the /source event/ in @kiroku.dead_letters@ with+structured reason kind @max_attempts_exceeded@ and atomically advances the+checkpoint. The manager will not see that event again unless an operator+replays it through @Keiro.DeadLetter.Replay@. Install+'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe the+terminal transition.++The adapter's @KirokuAdapterConfig@ does not currently expose @retryPolicy@, so+that path uses Kiroku's default bound. The sharded path is configurable:+'Keiro.Subscription.Shard.Worker.runShardedSubscriptionGroupAck' forwards+'Keiro.Subscription.Shard.Worker.ShardedWorkerOptions.retryPolicy' into the+same Kiroku acknowledgement ladder. A shard handler that dispatches commands+can use 'decideForFailures' and 'isRejectionClass' to classify outcomes, then+map the decision to its existing @ShardAck@ reply.++=== Correlation, ordering, and transaction boundaries++Events from one originating stream retain that stream's append order. Kiroku+consumer groups hash the originating stream id to a stable member, so sharding+does not split one stream across readers. Events from /different/ streams that+'correlate' to the same manager instance have no business-order guarantee,+however. Their append transactions race for global positions and, under+sharding, the streams may be processed concurrently by different members. A+retry on one member does not stop another member from advancing.++For example, both @payment-ORD1@'s @PaymentCaptured@ and @shipment-ORD1@'s+@ShipmentAllocated@ may correlate to order @ORD1@. The manager must accept+@PaymentCaptured@ then @ShipmentAllocated@ /and/ the reverse, normally with+states that record one fact while waiting for the other. An unsharded Kiroku+subscription processes its observed global order serially, including retries,+but that order still reflects append timing rather than a domain sequence.++Rule of thumb: 'correlate' may join streams freely, but every such join must be+order-insensitive. When a strict sequence is required, enforce it in the+manager's own state machine — for example with an explicit no-op/waiting state+and a timer-driven retry, or a modeled rejection handled by the dead-letter+policy — never by assuming delivery order.++The persistence boundary is also intentionally smaller than one whole saga+reaction. A manager event and its timers commit together when the manager+command appends; a timer-only no-op reaction schedules its timers in a separate+transaction. Each target command and its inline projections then commit in+their own transaction. A crash or rejected target can therefore leave durable+manager history without every target write. Deterministic ids make source-event+replay fill the missing writes without duplicating completed ones; the rejected+command section above describes the case that is deliberately acknowledged+instead.+-}+module Keiro.ProcessManager (+    -- * Definition+    ProcessManager (..),+    ProcessManagerAction (..),+    PMCommand (..),++    -- * Results+    ProcessManagerResult (..),+    PMCommandResult (..),+    PMStateResult (..),++    -- * Running+    PoisonPolicy (..),+    RejectedCommandPolicy (..),+    DispatchFailure (..),+    WorkerOptions (..),+    defaultWorkerOptions,+    isTransientStoreError,+    isTransientCommandError,+    isRejectionClass,+    decideForFailures,+    ackForCommandError,+    runProcessManagerOnce,+    runProcessManagerWorkerWith,+    runProcessManagerWorker,++    -- * Idempotency primitives+    deterministicCommandId,+    eventAlreadyIn,+    confirmBenignDuplicate,+)+where++import Data.Coerce (coerce)+import Data.Text qualified as Text+import Data.UUID qualified as UUID+import Data.UUID.V5 qualified as UUID.V5+import Effectful (Eff, IOE, (:>))+import Effectful.Error.Static (Error, tryError)+import GHC.Stack (HasCallStack)+import Keiki.Core (BoolAlg, RegFile)+import Keiro.Command (CommandError (..), CommandResult, RunCommandOptions, commandErrorClass, runCommandWithSql)+import Keiro.DeadLetter (DispatchDeadLetter (..), DispatcherKind (..), recordDispatchDeadLetter)+import Keiro.EventStream (EventStream)+import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated)+import Keiro.Prelude+import Keiro.Projection (InlineProjection, runCommandWithProjections)+import Keiro.Stream (Stream)+import Keiro.Telemetry (KeiroMetrics, recordDispatchDeadLettered, recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison)+import Keiro.Timer (TimerRequest, scheduleTimerTx)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Effect.Resource (KirokuStoreResource)+import Kiroku.Store.Error (StoreError (..))+import Kiroku.Store.Read (eventExistsInStream)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (EventId (..), RecordedEvent)+import Kiroku.Store.Types qualified as StoreTypes+import Shibuya.Adapter (Adapter (..))+import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..))+import Shibuya.Core.AckHandle (AckHandle (..))+import Shibuya.Core.Ingested (Ingested (..))+import Shibuya.Core.Types (Attempt (..), Envelope (..))+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Streamly+import Prelude (any, filter, fromIntegral, length, not, uncurry, zip, (&&), (+))++{- | A process manager wiring together a manager state machine and the target+aggregate it drives.++* 'name' — stable identity; part of every deterministic write id.+* 'correlate' — derives the correlation key for an input event, selecting+  which manager instance handles it.+* 'eventStream' — the manager's own 'EventStream'; its events record the+  saga's progress.+* 'streamFor' — maps a correlation key to the manager's 'Stream' handle.+* 'targetEventStream' — the aggregate that dispatched commands are sent to.+* 'targetProjections' — inline projections for the target aggregate, run in+  the same transaction as each dispatched command's append. Return @[]@ for+  append-only dispatch.+* 'handle' — the pure reaction: given an input event, produce the+  manager-state command, the target commands to dispatch, and any timers to+  schedule.+-}+data ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo = ProcessManager+    { name :: !Text+    , correlate :: !(input -> Text)+    , eventStream :: !(ValidatedEventStream phi rs s ci co)+    , streamFor :: !(Text -> Stream (EventStream phi rs s ci co))+    , targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo)+    , targetProjections :: !(Stream targetCi -> [InlineProjection targetCo])+    {- ^ Inline projections for the target aggregate, run in the same transaction+    as each dispatched command's append. Return @[]@ for append-only dispatch.+    -}+    , handle :: !(input -> ProcessManagerAction ci targetCi)+    }+    deriving stock (Generic)++{- | What a process manager decides to do for one input event: advance its own+state with 'command', dispatch zero or more target 'commands', and schedule+zero or more 'timers'. All three are applied atomically with crash-safe+idempotency by 'runProcessManagerOnce'.+-}+data ProcessManagerAction ci targetCi = ProcessManagerAction+    { command :: !ci+    , commands :: ![PMCommand targetCi]+    , timers :: ![TimerRequest]+    }+    deriving stock (Generic)++-- | A single command addressed to a specific target stream.+data PMCommand targetCi = PMCommand+    { target :: !(Stream targetCi)+    , command :: !targetCi+    }+    deriving stock (Generic, Eq, Show)++-- | Outcome of one dispatched target command.+data PMCommandResult target+    = -- | The command appended events (carries the 'CommandResult').+      PMCommandAppended !(CommandResult target)+    | {- | The command was already applied (idempotent replay); carries the+      deterministic id that already existed.+      -}+      PMCommandDuplicate !EventId+    | {- | The command failed in the named target stream; the worker classifies+      the error. Transient failures retry, rejection-class failures follow+      'RejectedCommandPolicy', and systemic deterministic failures halt.+      -}+      PMCommandFailed !StoreTypes.StreamName !CommandError+    deriving stock (Generic, Eq, Show)++{- | Outcome of the manager's own state append. Unlike 'PMCommandResult' there+is no failure case — a manager-state append that genuinely errors aborts the+whole reaction via an outer @Left@ 'CommandError'.+-}+data PMStateResult target+    = PMStateAppended !(CommandResult target)+    | PMStateDuplicate !EventId+    deriving stock (Generic, Eq, Show)++{- | The complete result of reacting to one event: how the manager state+advanced, the outcome of each dispatched command in order, and how many+timers were scheduled.+-}+data ProcessManagerResult managerTarget commandTarget = ProcessManagerResult+    { managerResult :: !(PMStateResult managerTarget)+    , commandResults :: ![PMCommandResult commandTarget]+    , timersScheduled :: !Int+    }+    deriving stock (Generic, Eq, Show)++-- | What a worker does with a message its decoder cannot parse.+data PoisonPolicy es msg+    = PoisonHalt+    | PoisonSkip !(Envelope msg -> Eff es ())+    | PoisonDeadLetter !(Envelope msg -> Eff es ())++-- | What a worker does when every failed dispatch is a rejection-class error.+data RejectedCommandPolicy+    = -- | Halt without acknowledging so the source event replays. This is the default.+      RejectedHalt+    | -- | Persist a durable dispatch dead letter and acknowledge the source event.+      RejectedDeadLetter+    | -- | Acknowledge and count the rejection without persisting a record.+      RejectedSkip+    deriving stock (Generic, Eq, Show)++-- | One failed dispatch with the target identity needed by worker policy.+data DispatchFailure = DispatchFailure+    { emitIndex :: !Int+    , targetStreamName :: !StoreTypes.StreamName+    , commandError :: !CommandError+    }+    deriving stock (Generic, Eq, Show)++-- | Worker-level knobs shared by the process-manager and router workers.+data WorkerOptions es msg = WorkerOptions+    { poisonPolicy :: !(PoisonPolicy es msg)+    , rejectedCommandPolicy :: !RejectedCommandPolicy+    , transientRetryDelay :: !RetryDelay+    , metrics :: !(Maybe KeiroMetrics)+    }+    deriving stock (Generic)++defaultWorkerOptions :: WorkerOptions es msg+defaultWorkerOptions =+    WorkerOptions+        { poisonPolicy = PoisonHalt+        , rejectedCommandPolicy = RejectedHalt+        , transientRetryDelay = RetryDelay 5+        , metrics = Nothing+        }++isTransientStoreError :: StoreError -> Bool+isTransientStoreError = \case+    ConnectionLost{} -> True+    PoolAcquisitionTimeout -> True+    ConnectionError{} -> True+    WrongExpectedVersion{} -> True+    StreamAlreadyExists{} -> True+    EmptyAppendBatch{} -> False+    StreamNotFound{} -> False+    ReservedStreamName{} -> False+    StreamNameTooLong{} -> False+    DuplicateEvent{} -> False+    EventAlreadyLinked{} -> False+    LinkSourceEventMissing{} -> False+    UnexpectedServerError{} -> False++isTransientCommandError :: CommandError -> Bool+isTransientCommandError = \case+    StoreFailed err -> isTransientStoreError err+    RetryExhausted _ err -> isTransientStoreError err+    ConflictFixpoint _ err -> isTransientStoreError err+    HydrationDecodeFailed{} -> False+    HydrationReplayFailed{} -> False+    HydrationGapDetected{} -> False+    CommandRejected -> False+    CommandAmbiguous{} -> False+    EncodeFailed{} -> False++-- | Whether a command error is a per-command rejection covered by worker policy.+isRejectionClass :: CommandError -> Bool+isRejectionClass = \case+    CommandRejected -> True+    CommandAmbiguous{} -> True+    _ -> False++{- | Classify a group of failed dispatches and choose one acknowledgement.++Systemic deterministic errors always halt. Any transient error retries the+whole source event. Only an all-rejection group reaches the configured+'RejectedCommandPolicy'. Dead-letter writes are idempotent under redelivery.+-}+decideForFailures ::+    (IOE :> es, Store :> es) =>+    WorkerOptions es msg ->+    DispatcherKind ->+    Text ->+    Text ->+    RecordedEvent ->+    Int ->+    [DispatchFailure] ->+    Eff es AckDecision+decideForFailures workerOptions dispatcherKind dispatcherName correlationId sourceEvent attemptCount failures =+    case filter isSystemicDeterministic failures of+        failure : _ -> pure (haltFor failure)+        []+            | any (isTransientCommandError . (^. #commandError)) failures ->+                pure (AckRetry (workerOptions ^. #transientRetryDelay))+            | otherwise ->+                case failures of+                    [] -> pure AckOk+                    _ -> decideRejected+  where+    isSystemicDeterministic failure =+        let err = failure ^. #commandError+         in not (isTransientCommandError err) && not (isRejectionClass err)++    haltFor failure =+        AckHalt (HaltFatal (Text.pack (show (failure ^. #commandError))))++    decideRejected =+        case workerOptions ^. #rejectedCommandPolicy of+            RejectedHalt -> pure (haltFor (headFailure failures))+            RejectedDeadLetter -> do+                traverse_ recordFailure failures+                recordHandled+                pure AckOk+            RejectedSkip -> do+                recordHandled+                pure AckOk++    recordHandled =+        recordDispatchDeadLettered+            (workerOptions ^. #metrics)+            (fromIntegral (length failures))++    recordFailure failure =+        let err = failure ^. #commandError+         in recordDispatchDeadLetter+                DispatchDeadLetter+                    { dispatcherKind = dispatcherKind+                    , dispatcherName = dispatcherName+                    , correlationId = correlationId+                    , sourceEventId = sourceEvent ^. #eventId+                    , sourceGlobalPosition = sourceEvent ^. #globalPosition+                    , emitIndex = failure ^. #emitIndex+                    , targetStreamName = failure ^. #targetStreamName+                    , errorClass = commandErrorClass err+                    , errorDetail = Text.pack (show err)+                    , attemptCount = max 1 attemptCount+                    }++    headFailure = \case+        failure : _ -> failure+        [] -> DispatchFailure (-1) (StoreTypes.StreamName "unknown") CommandRejected++ackForCommandError :: RetryDelay -> CommandError -> AckDecision+ackForCommandError delay err+    | isTransientCommandError err = AckRetry delay+    | otherwise = AckHalt (HaltFatal (Text.pack (show err)))++{- | Derive a stable, collision-resistant 'EventId' for a manager write from+@(manager name, correlation id, source event id, emit index)@ via a v5 UUID.++The same inputs always yield the same id, so a replayed source event+produces the same write ids and the store's uniqueness constraint collapses+the duplicate. The manager-state append uses an emit index of @-1@ to keep+it distinct from the dispatched commands (which start at @0@). This positional+index is sound because 'handle' is pure and therefore returns the same command+order for the same input. The effectful router uses+'Keiro.Router.deterministicRouterCommandId' instead, retaining this positional+id only as a transition probe for pre-upgrade router dispatches.+-}+deterministicCommandId :: Text -> Text -> EventId -> Int -> EventId+deterministicCommandId managerName correlationId sourceEventId emitIndex =+    EventId+        $ UUID.V5.generateNamed UUID.V5.namespaceURL+        $ fmap (fromIntegral . fromEnum)+        $ Text.unpack+        $ Text.intercalate+            ":"+            [ "keiro"+            , "process-manager"+            , managerName+            , correlationId+            , UUID.toText (eventIdToUuid sourceEventId)+            , Text.pack (show emitIndex)+            ]++{- | React to a single source event: advance the manager's state, dispatch+its target commands, and schedule its timers — each under a deterministic,+idempotent write id.++The manager-state append and its timers commit in one transaction; each+target command is then dispatched (with its inline projections) in its own.+A duplicate manager append short-circuits to 'PMStateDuplicate' but still+re-runs the dispatch loop, so a crash between the state append and a+command dispatch is recovered on replay. Returns @Left@ only when the+manager-state append fails for a non-duplicate reason; per-command failures+are reported inside 'commandResults'.+-}+runProcessManagerOnce ::+    forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es.+    ( HasCallStack+    , IOE :> es+    , Store :> es+    , Error StoreError :> es+    , KirokuStoreResource :> es+    , BoolAlg phi (RegFile rs, ci)+    , BoolAlg targetPhi (RegFile targetRs, targetCi)+    , Eq co+    , Eq targetCo+    ) =>+    RunCommandOptions ->+    ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo ->+    RecordedEvent ->+    input ->+    Eff es (Either CommandError (ProcessManagerResult (EventStream phi rs s ci co) (EventStream targetPhi targetRs targetState targetCi targetCo)))+runProcessManagerOnce options manager sourceEvent input = do+    let correlationId = (manager ^. #correlate) input+        action = (manager ^. #handle) input+        managerStream = (manager ^. #streamFor) correlationId+        managerEventId = deterministicCommandId (manager ^. #name) correlationId (sourceEvent ^. #eventId) (-1)+        managerOptions = options & #eventIds .~ [managerEventId]+        managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream+    managerAlreadyProcessed <- eventAlreadyIn options managerStreamName managerEventId+    if managerAlreadyProcessed+        then finish correlationId (PMStateDuplicate managerEventId) action+        else do+            managerOutcome <-+                runCommandWithSql+                    managerOptions+                    (manager ^. #eventStream)+                    managerStream+                    (action ^. #command)+                    (\_ -> traverse_ scheduleTimerTx (action ^. #timers))+            case managerOutcome of+                Left err -> do+                    benign <- confirmBenignDuplicate managerStreamName managerEventId err+                    if benign+                        then finish correlationId (PMStateDuplicate managerEventId) action+                        else pure (Left err)+                Right (managerResult, scheduledInAppend) -> do+                    -- No-op manager commands do not execute runCommandWithSql's callback,+                    -- so schedule timer-only reactions explicitly.+                    case scheduledInAppend of+                        Nothing -> runTransaction (traverse_ scheduleTimerTx (action ^. #timers))+                        Just () -> pure ()+                    finish correlationId (PMStateAppended managerResult) action+  where+    finish correlationId managerResult action = do+        commandResults <- dispatchCommands correlationId (sourceEvent ^. #eventId) (action ^. #commands)+        pure+            $ Right+                ProcessManagerResult+                    { managerResult = managerResult+                    , commandResults = commandResults+                    , timersScheduled = length (action ^. #timers)+                    }++    dispatchCommands correlationId sourceEventId commands =+        traverse+            (uncurry (dispatchCommand correlationId sourceEventId))+            (zip [0 ..] commands)++    dispatchCommand correlationId sourceEventId emitIndex command = do+        let commandId = deterministicCommandId (manager ^. #name) correlationId sourceEventId emitIndex+            targetOptions = options & #eventIds .~ [commandId]+            targetStream = retarget (command ^. #target)+            targetStreamName = ((unvalidated (manager ^. #targetEventStream)) ^. #resolveStreamName) targetStream+        commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId+        if commandAlreadyProcessed+            then pure (PMCommandDuplicate commandId)+            else do+                outcome <-+                    runCommandWithProjections+                        targetOptions+                        (manager ^. #targetEventStream)+                        targetStream+                        (command ^. #command)+                        ((manager ^. #targetProjections) (command ^. #target))+                case outcome of+                    Right result -> pure (PMCommandAppended result)+                    Left err -> do+                        benign <- confirmBenignDuplicate targetStreamName commandId err+                        pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err++    retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo)+    retarget = coerce++{- | Run a process manager as a live subscription draining a Shibuya adapter with+'defaultWorkerOptions'.++Use 'runProcessManagerWorkerWith' to override poison-message handling, rejected+command handling, transient retry delay, or dispatch metrics. Every ingested message's ack handle is+finalized exactly once. Successful and duplicate dispatches finalize 'AckOk';+transient store failures finalize 'AckRetry'; rejection-class failures follow+'RejectedCommandPolicy'; other deterministic failures finalize 'AckHalt';+undecodable messages follow the configured 'PoisonPolicy'. Under+'RejectedDeadLetter', see the module-level saga-history contract before opting+in. On a Kiroku-backed adapter, each 'AckRetry' redelivery is bounded by the+subscription @RetryPolicy@ (five total deliveries by default). Exhaustion+dead-letters the source event in @kiroku.dead_letters@ and advances the+checkpoint; @KirokuAdapterConfig@ does not currently expose that bound. Observe+the terminal event with 'Keiro.Telemetry.kirokuEventBridge' and replay it with+@Keiro.DeadLetter.Replay@ when appropriate.+-}+runProcessManagerWorker ::+    forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es.+    ( HasCallStack+    , IOE :> es+    , Store :> es+    , Error StoreError :> es+    , KirokuStoreResource :> es+    , BoolAlg phi (RegFile rs, ci)+    , BoolAlg targetPhi (RegFile targetRs, targetCi)+    , Eq co+    , Eq targetCo+    ) =>+    RunCommandOptions ->+    ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo ->+    Adapter es msg ->+    (msg -> Maybe (RecordedEvent, input)) ->+    Eff es ()+runProcessManagerWorker =+    runProcessManagerWorkerWith defaultWorkerOptions++runProcessManagerWorkerWith ::+    forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo es.+    ( HasCallStack+    , IOE :> es+    , Store :> es+    , Error StoreError :> es+    , KirokuStoreResource :> es+    , BoolAlg phi (RegFile rs, ci)+    , BoolAlg targetPhi (RegFile targetRs, targetCi)+    , Eq co+    , Eq targetCo+    ) =>+    WorkerOptions es msg ->+    RunCommandOptions ->+    ProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo ->+    Adapter es msg ->+    (msg -> Maybe (RecordedEvent, input)) ->+    Eff es ()+runProcessManagerWorkerWith workerOptions options manager Adapter{source = adapterSource} decodeMessage =+    Streamly.fold Fold.drain+        $ Streamly.mapM handleIngested adapterSource+  where+    handleIngested :: Ingested es msg -> Eff es AckDecision+    handleIngested Ingested{envelope = env@Envelope{payload = message}, ack = AckHandle finalizeAck} = do+        decision <- case decodeMessage message of+            Nothing -> decideForPoison workerOptions "process-manager worker could not decode message" env+            Just (recorded, input) -> do+                let correlationId = (manager ^. #correlate) input+                    managerStream = (manager ^. #streamFor) correlationId+                    managerStreamName = ((unvalidated (manager ^. #eventStream)) ^. #resolveStreamName) managerStream+                    attemptCount = envelopeAttemptCount env+                outcome <- tryError @StoreError (runProcessManagerOnce options manager recorded input)+                case outcome of+                    Left (_, storeErr) -> do+                        recordDispatchFailed (workerOptions ^. #metrics) 1+                        pure (ackForThrownStoreError (workerOptions ^. #transientRetryDelay) storeErr)+                    Right (Left err) -> do+                        recordDispatchFailed (workerOptions ^. #metrics) 1+                        decideForFailures+                            workerOptions+                            DispatcherProcessManager+                            (manager ^. #name)+                            correlationId+                            recorded+                            attemptCount+                            [DispatchFailure (-1) managerStreamName err]+                    Right (Right result) ->+                        ackForResults+                            workerOptions+                            (manager ^. #name)+                            correlationId+                            recorded+                            attemptCount+                            (result ^. #managerResult)+                            (result ^. #commandResults)+        finalizeAck decision+        pure decision++ackForThrownStoreError :: RetryDelay -> StoreError -> AckDecision+ackForThrownStoreError delay = ackForCommandError delay . StoreFailed++ackForResults ::+    (IOE :> es, Store :> es) =>+    WorkerOptions es msg ->+    Text ->+    Text ->+    RecordedEvent ->+    Int ->+    PMStateResult managerTarget ->+    [PMCommandResult commandTarget] ->+    Eff es AckDecision+ackForResults workerOptions managerName correlationId sourceEvent attemptCount managerResult commandResults = do+    let duplicateCount = stateDuplicateCount managerResult + commandDuplicateCount commandResults+        failures =+            [ DispatchFailure emitIndex targetStreamName err+            | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] commandResults+            ]+    recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount+    recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures))+    decideForFailures+        workerOptions+        DispatcherProcessManager+        managerName+        correlationId+        sourceEvent+        attemptCount+        failures++stateDuplicateCount :: PMStateResult target -> Int64+stateDuplicateCount = \case+    PMStateDuplicate{} -> 1+    PMStateAppended{} -> 0++commandDuplicateCount :: [PMCommandResult target] -> Int64+commandDuplicateCount =+    fromIntegral . length . filter isDuplicateResult+  where+    isDuplicateResult = \case+        PMCommandDuplicate{} -> True+        _ -> False++envelopeAttemptCount :: Envelope msg -> Int+envelopeAttemptCount env =+    case env ^. #attempt of+        Nothing -> 1+        Just (Attempt attempt) -> fromIntegral attempt + 1++decideForPoison ::+    (IOE :> es) =>+    WorkerOptions es msg ->+    Text ->+    Envelope msg ->+    Eff es AckDecision+decideForPoison workerOptions reason env = do+    recordDispatchPoison (workerOptions ^. #metrics) 1+    case workerOptions ^. #poisonPolicy of+        PoisonHalt -> pure (AckHalt (HaltFatal reason))+        PoisonSkip callback -> do+            callback env+            pure AckOk+        PoisonDeadLetter callback -> do+            callback env+            pure (AckDeadLetter (InvalidPayload reason))++eventIdToUuid :: EventId -> UUID.UUID+eventIdToUuid (EventId uuid) = uuid++{- | Check whether an event with the given id is already present in a live stream.+Used as the pre-dispatch idempotency guard so a+command that was already applied on a prior (possibly crashed) attempt is+recognized as a duplicate before re-running it.+-}+eventAlreadyIn ::+    (Store :> es) =>+    RunCommandOptions ->+    StoreTypes.StreamName ->+    EventId ->+    Eff es Bool+eventAlreadyIn _options streamName eventId =+    eventExistsInStream streamName eventId++{- | Decide whether a failed append is a benign duplicate of the write just+attempted: whether @ourId@ is genuinely present in @streamName@.++Kiroku's @DuplicateEvent@ carries 'Just' the colliding id only when+PostgreSQL's detail string parses ('Nothing' otherwise), and because the+store's event-id uniqueness is global, even a matching id does not prove the+event landed in our stream. A mismatched id is never ours; a matching or+missing id is confirmed against the target stream with a point lookup. Callers+fold 'True' into their duplicate result and surface 'False' as the original+failure.+-}+confirmBenignDuplicate ::+    (Store :> es) =>+    StoreTypes.StreamName ->+    EventId ->+    CommandError ->+    Eff es Bool+confirmBenignDuplicate streamName ourId = \case+    StoreFailed (DuplicateEvent (Just duplicateId))+        | duplicateId == ourId -> eventExistsInStream streamName ourId+    StoreFailed (DuplicateEvent Nothing) -> eventExistsInStream streamName ourId+    _ -> pure False
+ src/Keiro/Projection.hs view
@@ -0,0 +1,250 @@+{- | Projections: turning a stream's events into read-side state.++Two flavors, trading consistency against coupling:++* An 'InlineProjection' runs in the /same/ transaction as the command that+  produced the events, so the read model is updated atomically with the+  append — never stale, but tied to the writer's transaction and latency.+  'runCommandWithProjections' runs a command and applies a list of inline+  projections to whatever it emits.+* An 'AsyncProjection' runs later from a subscription draining the event+  log. It carries a 'subscriptionName' for checkpointing and an+  'idempotencyKey' so redelivery is safe; 'applyAsyncProjection' performs+  one application. This decouples the read model from the writer at the+  cost of eventual consistency.++Both ultimately fold events into a SQL read model via a+'Hasql.Transaction.Transaction'; the difference is only /when/ that+transaction runs.+-}+module Keiro.Projection (+    -- * Inline projections+    InlineProjection (..),+    runCommandWithProjections,++    -- * Asynchronous projections+    AsyncProjection (..),+    AsyncApplyOutcome (..),+    applyAsyncProjection,+    applyAsyncProjectionUnfenced,+    pruneAsyncProjectionDedupBefore,+    recordProjectionLag,+)+where++import Contravariant.Extras (contrazip2)+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Error.Static (Error)+import GHC.Stack (HasCallStack)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiki.Core (BoolAlg, RegFile)+import Keiro.Command (CommandError, CommandResult, RunCommandOptions, runCommandWithSqlEvents)+import Keiro.EventStream (EventStream)+import Keiro.EventStream.Validate (ValidatedEventStream)+import Keiro.Prelude+import Keiro.ReadModel (readSubscriptionPosition, storeHeadPosition)+import Keiro.Stream (Stream)+import Keiro.Telemetry (KeiroMetrics)+import Keiro.Telemetry qualified as Telemetry+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Effect.Resource (KirokuStoreResource)+import Kiroku.Store.Error (StoreError)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (EventId (..), GlobalPosition (..), RecordedEvent)+import "hasql-transaction" Hasql.Transaction qualified as Tx+import Prelude qualified++{- | A read-model update applied synchronously with the command that emits+the event. 'apply' receives both the decoded event @co@ and the+'RecordedEvent' the store persisted, and runs in the append transaction.+'name' identifies the projection for diagnostics.+-}+data InlineProjection co = InlineProjection+    { name :: !Text+    , apply :: !(co -> RecordedEvent -> Tx.Transaction ())+    }+    deriving stock (Generic)++{- | A read-model update applied asynchronously by a subscription worker.++* 'name' — identifies the projection for diagnostics.+* 'readModelName' — names the registry row for the model this projection writes.+* 'subscriptionName' — the cursor under which the worker checkpoints its+  progress through the event log.+* 'applyRecorded' — folds one 'RecordedEvent' into the read model.+* 'idempotencyKey' — the 'EventId' used to suppress duplicate application on+  redelivery, making the projection safe to retry.+-}+data AsyncProjection = AsyncProjection+    { name :: !Text+    , readModelName :: !Text+    , subscriptionName :: !Text+    , applyRecorded :: !(RecordedEvent -> Tx.Transaction ())+    , idempotencyKey :: !(RecordedEvent -> EventId)+    }+    deriving stock (Generic)++-- | The database-visible result of one asynchronous projection attempt.+data AsyncApplyOutcome+    = AsyncApplied+    | AsyncDuplicate+    | AsyncFenced+    deriving stock (Generic, Eq, Show)++{- | Run a command and apply every supplied 'InlineProjection' to the events+it emits, all inside the command's append transaction. A projection failure+aborts the whole transaction, so the events and the read-model update commit+together or not at all.+-}+runCommandWithProjections ::+    forall phi rs s ci co es.+    (HasCallStack, IOE :> es, Store :> es, Error StoreError :> es, KirokuStoreResource :> es, BoolAlg phi (RegFile rs, ci), Eq co) =>+    RunCommandOptions ->+    ValidatedEventStream phi rs s ci co ->+    Stream (EventStream phi rs s ci co) ->+    ci ->+    [InlineProjection co] ->+    Eff es (Either CommandError (CommandResult (EventStream phi rs s ci co)))+runCommandWithProjections options eventStream targetStream command projections = do+    result <-+        runCommandWithSqlEvents+            options+            eventStream+            targetStream+            command+            ( \pairs _appendResult ->+                traverse_+                    ( \projection ->+                        traverse_+                            (\(event, recorded) -> (projection ^. #apply) event recorded)+                            pairs+                    )+                    projections+            )+    pure (fmap Prelude.fst result)++{- | Apply one event to a live 'AsyncProjection', returning a distinct outcome+for a successful application, a retained dedup key, or a rebuild fence.++The registry row is read with @FOR SHARE@ inside the same transaction as the+dedup insert and application. A missing row or any status other than @live@+returns 'AsyncFenced' without touching either table. A worker that receives+'AsyncFenced' must not checkpoint past the event: fail or park the delivery and+retry after promotion. Ack-coupled Kiroku delivery preserves the checkpoint+when its handler does not acknowledge success.++The projection's 'idempotencyKey' is inserted into @keiro_projection_dedup@+inside the same transaction as 'applyRecorded'. When that insert conflicts,+the event was already applied within the retained dedup window and the update+is skipped. Use 'pruneAsyncProjectionDedupBefore' only for events older than+the subscription system can redeliver; pruning intentionally re-opens those+events for application if they are replayed later.+-}+applyAsyncProjection :: AsyncProjection -> RecordedEvent -> Tx.Transaction AsyncApplyOutcome+applyAsyncProjection projection recorded = do+    status <-+        Tx.statement+            (projection ^. #readModelName)+            lockReadModelStatusStmt+    case status of+        Just "live" -> applyAsyncProjectionUnfenced projection recorded+        _ -> pure AsyncFenced++{- | Apply one event without consulting the read-model registry fence.++This is exclusively the rebuild replay entry point: it retains normal dedup+semantics while permitting the designated rebuilder to write while the model is+@rebuilding@. Live workers must use 'applyAsyncProjection'.+-}+applyAsyncProjectionUnfenced :: AsyncProjection -> RecordedEvent -> Tx.Transaction AsyncApplyOutcome+applyAsyncProjectionUnfenced projection recorded = do+    inserted <-+        Tx.statement+            (projection ^. #name, eventIdToUuid ((projection ^. #idempotencyKey) recorded))+            insertProjectionDedupStmt+    if inserted+        then do+            (projection ^. #applyRecorded) recorded+            pure AsyncApplied+        else pure AsyncDuplicate++{- | Age out async-projection dedup rows older than the supplied timestamp.++Use this only beyond the subscription system's redelivery window; pruning+re-opens those events for application. It is not a rebuild reset. Supported+rebuilds use 'Keiro.ReadModel.Rebuild.startRebuild', which atomically deletes+only the named projections' keys while fencing writers and resetting the model.+Returns the number of rows pruned.+-}+pruneAsyncProjectionDedupBefore :: (Store :> es) => UTCTime -> Eff es Int64+pruneAsyncProjectionDedupBefore cutoff =+    runTransaction+        $ Tx.statement cutoff pruneProjectionDedupBeforeStmt++{- | Record 'keiro.projection.lag' for one async projection: how many events its+subscription is behind the global log head, computed as the store head global+position minus the subscription's checkpoint position (clamped at 0). A no-op+when no metrics handle is supplied. Call once per drain pass, after applying the+batch, so the gauge reflects the backlog the worker has left to catch up on.++There is no in-library polling drain loop today (the application drives+'applyAsyncProjection' per event), so this is the entry point an application+calls to surface lag for a subscription.+-}+recordProjectionLag ::+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    AsyncProjection ->+    Eff es ()+recordProjectionLag metrics projection = do+    headPos <- storeHeadPosition+    checkpoint <-+        fromMaybe (GlobalPosition 0)+            <$> readSubscriptionPosition (projection ^. #subscriptionName)+    Telemetry.recordProjectionLag metrics (positionGap headPos checkpoint)++-- | The non-negative gap between the log head and a checkpoint, in events.+positionGap :: GlobalPosition -> GlobalPosition -> Int64+positionGap (GlobalPosition headP) (GlobalPosition checkP) = max 0 (headP Prelude.- checkP)++insertProjectionDedupStmt :: Statement (Text, UUID) Bool+insertProjectionDedupStmt =+    preparable+        """+        INSERT INTO keiro.keiro_projection_dedup (projection_name, event_id)+        VALUES ($1, $2)+        ON CONFLICT (projection_name, event_id) DO NOTHING+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.uuid))+        )+        ((> 0) <$> D.rowsAffected)++lockReadModelStatusStmt :: Statement Text (Maybe Text)+lockReadModelStatusStmt =+    preparable+        """+        SELECT status+        FROM keiro.keiro_read_models+        WHERE name = $1+        FOR SHARE+        """+        (E.param (E.nonNullable E.text))+        (D.rowMaybe (D.column (D.nonNullable D.text)))++pruneProjectionDedupBeforeStmt :: Statement UTCTime Int64+pruneProjectionDedupBeforeStmt =+    preparable+        """+        DELETE FROM keiro.keiro_projection_dedup+        WHERE applied_at < $1+        """+        (E.param (E.nonNullable E.timestamptz))+        D.rowsAffected++eventIdToUuid :: EventId -> UUID+eventIdToUuid (EventId value) = value
+ src/Keiro/ReadModel.hs view
@@ -0,0 +1,366 @@+{- | Querying the read side, with explicit consistency.++A 'ReadModel' is a named, versioned SQL projection table plus the query that+reads it. Querying it does more than run SQL: 'runQuery' first verifies the+table's registered schema is current and 'Live' (rejecting a stale or+mid-rebuild model), then honours the requested 'ConsistencyMode' before+running the query in a transaction.++The consistency modes trade freshness against latency:++* 'Strong' — capture the store head position at query start and block until+  the model's subscription cursor reaches it.+* 'Eventual' — query immediately. Read-your-writes is the projection worker's+  responsibility under 'Eventual'.+* 'PositionWait' — block until the model's subscription has caught up to a+  target 'GlobalPosition' (typically the position returned by the command+  the caller just ran), giving read-your-writes against an asynchronous+  projection. 'waitFor' implements the polling loop and times out with+  'ReadModelWaitTimeout'.++Schema lifecycle (registration, status transitions) lives in+"Keiro.ReadModel.Schema", which is re-exported here.++Register each model once at projection startup with 'registerReadModel' before+serving queries. Queries fail with 'ReadModelUnregistered' when startup wiring+has not registered the model; they never create registry rows themselves.+-}+module Keiro.ReadModel (+    -- * Definition+    ReadModel (..),+    qualifiedTableName,++    -- * Consistency+    ConsistencyMode (..),+    StrongScope (..),+    PositionWaitOptions (..),+    defaultStrongWaitOptions,++    -- * Querying+    runQuery,+    runQueryWith,+    waitFor,+    readSubscriptionPosition,+    storeHeadPosition,+    categoryHeadPosition,++    -- * Errors+    ReadModelError (..),++    -- * Schema lifecycle+    module Keiro.ReadModel.Schema,+)+where++import Control.Concurrent (threadDelay)+import Data.Time.Clock (diffUTCTime)+import Data.Vector qualified as Vector+import Effectful (Eff, IOE, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Connection (qualifyTable)+import Keiro.Prelude+import Keiro.ReadModel.Schema+import Keiro.Telemetry (KeiroMetrics, recordProjectionWaitTimeouts)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Read (readAllBackward)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (GlobalPosition (..))+import "hasql-transaction" Hasql.Transaction qualified as Tx+import Prelude qualified++{- | A queryable read-side projection over a query input @q@ and result @r@.++* 'name' — logical identity, also the key in the @keiro_read_models@+  registry.+* 'tableName' — the underlying projection table.+* 'schema' — the PostgreSQL schema the read-model /data/ table lives in. The+  application qualifies its 'query' SQL against this schema (typically via+  'Keiro.Connection.qualifyTable' or 'qualifiedTableName'); Keiro does not+  rewrite 'query'. This is the application's data schema and is entirely+  separate from Keiro's own @keiro@ schema, where the @keiro_read_models@+  registry lives. It is deliberately not persisted (see 'ensureReadModel').+* 'subscriptionName' — the cursor that tracks how far the projection worker+  has consumed the event log; consulted by 'PositionWait'.+* 'version' \/ 'shapeHash' — schema identity; a query fails with+  'ReadModelStaleSchema' if the registered values diverge, forcing a rebuild.+* 'defaultConsistency' — the 'ConsistencyMode' used by 'runQuery'.+* 'strongScope' — the event-log head a 'Strong' query waits for.+* 'query' — the SQL read, as a 'Hasql.Transaction.Transaction'.+-}+data ReadModel q r = ReadModel+    { name :: !Text+    , tableName :: !Text+    , schema :: !Text+    , subscriptionName :: !Text+    , version :: !Int+    , shapeHash :: !Text+    , defaultConsistency :: !ConsistencyMode+    , strongScope :: !StrongScope+    , query :: !(q -> Tx.Transaction r)+    }+    deriving stock (Generic)++{- | The read model's fully-qualified, double-quoted table reference+@"schema"."table"@, for interpolation into the application's projection SQL.+Equal to @'Keiro.Connection.qualifyTable' ('schema' rm) ('tableName' rm)@.+-}+qualifiedTableName :: ReadModel q r -> Text+qualifiedTableName readModel =+    qualifyTable (readModel ^. #schema) (readModel ^. #tableName)++{- | How fresh a read must be before the query runs.++'Strong' waits for the model's subscription to reach the store head captured+at query start according to the model's 'strongScope'. It is intended for+asynchronous read models with a worker advancing that subscription cursor;+inline-only models should use 'Eventual' because they have no subscription+worker to advance while waiting.+'PositionWait' blocks until the projection has caught up to a caller-supplied+target log position (or times out). 'Eventual' queries immediately.+-}+data ConsistencyMode+    = Strong+    | Eventual+    | PositionWait !PositionWaitOptions+    deriving stock (Generic, Eq, Show)++{- | Which log head a 'Strong' read must reach.++'EntireLog' preserves the original behavior and is live only when the model's+subscription observes every event. A category subscription should use+'CategoryHead' with its Kiroku category, so unrelated categories cannot hold+the read behind forever. A model fed by multiple categories should use+'PositionWait' for an explicit write position or 'EntireLog' with a matching+all-stream subscription.++Kiroku currently does not advance category checkpoints on empty fetches. If it+does so in a future release, category-scoped targets may become unnecessary,+but the explicit model contract remains valid.+-}+data StrongScope+    = EntireLog+    | CategoryHead !Text+    deriving stock (Generic, Eq, Show)++{- | Parameters for a 'PositionWait' query.++* 'target' — the 'GlobalPosition' the projection must reach; 'Nothing'+  skips waiting entirely.+* 'timeoutMicros' — give up after this long with 'ReadModelWaitTimeout'.+* 'pollMicros' — delay between subscription-position checks.+-}+data PositionWaitOptions = PositionWaitOptions+    { target :: !(Maybe GlobalPosition)+    , timeoutMicros :: !Int+    , pollMicros :: !Int+    }+    deriving stock (Generic, Eq, Show)++{- | Default wait settings used by 'Strong': wait up to five seconds, polling+every 10ms, for the store head captured at query start.+-}+defaultStrongWaitOptions :: PositionWaitOptions+defaultStrongWaitOptions =+    PositionWaitOptions+        { target = Nothing+        , timeoutMicros = 5000000+        , pollMicros = 10000+        }++-- | Why a read-model query could not run.+data ReadModelError+    = {- | No registry row exists for the model. Register it once at projection+      startup with 'registerReadModel' before serving queries.+      -}+      ReadModelUnregistered !Text+    | {- | The registered schema (version or shape hash) differs from the+      model's current definition: name, expected vs. found version, then+      expected vs. found shape hash. The model must be rebuilt.+      -}+      ReadModelStaleSchema !Text !Int !Int !Text !Text+    | {- | A 'PositionWait' query timed out: model name, target position, and+      the last observed subscription position.+      -}+      ReadModelWaitTimeout !Text !GlobalPosition !GlobalPosition+    | {- | The model is registered but not 'Live' (e.g. rebuilding or+      abandoned): name and current status.+      -}+      ReadModelNotLive !Text !ReadModelStatus+    deriving stock (Generic, Eq, Show)++{- | Query a read model using its 'defaultConsistency'. Validates schema and+liveness first, waits if the mode requires it, then runs the query.+-}+runQuery ::+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    ReadModel q r ->+    q ->+    Eff es (Either ReadModelError r)+runQuery metrics readModel =+    runQueryWith metrics (readModel ^. #defaultConsistency) readModel++{- | Query a read model with an explicit 'ConsistencyMode', overriding its+default. Validates the model's schema and liveness, honours the wait mode,+then runs the query in a transaction.+-}+runQueryWith ::+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    ConsistencyMode ->+    ReadModel q r ->+    q ->+    Eff es (Either ReadModelError r)+runQueryWith metrics consistency readModel input = do+    schemaCheck <- ensureReadModel readModel+    case schemaCheck of+        Left err -> pure (Left err)+        Right () -> do+            waitResult <- waitIfNeeded metrics consistency readModel+            case waitResult of+                Left err -> pure (Left err)+                Right () -> Right <$> runTransaction ((readModel ^. #query) input)++{- | Block until the model's subscription has advanced to @targetPosition@,+polling at 'pollMicros' intervals. Returns @Right ()@ once caught up, or+'ReadModelWaitTimeout' if 'timeoutMicros' elapses first.+-}+waitFor ::+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    PositionWaitOptions ->+    ReadModel q r ->+    GlobalPosition ->+    Eff es (Either ReadModelError ())+waitFor metrics options readModel targetPosition = do+    started <- liftIO getCurrentTime+    poll started (GlobalPosition 0)+  where+    poll started observed = do+        current <- readSubscriptionPosition (readModel ^. #subscriptionName)+        let observed' = fromMaybe observed current+        if observed' >= targetPosition+            then pure (Right ())+            else do+                now <- liftIO getCurrentTime+                let elapsedMicros =+                        Prelude.floor+                            (diffUTCTime now started Prelude.* 1000000)+                if elapsedMicros >= options ^. #timeoutMicros+                    then do+                        -- A genuine give-up: bump keiro.projection.wait.timeouts (no-op+                        -- under a 'Nothing' handle) before surfacing the timeout.+                        recordProjectionWaitTimeouts metrics 1+                        pure+                            (Left (ReadModelWaitTimeout (readModel ^. #name) targetPosition observed'))+                    else do+                        liftIO (threadDelay (options ^. #pollMicros))+                        poll started observed'++-- Note: the read model's 'schema' field is deliberately NOT persisted here. The+-- registry keys on name/version/shapeHash/status (the model's schema identity);+-- where the application's data table physically lives is a deployment/wiring+-- concern, not part of that identity. See EP-4's Decision Log.+ensureReadModel ::+    (Store :> es) =>+    ReadModel q r ->+    Eff es (Either ReadModelError ())+ensureReadModel readModel = do+    found <- lookupReadModel (readModel ^. #name)+    pure $ case found of+        Just metadata -> validateMetadata readModel metadata+        Nothing -> Left (ReadModelUnregistered (readModel ^. #name))++validateMetadata :: ReadModel q r -> ReadModelMetadata -> Either ReadModelError ()+validateMetadata readModel metadata+    | metadata ^. #version /= readModel ^. #version =+        stale+    | metadata ^. #shapeHash /= readModel ^. #shapeHash =+        stale+    | metadata ^. #status /= Live =+        Left (ReadModelNotLive (readModel ^. #name) (metadata ^. #status))+    | otherwise =+        Right ()+  where+    stale =+        Left+            ( ReadModelStaleSchema+                (readModel ^. #name)+                (readModel ^. #version)+                (metadata ^. #version)+                (readModel ^. #shapeHash)+                (metadata ^. #shapeHash)+            )++waitIfNeeded ::+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    ConsistencyMode ->+    ReadModel q r ->+    Eff es (Either ReadModelError ())+waitIfNeeded metrics Strong readModel = do+    target <- case readModel ^. #strongScope of+        EntireLog -> storeHeadPosition+        CategoryHead category -> categoryHeadPosition category+    waitFor metrics (defaultStrongWaitOptions & #target ?~ target) readModel target+waitIfNeeded _ Eventual _ = pure (Right ())+waitIfNeeded metrics (PositionWait options) readModel =+    case options ^. #target of+        Nothing -> pure (Right ())+        Just targetPosition -> waitFor metrics options readModel targetPosition++readSubscriptionPosition ::+    (Store :> es) =>+    Text ->+    Eff es (Maybe GlobalPosition)+readSubscriptionPosition subscriptionName =+    runTransaction+        $ Tx.statement subscriptionName lookupSubscriptionPositionStmt++lookupSubscriptionPositionStmt :: Statement Text (Maybe GlobalPosition)+lookupSubscriptionPositionStmt =+    preparable+        """+        SELECT min(last_seen)+        FROM subscriptions+        WHERE subscription_name = $1+        """+        (E.param (E.nonNullable E.text))+        (D.singleRow (fmap GlobalPosition <$> D.column (D.nullable D.int8)))++{- | The global position of the most recent event in the @$all@ log, or+@GlobalPosition 0@ when the log is empty. 'readAllBackward' treats+@GlobalPosition 0@ as "after everything", so a limit of 1 returns the head.+-}+storeHeadPosition :: (Store :> es) => Eff es GlobalPosition+storeHeadPosition = do+    recent <- readAllBackward (GlobalPosition 0) 1+    pure $ case Vector.toList recent of+        (event : _) -> event ^. #globalPosition+        [] -> GlobalPosition 0++{- | The latest global position originating in a Kiroku category, or+@GlobalPosition 0@ when that category has no events. This deliberately reads+Kiroku's indexed @streams@ and @$all@ membership tables because Kiroku 0.3 does+not export a category-head query.+-}+categoryHeadPosition :: (Store :> es) => Text -> Eff es GlobalPosition+categoryHeadPosition category =+    runTransaction+        $ Tx.statement category categoryHeadPositionStmt++categoryHeadPositionStmt :: Statement Text GlobalPosition+categoryHeadPositionStmt =+    preparable+        """+        SELECT COALESCE(max(se.stream_version), 0)+        FROM streams s+        JOIN stream_events se+          ON se.original_stream_id = s.stream_id+         AND se.stream_id = 0+        WHERE s.category = $1+        """+        (E.param (E.nonNullable E.text))+        (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8)))
+ src/Keiro/ReadModel/Rebuild.hs view
@@ -0,0 +1,196 @@+{- | The supported offline read-model rebuild lifecycle.++Use this checklist rather than composing the low-level status transitions:++1. Call 'Keiro.ReadModel.Schema.registerReadModel' once at projection startup.+   Explicit registration makes misspelled or never-populated models fail with+   'ReadModelUnregistered' instead of appearing healthy.+2. Call 'startRebuild' with every feeding async projection name and the replay+   position. It atomically fences live writers, takes queries offline, truncates+   the data table, clears the named dedup keys, and resets the subscription+   checkpoint, preventing live/replay interleaving and all-deduplicated rebuilds.+3. Replay through 'Keiro.Projection.applyAsyncProjectionUnfenced'. This is the+   only apply path allowed to bypass the live-writer fence, while retaining+   deduplication inside the designated rebuild.+4. After replay catches up and application-specific verification succeeds, call+   'finishRebuild' with the same projection names and replay position. Its+   promotion guard refuses to serve a non-empty-log rebuild that applied no+   events.+5. If replay or verification fails, call 'abandonRebuild'. Queries remain+   unavailable instead of exposing partial data; repair or restore the table+   before beginning another rebuild.++Normal workers continue to call 'Keiro.Projection.applyAsyncProjection'. Its+registry lock fences them automatically while the model is rebuilding, but they+must not checkpoint an 'Keiro.Projection.AsyncFenced' event. Keiro does not yet+provide a shadow-table or online cutover mechanism; applications that need+zero-downtime rebuilds must build that orchestration above this lifecycle API.+-}+module Keiro.ReadModel.Rebuild (+    RebuildError (..),+    startRebuild,+    finishRebuild,+    rebuild,+    promote,+    abandonRebuild,+)+where++import Contravariant.Extras (contrazip2)+import Data.Text.Encoding qualified as TE+import Effectful (Eff, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Prelude+import Keiro.ReadModel+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (GlobalPosition (..))+import "hasql-transaction" Hasql.Transaction qualified as Tx++-- | Why a rebuild could not be promoted.+data RebuildError+    = {- | The model name and current store head when a rebuild started before+      existing events but applied none of its feeding projections.+      -}+      RebuildProducedNoApplies !Text !GlobalPosition+    deriving stock (Generic, Eq, Show)++{- | Atomically take a model offline, truncate its data table, clear the dedup+keys for its feeding async projections, and reset every member of its+subscription to the supplied replay position.++The registry transition runs first and holds the row lock that+'Keiro.Projection.applyAsyncProjection' uses as its writer fence. PostgreSQL+keeps the table truncate transactional. Kiroku's public checkpoint save is+monotonic, so this helper deliberately resets @subscriptions.last_seen@+directly inside the same fenced transaction.+-}+startRebuild ::+    (Store :> es) =>+    ReadModel q r ->+    [Text] ->+    GlobalPosition ->+    Eff es ReadModelMetadata+startRebuild readModel projectionNames replayFrom =+    runTransaction $ do+        metadata <- transitionReadModelTxFor readModel Rebuilding+        Tx.sql (TE.encodeUtf8 ("TRUNCATE TABLE " <> qualifiedTableName readModel))+        unless (null projectionNames) $+            Tx.statement projectionNames deleteProjectionDedupStmt+        Tx.statement+            (readModel ^. #subscriptionName, globalPositionToInt replayFrom)+            resetSubscriptionCheckpointStmt+        pure metadata++{- | Promote a completed rebuild in the same transaction as its safety check.++When async projection names are supplied, a store head beyond @replayFrom@+requires at least one new dedup row. 'startRebuild' deleted those rows, so their+count is the model-independent number of projection applications during this+rebuild. An empty projection-name list denotes an inline-only model and skips+the guard because no async dedup rows can exist for it.+-}+finishRebuild ::+    (Store :> es) =>+    ReadModel q r ->+    [Text] ->+    GlobalPosition ->+    Eff es (Either RebuildError ReadModelMetadata)+finishRebuild readModel projectionNames replayFrom =+    runTransaction $ do+        headPosition <- Tx.statement () storeHeadPositionStmt+        applyCount <-+            if null projectionNames+                then pure 0+                else Tx.statement projectionNames countProjectionDedupStmt+        if null projectionNames || applyCount > 0 || headPosition <= replayFrom+            then Right <$> transitionReadModelTxFor readModel Live+            else pure (Left (RebuildProducedNoApplies (readModel ^. #name) headPosition))++{- | Low-level status transition only. It does not truncate data, reset dedup+keys or checkpoints, or establish the complete rebuild workflow. Use+'startRebuild' for supported rebuilds.+-}+rebuild :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata+rebuild readModel =+    markRebuilding+        (readModel ^. #name)+        (readModel ^. #version)+        (readModel ^. #shapeHash)++{- | Low-level status transition only. It bypasses the empty-rebuild guard. Use+'finishRebuild' to promote a supported rebuild.+-}+promote :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata+promote readModel =+    markLive+        (readModel ^. #name)+        (readModel ^. #version)+        (readModel ^. #shapeHash)++-- | Mark a model 'Abandoned', backing out of an in-progress rebuild.+abandonRebuild :: (Store :> es) => ReadModel q r -> Eff es ReadModelMetadata+abandonRebuild readModel =+    markAbandoned+        (readModel ^. #name)+        (readModel ^. #version)+        (readModel ^. #shapeHash)++transitionReadModelTxFor :: ReadModel q r -> ReadModelStatus -> Tx.Transaction ReadModelMetadata+transitionReadModelTxFor readModel status =+    transitionReadModelTx+        (readModel ^. #name)+        (readModel ^. #version)+        (readModel ^. #shapeHash)+        status++deleteProjectionDedupStmt :: Statement [Text] ()+deleteProjectionDedupStmt =+    preparable+        """+        DELETE FROM keiro.keiro_projection_dedup+        WHERE projection_name = ANY($1)+        """+        (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+        D.noResult++countProjectionDedupStmt :: Statement [Text] Int64+countProjectionDedupStmt =+    preparable+        """+        SELECT count(*)+        FROM keiro.keiro_projection_dedup+        WHERE projection_name = ANY($1)+        """+        (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+        (D.singleRow (D.column (D.nonNullable D.int8)))++resetSubscriptionCheckpointStmt :: Statement (Text, Int64) ()+resetSubscriptionCheckpointStmt =+    preparable+        """+        UPDATE subscriptions+        SET last_seen = $2, updated_at = now()+        WHERE subscription_name = $1+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int8))+        )+        D.noResult++storeHeadPositionStmt :: Statement () GlobalPosition+storeHeadPositionStmt =+    preparable+        """+        SELECT COALESCE(max(stream_version), 0)+        FROM stream_events+        WHERE stream_id = 0+        """+        E.noParams+        (D.singleRow (GlobalPosition <$> D.column (D.nonNullable D.int8)))++globalPositionToInt :: GlobalPosition -> Int64+globalPositionToInt (GlobalPosition position) = position
+ src/Keiro/ReadModel/Schema.hs view
@@ -0,0 +1,205 @@+{- | The @keiro_read_models@ registry: schema identity and lifecycle status.++Every read model explicitly registers a row at projection startup recording its 'version', 'shapeHash', and+'ReadModelStatus'. The registry is what lets 'Keiro.ReadModel.runQuery'+refuse to serve a model whose code-side schema has drifted from the table on+disk, or one that is mid-rebuild. The status transitions ('markRebuilding',+'markLive', 'markAbandoned') drive the rebuild workflow in+"Keiro.ReadModel.Rebuild".++All operations run as single-statement 'Hasql.Transaction.Transaction's+against the @keiro_read_models@ table; an unrecognized stored status decodes+to 'UnknownStatus' so callers see the raw database value instead of a silent+fallback.+-}+module Keiro.ReadModel.Schema (+    -- * Metadata+    ReadModelMetadata (..),+    ReadModelStatus (..),++    -- * Registration and lookup+    registerReadModel,+    lookupReadModel,++    -- * Status transitions+    markRebuilding,+    markLive,+    markAbandoned,+    transitionReadModelTx,+)+where++import Contravariant.Extras (contrazip3, contrazip4)+import Effectful (Eff, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Prelude+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import "hasql-transaction" Hasql.Transaction qualified as Tx+import Prelude qualified++{- | Lifecycle status of a registered read model.++* 'Live' — current and queryable.+* 'Rebuilding' — being repopulated from the event log; not yet queryable.+* 'Paused' — temporarily not served.+* 'Abandoned' — a rebuild that was given up on.+* 'UnknownStatus' — a database value this library version does not recognize.+-}+data ReadModelStatus+    = Live+    | Rebuilding+    | Paused+    | Abandoned+    | UnknownStatus !Text+    deriving stock (Generic, Eq, Show)++{- | One row of the @keiro_read_models@ registry: a model's name, schema+identity ('version' and 'shapeHash'), the time it was last (re)built, and+its current 'status'.+-}+data ReadModelMetadata = ReadModelMetadata+    { name :: !Text+    , version :: !Int+    , shapeHash :: !Text+    , lastBuiltAt :: !(Maybe UTCTime)+    , status :: !ReadModelStatus+    }+    deriving stock (Generic, Eq, Show)++{- | Register a read model once at projection startup, inserting a 'Live' row+if none exists. Querying never performs this registration automatically, so+deployments that previously relied on their first query to register must add+this startup call. Idempotent:+an existing registration is returned unchanged (the @version@ and+@shapeHash@ are /not/ overwritten), so a query can compare them and detect+schema drift.+-}+registerReadModel :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata+registerReadModel name version shapeHash =+    runTransaction+        $ Tx.statement+            (name, Prelude.fromIntegral version, shapeHash)+            registerReadModelStmt++-- | Look up a read model's registry row by name, if it exists.+lookupReadModel :: (Store :> es) => Text -> Eff es (Maybe ReadModelMetadata)+lookupReadModel name =+    runTransaction+        $ Tx.statement name lookupReadModelStmt++{- | Upsert the registry row to 'Rebuilding' at the given schema identity.+Marks the model as being repopulated so queries stop serving it until+'markLive'.+-}+markRebuilding :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata+markRebuilding name version shapeHash =+    runTransaction $ transitionReadModelTx name version shapeHash Rebuilding++{- | Upsert the registry row to 'Live' at the given schema identity, stamping+@last_built_at@. Makes the model queryable again after a rebuild.+-}+markLive :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata+markLive name version shapeHash =+    runTransaction $ transitionReadModelTx name version shapeHash Live++{- | Upsert the registry row to 'Abandoned' at the given schema identity,+recording that a rebuild was given up on.+-}+markAbandoned :: (Store :> es) => Text -> Int -> Text -> Eff es ReadModelMetadata+markAbandoned name version shapeHash =+    runTransaction $ transitionReadModelTx name version shapeHash Abandoned++{- | Transaction-composable form of a registry status transition. Rebuild+orchestration uses this form so the status row lock, table reset, dedup reset,+and checkpoint reset share one database transaction.+-}+transitionReadModelTx :: Text -> Int -> Text -> ReadModelStatus -> Tx.Transaction ReadModelMetadata+transitionReadModelTx name version shapeHash status =+    Tx.statement+        (name, Prelude.fromIntegral version, shapeHash, statusToText status)+        transitionReadModelStmt++registerReadModelStmt :: Statement (Text, Int64, Text) ReadModelMetadata+registerReadModelStmt =+    preparable+        """+        INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at)+        VALUES ($1, $2, $3, 'live', now())+        ON CONFLICT (name) DO UPDATE+          SET name = EXCLUDED.name+        RETURNING name, version, shape_hash, last_built_at, status+        """+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.text))+        )+        readModelMetadataSingle++lookupReadModelStmt :: Statement Text (Maybe ReadModelMetadata)+lookupReadModelStmt =+    preparable+        """+        SELECT name, version, shape_hash, last_built_at, status+        FROM keiro.keiro_read_models+        WHERE name = $1+        """+        (E.param (E.nonNullable E.text))+        (D.rowMaybe readModelMetadataDecoder)++transitionReadModelStmt :: Statement (Text, Int64, Text, Text) ReadModelMetadata+transitionReadModelStmt =+    preparable+        """+        INSERT INTO keiro.keiro_read_models (name, version, shape_hash, status, last_built_at, updated_at)+        VALUES ($1, $2, $3, $4, now(), now())+        ON CONFLICT (name) DO UPDATE+          SET version = EXCLUDED.version,+              shape_hash = EXCLUDED.shape_hash,+              status = EXCLUDED.status,+              last_built_at = CASE+                WHEN EXCLUDED.status = 'live' THEN now()+                ELSE keiro_read_models.last_built_at+              END,+              updated_at = now()+        RETURNING name, version, shape_hash, last_built_at, status+        """+        ( contrazip4+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        readModelMetadataSingle++readModelMetadataSingle :: D.Result ReadModelMetadata+readModelMetadataSingle =+    D.singleRow readModelMetadataDecoder++readModelMetadataDecoder :: D.Row ReadModelMetadata+readModelMetadataDecoder =+    ReadModelMetadata+        <$> D.column (D.nonNullable D.text)+        <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nullable D.timestamptz)+        <*> (statusFromText <$> D.column (D.nonNullable D.text))++statusToText :: ReadModelStatus -> Text+statusToText = \case+    Live -> "live"+    Rebuilding -> "rebuilding"+    Paused -> "paused"+    Abandoned -> "abandoned"+    UnknownStatus raw -> raw++statusFromText :: Text -> ReadModelStatus+statusFromText = \case+    "live" -> Live+    "rebuilding" -> Rebuilding+    "paused" -> Paused+    "abandoned" -> Abandoned+    raw -> UnknownStatus raw
+ src/Keiro/Router.hs view
@@ -0,0 +1,425 @@+{- | Stateless, content-based routing of events to commands.++A 'Router' is the stateless sibling of+'Keiro.ProcessManager.ProcessManager': for each incoming event it resolves+a data-dependent set of target streams /effectfully/ (typically via a+read-model query) and dispatches one command to each. Dispatch is+idempotent per resolved target identity: every command is appended under a+target-name-keyed deterministic id, and store-level duplicate rejections are+confirmed against that target before becoming a benign+'PMCommandDuplicate'. Redelivery therefore deduplicates every target resolved+again, regardless of target order. Because resolution is effectful, the target+set may drift between attempts; dispatches accumulate as the union of those+attempts, so callers that require one exact set must keep resolution stable for+a source event.++Use 'runRouterOnce' to dispatch a single event, or 'runRouterWorker' to run+the router as a live subscription draining a Shibuya adapter. Its retry and+source-event dead-letter contract is the same bounded Kiroku contract described+by "Keiro.ProcessManager": five total deliveries by default, followed by a+@kiroku.dead_letters@ write and atomic checkpoint advance.++A router's 'key' can join events from different source streams just as a+process manager's @correlate@ function can. The same ordering rule applies:+same-stream order is preserved, but different streams have no relative+business-order guarantee and may run concurrently under sharding. Keep routed+logic order-insensitive; see "Keiro.ProcessManager" for the worked example.+Each resolved target command (with its inline projections) commits in its own+transaction, so fan-out is idempotent rather than all-target atomic.+-}+module Keiro.Router (+    -- * Definition+    Router (..),+    RouterResult (..),++    -- * Idempotency+    deterministicRouterCommandId,++    -- * Running+    runRouterOnce,+    runRouterWorkerWith,+    runRouterWorker,+)+where++import Data.ByteString qualified as ByteString+import Data.ByteString.Char8 qualified as ByteString.Char8+import Data.Coerce (coerce)+import Data.Map.Strict qualified as Map+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Data.Traversable (mapAccumL)+import Data.UUID qualified as UUID+import Data.UUID.V5 qualified as UUID.V5+import Effectful (Eff, IOE, (:>))+import Effectful.Error.Static (Error, tryError)+import GHC.Stack (HasCallStack)+import Keiki.Core (BoolAlg, RegFile)+import Keiro.Command (CommandError (..), RunCommandOptions)+import Keiro.DeadLetter (DispatcherKind (..))+import Keiro.EventStream (EventStream)+import Keiro.EventStream.Validate (ValidatedEventStream, unvalidated)+import Keiro.Prelude+import Keiro.ProcessManager (+    DispatchFailure (..),+    PMCommand (..),+    PMCommandResult (..),+    PoisonPolicy (..),+    WorkerOptions (..),+    ackForCommandError,+    confirmBenignDuplicate,+    decideForFailures,+    defaultWorkerOptions,+    deterministicCommandId,+    eventAlreadyIn,+ )+import Keiro.Projection (InlineProjection, runCommandWithProjections)+import Keiro.Stream (Stream)+import Keiro.Telemetry (recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Effect.Resource (KirokuStoreResource)+import Kiroku.Store.Error (StoreError (..))+import Kiroku.Store.Types (EventId (..), RecordedEvent, StreamName (..))+import Shibuya.Adapter (Adapter (..))+import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..))+import Shibuya.Core.AckHandle (AckHandle (..))+import Shibuya.Core.Ingested (Ingested (..))+import Shibuya.Core.Types (Attempt (..), Envelope (..))+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Streamly+import Prelude (filter, fromIntegral, length, snd, zip, (+))++{- | A stateless, content-based router (in the Enterprise Integration Patterns+sense): for each incoming event it resolves a data-dependent set of target+streams /effectfully/ and dispatches one command to each.++This is the stateless counterpart of 'Keiro.ProcessManager.ProcessManager'. It+has no manager state stream, no @correlate@, and no self-directed command. Its+sole new capability over the process manager is that target resolution runs in+@Eff es@ — typically a read-model query via 'Keiro.ReadModel.runQuery' — so the+fan-out set can be /looked up/ rather than computed purely from the event.++Dispatch is idempotent by construction: each target command is appended under a+deterministic identifier derived from @(name, key input, source event id,+resolved target stream name, occurrence)@ (see+'deterministicRouterCommandId'), pre-checked with 'eventAlreadyIn', and the+store's @DuplicateEvent@ rejection is confirmed against the target stream+before it is treated as benign. A redelivery deduplicates every target it+resolves again even if target order or membership changed. A target resolved+only on an earlier attempt keeps its immutable dispatch, and a newly resolved+target is dispatched on the later attempt; the cumulative set is therefore the+union of attempt outputs. Keep 'resolve' stable for a source event when the+exact recipient set matters.++Each dispatch also runs 'targetProjections' for the target aggregate in the same+append transaction. The function receives the concrete target stream so callers can+build projections closed over stream-local keys. Return @[]@ to preserve+append-only dispatch.+-}+data Router input targetPhi targetRs targetState targetCi targetCo es = Router+    { name :: !Text+    -- ^ Stable identifier; part of every dispatched command's deterministic id.+    , key :: !(input -> Text)+    -- ^ Correlation string for the source event (e.g. the transaction id).+    , resolve :: !(input -> Eff es [PMCommand targetCi])+    {- ^ The effectful seam: compute the data-dependent target set, typically+    @runQuery readModel q@.+    -}+    , targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo)+    -- ^ The aggregate every resolved command is dispatched to.+    , targetProjections :: !(Stream targetCi -> [InlineProjection targetCo])+    {- ^ Inline projections for the target aggregate, run in the same transaction+    as each dispatched command's append. Return @[]@ for append-only dispatch.+    -}+    }+    deriving stock (Generic)++{- | The outcome of a single 'runRouterOnce' invocation: one+'PMCommandResult' per resolved target, in resolution order.++Unlike 'Keiro.ProcessManager.ProcessManagerResult' there is no manager-state+result, because a router has no state stream. A failed dispatch surfaces as a+'PMCommandFailed' element rather than an outer 'Either'.+-}+newtype RouterResult target = RouterResult+    { commandResults :: [PMCommandResult target]+    }+    deriving stock (Generic, Eq, Show)++{- | Derive a stable, collision-resistant 'EventId' for a router dispatch from+@(router name, key input, source event id, resolved target stream name,+occurrence)@ via a v5 UUID.++Unlike 'Keiro.ProcessManager.deterministicCommandId' (which the process manager+still uses, soundly, because its command list is a pure function of the input),+the router keys the id by the target's identity rather than its position in the+resolved list: 'resolve' is effectful, so a redelivery may see the same targets+in a different order or a drifted set, and a positional id would then point at+the wrong target. The @occurrence@ is the index among commands in the same+resolve batch that address the same target stream (0 for the first), so+resolving the same target twice in one batch still yields distinct ids.++The v5 name encodes every text field as length-prefixed UTF-8. This avoids both+delimiter ambiguity when names contain colons and character truncation for+non-ASCII names.+-}+deterministicRouterCommandId :: Text -> Text -> EventId -> StreamName -> Int -> EventId+deterministicRouterCommandId routerName correlationId sourceEventId targetStreamName occurrence =+    EventId+        $ UUID.V5.generateNamed UUID.V5.namespaceURL+        $ ByteString.unpack+        $ ByteString.concat+        $ fmap+            encodeField+            [ "keiro"+            , "router"+            , routerName+            , correlationId+            , UUID.toText (coerce sourceEventId)+            , coerce targetStreamName+            , Text.pack (show occurrence)+            ]+  where+    encodeField field =+        let bytes = Text.Encoding.encodeUtf8 field+         in ByteString.concat+                [ ByteString.Char8.pack (show (ByteString.length bytes))+                , ByteString.singleton 58+                , bytes+                ]++{- | Resolve the targets for one source event, then dispatch one command per+target with crash-safe, target-identity idempotency.++Unlike 'Keiro.ProcessManager.runProcessManagerOnce', whose pure command list+can safely use positional ids, a router derives each id from the resolved+target stream name and its same-stream occurrence. It skips ids already in the+target stream, otherwise runs 'Keiro.Projection.runCommandWithProjections', and+folds a @DuplicateEvent@ rejection only after confirming the attempted id is in+that target stream.++Returns 'RouterResult' directly (no outer @Either CommandError@) because — unlike+the process manager — there is no manager-state append that can fail before+dispatch.+-}+runRouterOnce ::+    forall input targetPhi targetRs targetState targetCi targetCo es.+    ( HasCallStack+    , IOE :> es+    , Store :> es+    , Error StoreError :> es+    , KirokuStoreResource :> es+    , BoolAlg targetPhi (RegFile targetRs, targetCi)+    , Eq targetCo+    ) =>+    RunCommandOptions ->+    Router input targetPhi targetRs targetState targetCi targetCo es ->+    RecordedEvent ->+    input ->+    Eff es (RouterResult (EventStream targetPhi targetRs targetState targetCi targetCo))+runRouterOnce options router sourceEvent input = do+    let correlationId = (router ^. #key) input+    commands <- (router ^. #resolve) input+    let named =+            [ (streamNameOf command, command)+            | command <- commands+            ]+        annotated = snd (mapAccumL occurrenceStep Map.empty (zip [0 ..] named))+        occurrenceStep seen (legacyIndex, (targetStreamName, command)) =+            let occurrence = Map.findWithDefault 0 targetStreamName seen+             in ( Map.insert targetStreamName (occurrence + 1) seen+                , (legacyIndex, occurrence, targetStreamName, command)+                )+    results <-+        traverse+            (dispatchCommand correlationId (sourceEvent ^. #eventId))+            annotated+    pure (RouterResult results)+  where+    streamNameOf command =+        ((unvalidated (router ^. #targetEventStream)) ^. #resolveStreamName)+            (retarget (command ^. #target))++    dispatchCommand correlationId sourceEventId (legacyIndex, occurrence, targetStreamName, command) = do+        let commandId =+                deterministicRouterCommandId+                    (router ^. #name)+                    correlationId+                    sourceEventId+                    targetStreamName+                    occurrence+            -- Transition: dispatches written by keiro versions that derived+            -- positional ids must still dedup across the upgrade. Remove in a+            -- later release after the compatibility window closes.+            legacyCommandId =+                deterministicCommandId+                    (router ^. #name)+                    correlationId+                    sourceEventId+                    legacyIndex+            targetOptions = options & #eventIds .~ [commandId]+            targetEventStream = router ^. #targetEventStream+            targetStream = retarget (command ^. #target)+        commandAlreadyProcessed <- eventAlreadyIn options targetStreamName commandId+        legacyAlreadyProcessed <-+            if commandAlreadyProcessed+                then pure False+                else eventAlreadyIn options targetStreamName legacyCommandId+        if commandAlreadyProcessed+            then pure (PMCommandDuplicate commandId)+            else+                if legacyAlreadyProcessed+                    then pure (PMCommandDuplicate legacyCommandId)+                    else do+                        outcome <-+                            runCommandWithProjections+                                targetOptions+                                targetEventStream+                                targetStream+                                (command ^. #command)+                                ((router ^. #targetProjections) (command ^. #target))+                        case outcome of+                            Right result -> pure (PMCommandAppended result)+                            Left err -> do+                                benign <- confirmBenignDuplicate targetStreamName commandId err+                                pure $ if benign then PMCommandDuplicate commandId else PMCommandFailed targetStreamName err++    retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo)+    retarget = coerce++{- | Run a 'Router' as a live subscription over a Shibuya 'Adapter'.++Mirrors 'Keiro.ProcessManager.runProcessManagerWorker': it drains the adapter's+message stream, decoding each message to a @(RecordedEvent, input)@ pair and+dispatching it through 'runRouterOnce'.++Ack policy (see this plan's Decision Log):++  * a message that fails to decode follows the configured 'PoisonPolicy'+    (default: 'AckHalt' @HaltFatal@);+  * otherwise, after dispatch, if every 'PMCommandResult' is+    'PMCommandAppended' or 'PMCommandDuplicate' the message finalizes 'AckOk';+  * if any dispatch is 'PMCommandFailed', transient failures finalize+    'AckRetry', systemic deterministic failures finalize @AckHalt+    (HaltFatal …)@, and rejection-class failures follow+    'RejectedCommandPolicy'.++Benign domain rejections (a target aggregate refusing a "check" command because+no edge matches) must be modeled as /total/ transitions in the keiki transducer+(an ε-complement self-loop) so they never surface as 'PMCommandFailed' and+therefore never wedge the worker. When the rejection is genuinely+data-dependent, 'RejectedDeadLetter' persists a queryable+"Keiro.DeadLetter.DispatchDeadLetter" and acknowledges the source event;+'RejectedSkip' acknowledges and records only the metric. 'RejectedHalt' remains+the default.++The worker invokes each ingested message's 'Shibuya.Core.AckHandle.AckHandle'+@finalize@ exactly once with the decision, so the decision reaches the adapter.+Use 'runRouterWorkerWith' to override poison-message handling, rejected-command+handling, transient retry delay, or dispatch metrics. On a Kiroku-backed+adapter, 'AckRetry' remains bounded by the subscription @RetryPolicy@ (five+total deliveries by default). Exhaustion records the source event in+@kiroku.dead_letters@ with reason kind @max_attempts_exceeded@ and advances the+checkpoint. @KirokuAdapterConfig@ does not currently expose @retryPolicy@;+install 'Keiro.Telemetry.kirokuEventBridge' on Kiroku's @eventHandler@ to observe+the terminal event. The configurable sharded path forwards+@ShardedWorkerOptions.retryPolicy@ through the same Kiroku ladder; see+"Keiro.Subscription.Shard.Worker".+-}+runRouterWorker ::+    forall msg input targetPhi targetRs targetState targetCi targetCo es.+    ( HasCallStack+    , IOE :> es+    , Store :> es+    , Error StoreError :> es+    , KirokuStoreResource :> es+    , BoolAlg targetPhi (RegFile targetRs, targetCi)+    , Eq targetCo+    ) =>+    RunCommandOptions ->+    Router input targetPhi targetRs targetState targetCi targetCo es ->+    Adapter es msg ->+    (msg -> Maybe (RecordedEvent, input)) ->+    Eff es ()+runRouterWorker =+    runRouterWorkerWith defaultWorkerOptions++runRouterWorkerWith ::+    forall msg input targetPhi targetRs targetState targetCi targetCo es.+    ( HasCallStack+    , IOE :> es+    , Store :> es+    , Error StoreError :> es+    , KirokuStoreResource :> es+    , BoolAlg targetPhi (RegFile targetRs, targetCi)+    , Eq targetCo+    ) =>+    WorkerOptions es msg ->+    RunCommandOptions ->+    Router input targetPhi targetRs targetState targetCi targetCo es ->+    Adapter es msg ->+    (msg -> Maybe (RecordedEvent, input)) ->+    Eff es ()+runRouterWorkerWith workerOptions options router Adapter{source = adapterSource} decodeMessage =+    Streamly.fold Fold.drain+        $ Streamly.mapM handleIngested adapterSource+  where+    handleIngested :: Ingested es msg -> Eff es AckDecision+    handleIngested Ingested{envelope = env@Envelope{payload = message}, ack = AckHandle finalizeAck} = do+        decision <- case decodeMessage message of+            Nothing -> decideForPoison "router worker could not decode message" env+            Just (recorded, input) -> do+                let correlationId = (router ^. #key) input+                    attemptCount = envelopeAttemptCount env+                outcome <- tryError @StoreError (runRouterOnce options router recorded input)+                case outcome of+                    Left (_, storeErr) -> do+                        recordDispatchFailed (workerOptions ^. #metrics) 1+                        pure (ackForCommandError (workerOptions ^. #transientRetryDelay) (StoreFailed storeErr))+                    Right (RouterResult results) -> ackDecisionFor recorded correlationId attemptCount results+        finalizeAck decision+        pure decision++    ackDecisionFor :: RecordedEvent -> Text -> Int -> [PMCommandResult target] -> Eff es AckDecision+    ackDecisionFor sourceEvent correlationId attemptCount results = do+        let duplicateCount = commandDuplicateCount results+            failures =+                [ DispatchFailure emitIndex targetStreamName err+                | (emitIndex, PMCommandFailed targetStreamName err) <- zip [0 ..] results+                ]+        recordDispatchDuplicate (workerOptions ^. #metrics) duplicateCount+        recordDispatchFailed (workerOptions ^. #metrics) (fromIntegral (length failures))+        decideForFailures+            workerOptions+            DispatcherRouter+            (router ^. #name)+            correlationId+            sourceEvent+            attemptCount+            failures++    commandDuplicateCount :: [PMCommandResult target] -> Int64+    commandDuplicateCount =+        fromIntegral . length . filter isDuplicateResult+      where+        isDuplicateResult = \case+            PMCommandDuplicate{} -> True+            _ -> False++    decideForPoison :: Text -> Envelope msg -> Eff es AckDecision+    decideForPoison reason env = do+        recordDispatchPoison (workerOptions ^. #metrics) 1+        case workerOptions ^. #poisonPolicy of+            PoisonHalt -> pure (AckHalt (HaltFatal reason))+            PoisonSkip callback -> do+                callback env+                pure AckOk+            PoisonDeadLetter callback -> do+                callback env+                pure (AckDeadLetter (InvalidPayload reason))++    envelopeAttemptCount :: Envelope msg -> Int+    envelopeAttemptCount env =+        case env ^. #attempt of+            Nothing -> 1+            Just (Attempt attempt) -> fromIntegral attempt + 1
+ src/Keiro/Snapshot.hs view
@@ -0,0 +1,168 @@+{- | Snapshots: skipping replay by persisting folded aggregate state.++A snapshot stores an aggregate's @(state, registers)@ at a known stream+version so hydration can start there instead of replaying the whole event+log. 'hydrateWithSnapshot' loads the latest compatible snapshot for a+stream (returning a 'SnapshotSeed' the command runner replays /forward/+from), and 'writeSnapshot' persists one after an append when the stream's+'Keiro.EventStream.SnapshotPolicy' fires.++Compatibility is gated by the version and register-file shape hash of the+'StateCodec': a snapshot is only loaded when both match the current codec, so a+change to the snapshot encoding or to the register layout transparently+falls back to a full replay rather than decoding stale bytes. The JSON+encoding lives in "Keiro.Snapshot.Codec" and the SQL storage in+"Keiro.Snapshot.Schema", both re-exported here.++Snapshot version non-regression applies only while the codec version and shape+hash stay the same. A writer with either discriminant changed may replace a+higher-version row, allowing codec rollback to recover. In a mixed-version+deployment incompatible writers can therefore thrash the one row per stream+and repeatedly force full replay; this affects performance, not correctness.+-}+module Keiro.Snapshot (+    -- * Hydration seed+    SnapshotSeed (..),+    SnapshotMissReason (..),+    SnapshotLookup (..),+    lookupSnapshotSeed,+    hydrateWithSnapshot,+    encodeSnapshotStrict,+    writeSnapshotEncoded,+    writeSnapshot,++    -- * State codec and storage+    module Keiro.Snapshot.Codec,+    module Keiro.Snapshot.Schema,+)+where++import Control.DeepSeq (force)+import Control.Exception (ErrorCall, evaluate, try)+import Effectful (Eff, (:>))+import Keiki.Core (RegFile)+import Keiro.EventStream (StateCodec)+import Keiro.Prelude+import Keiro.Snapshot.Codec+import Keiro.Snapshot.Schema+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Read (lookupStreamId)+import Kiroku.Store.Types (StreamId, StreamName, StreamVersion)++{- | A decoded snapshot the command runner replays forward from: the folded+'state' and 'registers' as of 'streamVersion'. Hydration reads only the+events after 'streamVersion' instead of the entire stream.+-}+data SnapshotSeed rs s = SnapshotSeed+    { state :: !s+    , registers :: !(RegFile rs)+    , streamVersion :: !StreamVersion+    }+    deriving stock (Generic)++-- | Why a snapshot lookup produced no usable hydration seed.+data SnapshotMissReason+    = SnapshotNoStream+    | SnapshotNotFound+    | SnapshotDecodeFailed !Text+    deriving stock (Eq, Show, Generic)++-- | The observable result of looking up and decoding an aggregate snapshot.+data SnapshotLookup rs s+    = SnapshotUnavailable !SnapshotMissReason+    | SnapshotHit !(SnapshotSeed rs s)+    deriving stock (Generic)++{- | Look up the latest compatible snapshot and retain the reason when no+usable seed exists. A matching row that fails to decode is distinguished from+a missing stream or row so callers can report the persistent fallback.+-}+lookupSnapshotSeed ::+    (Store :> es) =>+    StreamName ->+    StateCodec (s, RegFile rs) ->+    Eff es (SnapshotLookup rs s)+lookupSnapshotSeed streamName codec = do+    streamId <- lookupStreamId streamName+    case streamId of+        Nothing -> pure (SnapshotUnavailable SnapshotNoStream)+        Just foundStreamId -> do+            row <- lookupSnapshot foundStreamId (codec ^. #stateCodecVersion) (codec ^. #shapeHash)+            pure $ case row of+                Nothing -> SnapshotUnavailable SnapshotNotFound+                Just snapshot ->+                    case (codec ^. #decode) (snapshot ^. #state) of+                        Left message -> SnapshotUnavailable (SnapshotDecodeFailed message)+                        Right (state, registers) ->+                            SnapshotHit+                                SnapshotSeed+                                    { state = state+                                    , registers = registers+                                    , streamVersion = snapshot ^. #streamVersion+                                    }++{- | Load the latest snapshot compatible with @codec@ for the named stream.++Returns 'Nothing' — meaning "replay from the beginning" — when the stream+has no id yet, has no snapshot at the codec's version and shape hash, or has+a snapshot whose bytes fail to decode. Decode failure is treated as a benign+miss rather than an error, so a corrupt or stale snapshot never blocks+hydration.+-}+hydrateWithSnapshot ::+    (Store :> es) =>+    StreamName ->+    StateCodec (s, RegFile rs) ->+    Eff es (Maybe (SnapshotSeed rs s))+hydrateWithSnapshot streamName codec = do+    lookupSnapshotSeed streamName codec <&> \case+        SnapshotUnavailable _ -> Nothing+        SnapshotHit seed -> Just seed++{- | Strictly encode @state@ with @codec@, forcing the complete JSON value and+returning an 'ErrorCall' raised by a partial encoder or an uninitialized keiki+register. Other exception types deliberately remain visible to the caller.+-}+encodeSnapshotStrict :: StateCodec state -> state -> IO (Either ErrorCall Value)+encodeSnapshotStrict codec state =+    try @ErrorCall (evaluate (force ((codec ^. #encode) state)))++{- | Upsert a JSON value that has already been encoded and forced. Keeping this+separate from 'writeSnapshot' lets post-commit callers prove encoding is safe+before they touch the store. For a fixed codec version and shape hash, stale+versions are ignored. A different codec version or shape hash may replace a+higher-version row to permit codec rollback; see the module header.+-}+writeSnapshotEncoded ::+    (Store :> es) =>+    StreamId ->+    StreamVersion ->+    StateCodec state ->+    Value ->+    Eff es ()+writeSnapshotEncoded streamId streamVersion codec encoded =+    writeSnapshotRow+        SnapshotWrite+            { streamId = streamId+            , streamVersion = streamVersion+            , state = encoded+            , stateCodecVersion = codec ^. #stateCodecVersion+            , regfileShapeHash = codec ^. #shapeHash+            }++{- | Encode @state@ with @codec@ and upsert it as the snapshot for the given+stream at @streamVersion@. This compatibility helper preserves the historical+lazy encoding behavior; post-commit advisory paths should call+'encodeSnapshotStrict' first and pass the result to 'writeSnapshotEncoded'. For+a fixed codec version and shape hash stale writes are ignored, while an+incompatible codec may replace a newer row to permit rollback.+-}+writeSnapshot ::+    (Store :> es) =>+    StreamId ->+    StreamVersion ->+    StateCodec state ->+    state ->+    Eff es ()+writeSnapshot streamId streamVersion codec state =+    writeSnapshotEncoded streamId streamVersion codec ((codec ^. #encode) state)
+ src/Keiro/Snapshot/Codec.hs view
@@ -0,0 +1,69 @@+{- | The default JSON encoding for aggregate snapshots.++'defaultStateCodec' builds a 'StateCodec' for the @(state, registers)@ pair+of a keiki machine, serializing it as a JSON object @{ "state": …,+"registers": … }@. The state half uses its 'ToJSON' \/ 'FromJSON'+instances; the register half uses keiki's register-file JSON encoding. The+codec's 'shapeHash' is derived from the register-file /shape/, so any change+to the register layout changes the hash and transparently invalidates older+snapshots (see "Keiro.Snapshot").++Pass your own version number to bump it explicitly when the state encoding+changes in a way the shape hash does not capture.+-}+module Keiro.Snapshot.Codec (+    defaultStateCodec,+)+where++import Data.Aeson (Result (..), object, withObject, (.:))+import Data.Aeson qualified as Aeson+import Data.Aeson.Types (parseEither)+import Data.Text qualified as Text+import Keiki.Codec.JSON (RegFileToJSON, regFileFromJSON, regFileToJSON)+import Keiki.Core (RegFile)+import Keiki.Shape (KnownRegFileShape, regFileShapeHash)+import Keiro.EventStream (StateCodec (..))+import Keiro.Prelude++{- | A 'StateCodec' that serializes a @(state, registers)@ pair to a JSON+object, tagging it with the supplied codec version and a shape hash derived+from the register-file layout.+-}+defaultStateCodec ::+    forall rs s.+    (FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) =>+    Int ->+    StateCodec (s, RegFile rs)+defaultStateCodec version =+    StateCodec+        { stateCodecVersion = version+        , shapeHash = regFileShapeHash (Proxy @rs)+        , encode = \(state, registers) ->+            object+                [ "state" Aeson..= state+                , "registers" Aeson..= regFileToJSON registers+                ]+        , decode = decodeSnapshotValue+        }++decodeSnapshotValue ::+    forall rs s.+    (FromJSON s, RegFileToJSON rs) =>+    Value ->+    Either Text (s, RegFile rs)+decodeSnapshotValue value =+    case parseEither parser value of+        Left message -> Left (Text.pack message)+        Right pair -> Right pair+  where+    parser = withObject "Keiro snapshot" $ \objectValue -> do+        stateValue <- objectValue .: "state"+        registerValue <- objectValue .: "registers"+        state <- case Aeson.fromJSON stateValue of+            Error message -> fail ("state: " <> message)+            Success decoded -> pure decoded+        registers <- case regFileFromJSON @rs registerValue of+            Left message -> fail ("registers: " <> message)+            Right decoded -> pure decoded+        pure (state, registers)
+ src/Keiro/Snapshot/Schema.hs view
@@ -0,0 +1,173 @@+{- | The @keiro_snapshots@ table: persistence for aggregate snapshots.++One row per stream holds the latest snapshot of its folded state as JSONB,+tagged with the 'stateCodecVersion' and 'regfileShapeHash' that produced it.+'lookupSnapshot' fetches the newest row matching a given version and shape+hash (so incompatible snapshots are simply not found). Within one codec+version and shape hash, 'writeSnapshotRow' keeps only the highest stream+version, so a late or out-of-order write cannot regress the snapshot.++A write with a /different/ codec version or shape hash deliberately replaces+the row even at a lower stream version. This lets a rolled-back deployment+reclaim the single snapshot slot instead of being locked out by a newer codec+forever. During a mixed-version deployment, however, writers with incompatible+codecs can thrash that row and each side will miss the other's snapshot. The+cost is repeated full replay, never incorrect state: the event log remains the+source of truth.++This module is the storage layer beneath "Keiro.Snapshot"; callers normally+go through 'Keiro.Snapshot.hydrateWithSnapshot' and+'Keiro.Snapshot.writeSnapshot' rather than these statements directly.+-}+module Keiro.Snapshot.Schema (+    -- * Rows+    SnapshotRow (..),+    SnapshotWrite (..),++    -- * Storage+    lookupSnapshot,+    writeSnapshotRow,+)+where++import Contravariant.Extras (contrazip3, contrazip5)+import Effectful (Eff, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Prelude+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (StreamId (..), StreamVersion (..))+import "hasql-transaction" Hasql.Transaction qualified as Tx+import Prelude qualified++{- | A snapshot row as read back from @keiro_snapshots@: the stored 'state'+JSON, the 'streamVersion' it captures, the 'stateCodecVersion' and+'regfileShapeHash' that gate compatibility, and the create/update+timestamps.+-}+data SnapshotRow = SnapshotRow+    { streamId :: !StreamId+    , streamVersion :: !StreamVersion+    , state :: !Value+    , stateCodecVersion :: !Int+    , regfileShapeHash :: !Text+    , createdAt :: !UTCTime+    , updatedAt :: !UTCTime+    }+    deriving stock (Generic, Eq, Show)++{- | The fields needed to write a snapshot — 'SnapshotRow' minus the+database-managed timestamps.+-}+data SnapshotWrite = SnapshotWrite+    { streamId :: !StreamId+    , streamVersion :: !StreamVersion+    , state :: !Value+    , stateCodecVersion :: !Int+    , regfileShapeHash :: !Text+    }+    deriving stock (Generic, Eq, Show)++{- | Fetch the latest snapshot for a stream that matches the given codec+version and register-file shape hash. Returns 'Nothing' when no compatible+snapshot exists, so an incompatible one is treated as absent.+-}+lookupSnapshot ::+    (Store :> es) =>+    StreamId ->+    Int ->+    Text ->+    Eff es (Maybe SnapshotRow)+lookupSnapshot streamId version shapeHash =+    runTransaction+        $ Tx.statement+            (streamIdToInt streamId, Prelude.fromIntegral version, shapeHash)+            lookupSnapshotStmt++{- | Upsert a snapshot row for its stream. For the same codec version and shape+hash, the write only takes effect when its 'streamVersion' is at least the+stored one. An incompatible codec version or shape hash replaces the row even+at a lower version so codec rollback can make progress; see the module header+for the mixed-deployment performance caveat.+-}+writeSnapshotRow ::+    (Store :> es) =>+    SnapshotWrite ->+    Eff es ()+writeSnapshotRow snapshot =+    runTransaction+        $ Tx.statement (snapshotWriteParams snapshot) writeSnapshotStmt++lookupSnapshotStmt :: Statement (Int64, Int64, Text) (Maybe SnapshotRow)+lookupSnapshotStmt =+    preparable+        """+        SELECT stream_id, stream_version, state, state_codec_version, regfile_shape_hash, created_at, updated_at+        FROM keiro.keiro_snapshots+        WHERE stream_id = $1+          AND state_codec_version = $2+          AND regfile_shape_hash = $3+        ORDER BY stream_version DESC+        LIMIT 1+        """+        ( contrazip3+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.text))+        )+        (D.rowMaybe snapshotRowDecoder)++writeSnapshotStmt :: Statement (Int64, Int64, Value, Int64, Text) ()+writeSnapshotStmt =+    preparable+        """+        INSERT INTO keiro.keiro_snapshots+          (stream_id, stream_version, state, state_codec_version, regfile_shape_hash)+        VALUES+          ($1, $2, $3, $4, $5)+        ON CONFLICT (stream_id) DO UPDATE+          SET stream_version = EXCLUDED.stream_version,+              state = EXCLUDED.state,+              state_codec_version = EXCLUDED.state_codec_version,+              regfile_shape_hash = EXCLUDED.regfile_shape_hash,+              updated_at = now()+          WHERE keiro_snapshots.stream_version <= EXCLUDED.stream_version+             OR keiro_snapshots.state_codec_version <> EXCLUDED.state_codec_version+             OR keiro_snapshots.regfile_shape_hash <> EXCLUDED.regfile_shape_hash+        """+        ( contrazip5+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.jsonb))+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++snapshotRowDecoder :: D.Row SnapshotRow+snapshotRowDecoder =+    SnapshotRow+        <$> (StreamId <$> D.column (D.nonNullable D.int8))+        <*> (StreamVersion <$> D.column (D.nonNullable D.int8))+        <*> D.column (D.nonNullable D.jsonb)+        <*> (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8))+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nonNullable D.timestamptz)++streamIdToInt :: StreamId -> Int64+streamIdToInt (StreamId value) = value++streamVersionToInt :: StreamVersion -> Int64+streamVersionToInt (StreamVersion value) = value++snapshotWriteParams :: SnapshotWrite -> (Int64, Int64, Value, Int64, Text)+snapshotWriteParams snapshot =+    ( streamIdToInt (snapshot ^. #streamId)+    , streamVersionToInt (snapshot ^. #streamVersion)+    , snapshot ^. #state+    , Prelude.fromIntegral (snapshot ^. #stateCodecVersion)+    , snapshot ^. #regfileShapeHash+    )
+ src/Keiro/Subscription/Shard.hs view
@@ -0,0 +1,184 @@+{- | Cooperative consumer-group ownership for category subscriptions (EP-51).++kiroku already partitions a category into @N@ buckets (consumer-group members) by+a stable hash of the originating stream id, and keeps a per-member checkpoint, so+@N@ disjoint readers can drain a busy category in parallel. What kiroku leaves to+the operator is /membership/: "exactly one live process must own each member+index at a time" is, by itself, a manual @[0..N-1]@ wiring. This module supplies+the missing operability layer — a __lease__ over each bucket so a pool of+identical worker processes agree, with no external coordinator, on who owns which+bucket right now and re-divide the buckets automatically when a worker joins,+leaves, or dies.++The storage and SQL live in "Keiro.Subscription.Shard.Schema"; this module is the+typed 'Eff'-level surface over kiroku's 'Store':++* 'freshWorkerId' mints the per-process owner id.+* 'acquireOwnedBuckets' is the one-pass reconcile: renew the leases this worker+  still holds, then claim up to a /fair share/ more (taking over any expired+  leases), returning the buckets owned after the pass.+* 'renewOwnedBuckets' / 'relinquish' are the heartbeat and the graceful release.+* 'ensureShards' / 'ownershipSnapshot' populate and read the table.++The lease, not a held lock, is the ownership mechanism: a transaction-scoped+advisory lock auto-releases at transaction end (so it cannot span a worker's+multi-transaction lifetime) and a session-scoped lock has no connection affinity+through kiroku's pooled 'Store' — the same finding+'Keiro.Workflow.Resume.WorkflowResumeOptions' records for the resume worker. A+renewable @lease_expires_at@ timestamp gives lifetime ownership and automatic+failover without depending on connection affinity, and disjointness rests on the+@FOR UPDATE SKIP LOCKED@ claim, not on the liveness estimate being exact.+-}+module Keiro.Subscription.Shard (+    -- * Worker identity+    WorkerId (..),+    freshWorkerId,++    -- * Lease descriptor+    ShardLease (..),+    ShardCountMismatch (..),++    -- * Ownership operations+    ensureShards,+    acquireOwnedBuckets,+    renewOwnedBuckets,+    relinquish,+    ownershipSnapshot,++    -- * Fair-share helper+    fairShareTarget,+)+where++import Data.Set (Set)+import Data.Set qualified as Set+import Data.Time (NominalDiffTime)+import Data.UUID.V4 qualified as UUIDv4+import Effectful (Eff, IOE, (:>))+import Effectful.Exception (Exception, throwIO)+import Keiro.Prelude+import Keiro.Subscription.Shard.Schema (+    WorkerId (..),+    claimShardsTx,+    ensureShardRows,+    listShardCounts,+    listShardOwnership,+    releaseShardsTx,+    renewLeaseTx,+ )+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Subscription.Types (SubscriptionName (..))+import Kiroku.Store.Transaction (runTransaction)++-- | Mint a fresh per-process 'WorkerId' (a random UUID).+freshWorkerId :: (IOE :> es) => Eff es WorkerId+freshWorkerId = WorkerId <$> liftIO UUIDv4.nextRandom++{- | Everything an ownership pass needs for one @(subscription, worker)@: which+subscription is being sharded, this worker's id, the fixed bucket count @N@, and+how long a claim/renew is valid before it expires.+-}+data ShardLease = ShardLease+    { subscriptionName :: !SubscriptionName+    , workerId :: !WorkerId+    , shardCount :: !Int+    -- ^ @N@; the fixed number of buckets for this subscription name.+    , leaseTtl :: !NominalDiffTime+    -- ^ How long a claim or renewal keeps a bucket before it expires.+    }+    deriving stock (Generic)++data ShardCountMismatch = ShardCountMismatch+    { mismatchSubscriptionName :: !Text+    , mismatchConfigured :: !Int+    , mismatchFound :: ![Int]+    }+    deriving stock (Generic, Eq, Show)+    deriving anyclass (Exception)++{- | The fair-share claim target: @ceil(N / liveWorkers)@. When @k@ workers are+live they collectively claim all @N@ buckets and no single worker hogs them. A+non-positive @liveWorkers@ is treated as one (claim everything).+-}+fairShareTarget :: Int -> Int -> Int+fairShareTarget shardCount liveWorkers =+    let k = max 1 liveWorkers+     in (shardCount + k - 1) `div` k++{- | Idempotently populate the @N@ shard rows for this subscription. Safe to call+on every worker startup ('ensureShardRows' uses @ON CONFLICT DO NOTHING@).+-}+ensureShards :: (Store :> es) => ShardLease -> Eff es ()+ensureShards lease = do+    counts <- runTransaction $ do+        ensureShardRows (subscriptionName lease) (shardCount lease)+        listShardCounts (subscriptionName lease)+    let configured = shardCount lease+        found = [n | (n, _) <- counts, n /= configured]+    unless (null found) $+        throwIO+            ShardCountMismatch+                { mismatchSubscriptionName = case subscriptionName lease of+                    SubscriptionName name -> name+                , mismatchConfigured = configured+                , mismatchFound = found+                }++{- | One ownership-reconcile pass: in a single transaction, renew the leases this+worker still holds, then — if it holds fewer than its fair share — claim __one__+more bucket (unowned or expired). Returns the set of buckets owned __after__ the+pass.++Claiming __one at a time__ is deliberate and is what makes a pool of identical+workers converge to a fair split without any external coordinator. If a cold+worker grabbed its whole fair share at once it could, racing alone before its+peers' first pass, monopolise every bucket and then never see the idle peers+(they own nothing, so they are invisible in the lease table). Taking one bucket+per pass instead means concurrently-starting workers each grab one, become+visible after the first pass, and climb to an even share together; a worker+joining a balanced pool only picks up buckets freed by an expired lease+(failover). Ownership spreads over up to @N@ reconcile intervals — a deliberate+trade of spin-up latency for coordinator-free fairness.++@liveWorkers@ is the caller's estimate of how many workers are currently live+(see 'ownershipSnapshot'); it tunes the fair-share target and self-corrects next+pass. It never causes double ownership, because the @FOR UPDATE SKIP LOCKED@+claim is the real exclusion mechanism.+-}+acquireOwnedBuckets :: (IOE :> es, Store :> es) => ShardLease -> Int -> Eff es (Set Int)+acquireOwnedBuckets lease liveWorkers = do+    now <- liftIO getCurrentTime+    let target = fairShareTarget (shardCount lease) liveWorkers+    runTransaction $ do+        held <- renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease)+        -- Claim at most one bucket per pass (see the note above on convergence).+        claimed <-+            if length held < target+                then claimShardsTx (subscriptionName lease) (workerId lease) 1 now (leaseTtl lease)+                else pure []+        pure (Set.fromList held <> Set.fromList claimed)++{- | Renew only — write a fresh expiry for every bucket this worker still holds+and return them. Used when a worker wants to heartbeat without claiming more.+-}+renewOwnedBuckets :: (IOE :> es, Store :> es) => ShardLease -> Eff es (Set Int)+renewOwnedBuckets lease = do+    now <- liftIO getCurrentTime+    held <- runTransaction (renewLeaseTx (subscriptionName lease) (workerId lease) now (leaseTtl lease))+    pure (Set.fromList held)++{- | Graceful release of the given buckets (clean shutdown), so they are+claimable immediately instead of after lease expiry.+-}+relinquish :: (Store :> es) => ShardLease -> Set Int -> Eff es ()+relinquish lease buckets =+    runTransaction (releaseShardsTx (subscriptionName lease) (workerId lease) (Set.toList buckets))++{- | Read every bucket's @(bucket, owner, lease_expires_at)@ for this+subscription. The worker uses it to estimate @liveWorkers@ (count of distinct+non-expired owners) before an 'acquireOwnedBuckets' pass.+-}+ownershipSnapshot ::+    (Store :> es) => ShardLease -> Eff es [(Int, Maybe WorkerId, Maybe UTCTime)]+ownershipSnapshot lease =+    runTransaction (listShardOwnership (subscriptionName lease))
+ src/Keiro/Subscription/Shard/Schema.hs view
@@ -0,0 +1,227 @@+{- | The @keiro_subscription_shards@ table: storage and lease logic for+cooperative consumer-group ownership (EP-51).++A category subscription can be split across @N@ buckets — kiroku consumer-group+member indices in @[0, N)@ — so that @N@ cooperating workers each drain a+disjoint slice of the keyspace. This module owns the durable __assignment__+layer: one row per @(subscription_name, bucket)@ recording which worker holds it+right now, as a renewable __lease__ (an owner id plus an expiry timestamp). A+live worker renews its lease on a heartbeat; a dead worker stops renewing, its+lease expires, and another worker re-claims the bucket (failover). It does+__not__ store event positions — kiroku's per-member checkpoints+(@(subscription_name, consumer_group_member)@) do that, so a re-homed bucket+resumes where its previous owner left off.++The statements here are 'Hasql.Transaction.Transaction'-flavoured so callers can+compose several into one short transaction (e.g. renew-then-claim in+'Keiro.Subscription.Shard.acquireOwnedBuckets'); the typed 'Eff'-level wrappers+that run them through kiroku's pool live in "Keiro.Subscription.Shard". The+claim uses @FOR UPDATE SKIP LOCKED@ over the claimable rows, exactly as+'Keiro.Timer.Schema.claimDueTimer' does, so two workers racing the same bucket+can never both win — a stale "how many workers are live" estimate only changes+how aggressively a worker claims, never whether ownership stays disjoint.+-}+module Keiro.Subscription.Shard.Schema (+    -- * Worker identity+    WorkerId (..),++    -- * Lease statements (composable within a transaction)+    ensureShardRows,+    claimShardsTx,+    renewLeaseTx,+    releaseShardsTx,+    listShardOwnership,+    listShardCounts,+)+where++import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5)+import Data.Int (Int32)+import Data.Time (NominalDiffTime, addUTCTime)+import Data.UUID (UUID)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Prelude+import Kiroku.Store.Subscription.Types (SubscriptionName (..))+import "hasql-transaction" Hasql.Transaction qualified as Tx++{- | A per-process unique id naming the owner in a lease row. A UUID minted once+at worker start ('Keiro.Subscription.Shard.freshWorkerId'); two restarts of the+same binary get two different ids, so a restarted process never inherits the+dead process's leases — it claims afresh once the old leases expire.+-}+newtype WorkerId = WorkerId UUID+    deriving stock (Eq, Ord, Show)++{- | Idempotently insert the @N@ rows @(name, bucket = 0..N-1, shard_count = N)@+with @owner_worker_id@ left @NULL@. @ON CONFLICT DO NOTHING@ makes calling it+on every worker startup safe; it converges the table to exactly @N@ rows.+-}+ensureShardRows :: SubscriptionName -> Int -> Tx.Transaction ()+ensureShardRows (SubscriptionName name) shardCount =+    Tx.statement (name, fromIntegral shardCount) ensureShardRowsStmt++{- | Claim up to @targetCount@ buckets that are currently unowned __or__ whose+lease has expired (@owner_worker_id IS NULL OR lease_expires_at < now@), in one+statement, returning the bucket numbers actually claimed. @FOR UPDATE SKIP+LOCKED@ over the claimable rows is the exclusion mechanism: two workers racing+the same bucket cannot both win. The TTL is added to @now@ here (in Haskell) to+form the new @lease_expires_at@.+-}+claimShardsTx ::+    SubscriptionName -> WorkerId -> Int -> UTCTime -> NominalDiffTime -> Tx.Transaction [Int]+claimShardsTx (SubscriptionName name) (WorkerId worker) targetCount now ttl =+    fmap (fmap fromIntegral) $+        Tx.statement+            (name, now, addUTCTime ttl now, worker, fromIntegral targetCount)+            claimShardsStmt++{- | Renew every lease this worker still holds: write a fresh @lease_expires_at =+now + ttl@ and @heartbeat_at = now@ for each row it owns, returning the buckets+still held. A bucket stolen after this worker's lease lapsed is owned by someone+else and so is __not__ in the result — that is how a worker learns it lost a+bucket and stops reading it.+-}+renewLeaseTx :: SubscriptionName -> WorkerId -> UTCTime -> NominalDiffTime -> Tx.Transaction [Int]+renewLeaseTx (SubscriptionName name) (WorkerId worker) now ttl =+    fmap (fmap fromIntegral) $+        Tx.statement (name, now, addUTCTime ttl now, worker) renewLeaseStmt++{- | Graceful relinquish: clear ownership of the given buckets this worker holds+so they become claimable immediately, without waiting for lease expiry. Called+on clean shutdown. Only rows still owned by @worker@ are affected, so a bucket+already stolen is left untouched.+-}+releaseShardsTx :: SubscriptionName -> WorkerId -> [Int] -> Tx.Transaction ()+releaseShardsTx (SubscriptionName name) (WorkerId worker) buckets =+    Tx.statement (name, worker, fmap fromIntegral buckets) releaseShardsStmt++{- | Observability/test read of @(bucket, owner, lease_expires_at)@ for one+subscription, ordered by bucket.+-}+listShardOwnership :: SubscriptionName -> Tx.Transaction [(Int, Maybe WorkerId, Maybe UTCTime)]+listShardOwnership (SubscriptionName name) =+    Tx.statement name listShardOwnershipStmt++-- | Read existing shard-count groups for a subscription as @(shard_count, rows)@.+listShardCounts :: SubscriptionName -> Tx.Transaction [(Int, Int)]+listShardCounts (SubscriptionName name) =+    Tx.statement name listShardCountsStmt++ensureShardRowsStmt :: Statement (Text, Int32) ()+ensureShardRowsStmt =+    preparable+        """+        INSERT INTO keiro.keiro_subscription_shards (subscription_name, bucket, shard_count)+        SELECT $1, g, $2+        FROM generate_series(0, $2 - 1) AS g+        ON CONFLICT (subscription_name, bucket) DO NOTHING+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+        )+        D.noResult++claimShardsStmt :: Statement (Text, UTCTime, UTCTime, UUID, Int32) [Int32]+claimShardsStmt =+    preparable+        """+        WITH claimable AS (+          SELECT bucket+          FROM keiro.keiro_subscription_shards+          WHERE subscription_name = $1+            AND (owner_worker_id IS NULL OR lease_expires_at < $2)+          ORDER BY bucket+          LIMIT $5+          FOR UPDATE SKIP LOCKED+        )+        UPDATE keiro.keiro_subscription_shards s+        SET owner_worker_id = $4,+            lease_expires_at = $3,+            heartbeat_at = $2,+            updated_at = $2+        FROM claimable c+        WHERE s.subscription_name = $1 AND s.bucket = c.bucket+        RETURNING s.bucket+        """+        ( contrazip5+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.int4))+        )+        (D.rowList (D.column (D.nonNullable D.int4)))++renewLeaseStmt :: Statement (Text, UTCTime, UTCTime, UUID) [Int32]+renewLeaseStmt =+    preparable+        """+        UPDATE keiro.keiro_subscription_shards+        SET lease_expires_at = $3,+            heartbeat_at = $2,+            updated_at = $2+        WHERE subscription_name = $1+          AND owner_worker_id = $4+        RETURNING bucket+        """+        ( contrazip4+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.uuid))+        )+        (D.rowList (D.column (D.nonNullable D.int4)))++releaseShardsStmt :: Statement (Text, UUID, [Int32]) ()+releaseShardsStmt =+    preparable+        """+        UPDATE keiro.keiro_subscription_shards+        SET owner_worker_id = NULL,+            lease_expires_at = NULL,+            updated_at = now()+        WHERE subscription_name = $1+          AND owner_worker_id = $2+          AND bucket = ANY($3)+        """+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.int4))))+        )+        D.noResult++listShardOwnershipStmt :: Statement Text [(Int, Maybe WorkerId, Maybe UTCTime)]+listShardOwnershipStmt =+    preparable+        """+        SELECT bucket, owner_worker_id, lease_expires_at+        FROM keiro.keiro_subscription_shards+        WHERE subscription_name = $1+        ORDER BY bucket+        """+        (E.param (E.nonNullable E.text))+        (D.rowList ownershipRowDecoder)++listShardCountsStmt :: Statement Text [(Int, Int)]+listShardCountsStmt =+    preparable+        """+        SELECT shard_count, count(*)::int+        FROM keiro.keiro_subscription_shards+        WHERE subscription_name = $1+        GROUP BY shard_count+        ORDER BY shard_count+        """+        (E.param (E.nonNullable E.text))+        (D.rowList ((,) <$> (fromIntegral <$> D.column (D.nonNullable D.int4)) <*> (fromIntegral <$> D.column (D.nonNullable D.int4))))++ownershipRowDecoder :: D.Row (Int, Maybe WorkerId, Maybe UTCTime)+ownershipRowDecoder =+    (,,)+        <$> (fromIntegral <$> D.column (D.nonNullable D.int4))+        <*> (fmap WorkerId <$> D.column (D.nullable D.uuid))+        <*> D.column (D.nullable D.timestamptz)
+ src/Keiro/Subscription/Shard/Worker.hs view
@@ -0,0 +1,428 @@+{- | The sharded category-subscription worker: a rebalance loop that turns+leased bucket ownership ("Keiro.Subscription.Shard") into running kiroku+consumer-group readers (EP-51).++Start the __same__ worker binary @N@ times — on @N@ hosts, in @N@ containers, in+an autoscaling group — each calling 'runShardedSubscriptionGroup' with the same+'SubscriptionName' and 'ShardedWorkerOptions', and the workers cooperatively+partition the category among themselves: every event is processed at least once+and none are skipped. A brief ownership overlap can deliver an event more than+once, so handlers must be idempotent. No external coordinator+(etcd/ZooKeeper/Consul) — coordination lives in the+@keiro_subscription_shards@ lease table.++== One pass++'reconcileShardsOnce' is the single testable unit (like+'Keiro.Workflow.Resume.resumeWorkflowsOnce'):++1. Estimate how many workers are live from the lease table.+2. 'Keiro.Subscription.Shard.acquireOwnedBuckets' — renew the leases this worker+   still holds and claim up to a fair share more (taking over expired leases).+3. __Shed__ any buckets held beyond the fair share when more than one worker is+   live, so a worker that grabbed too many on a cold start (when it briefly+   believed it was alone) gives the excess back and the pool converges to an+   even split. A lone worker never sheds — it must own every bucket.+4. Reconcile readers: open a kiroku consumer-group reader for each newly-owned+   bucket, stop the reader for each newly-lost bucket. A bucket that moves owners+   resumes at its own kiroku per-member checkpoint. Each event is acknowledged+   only after its handler returns, so a shed bucket's checkpoint never covers an+   unprocessed event and no event is dropped.++'runShardedSubscriptionGroup' is the loop driver: mint a 'WorkerId', ensure the+shard rows exist, then run 'reconcileShardsOnce' every @renewInterval@ forever.+On graceful shutdown (the loop thread is killed and can run cleanup) a @finally@+stops every reader this worker holds and relinquishes its leases so another+worker can claim immediately. A real process crash still recovers by lease+expiry.++== Why @IO@, not @Eff@++Like 'Keiro.Workflow.Resume.runWorkflowResumeWorkerPush', this worker manages+long-lived 'Control.Concurrent' reader threads and takes the 'KirokuStore' handle+directly (each lease pass runs through 'Kiroku.Store.Effect.runStoreIO'), so its+natural home is 'IO'. The compatibility handler is an ordinary+@'RecordedEvent' -> 'IO' ()@; 'runShardedSubscriptionGroupAck' exposes the+per-event 'ShardAck' surface for handlers that need an explicit retry or+dead-letter decision. A sharded subscription delivers at-least-once (a brief+overlap is possible while a bucket changes owners), so the handler must be+idempotent — keyed on @eventId@ — exactly as keiro's async-projection guidance+already requires.++A synchronous exception from either handler is retried in place according to+'retryPolicy', using 'handlerRetryDelay'. Exhausting the bounded delivery budget+records the event in kiroku's @kiroku.dead_letters@ table and advances to the next+event. 'ShardReaderDied' therefore reports stream-level failures, not ordinary+handler exceptions. An asynchronous exception from shedding or shutdown writes+no acknowledgement, so the event is redelivered by the next owner.++A zombie worker that misses renewals past @leaseTtl@ may continue reading briefly+after another worker claims its bucket, which can duplicate deliveries. It cannot+regress the consumer-group checkpoint: kiroku's checkpoint upsert is monotonic+(@GREATEST@), so a late acknowledgement from the laggard never moves progress+backward.+-}+module Keiro.Subscription.Shard.Worker (+    -- * Options+    ShardWorkerError (..),+    ShardedWorkerOptions (..),+    ShardedWorkerConfigError (..),+    defaultShardedWorkerOptions,+    mkShardedWorkerOptions,+    acquireOutcome,++    -- * Per-event acknowledgement+    ShardAck (..),+    ShardDelivery (..),+    ShardEventHandler,+    RetryDelay (..),+    DeadLetterReason (..),++    -- * Running+    reconcileShardsOnce,+    runShardedSubscriptionGroup,+    runShardedSubscriptionGroupAck,+)+where++import Control.Concurrent (forkFinally, killThread, threadDelay)+import Control.Concurrent.STM (atomically, putTMVar)+import Control.Exception (SomeAsyncException, SomeException, catch, displayException, finally, fromException, throwIO)+import Control.Monad (forever)+import Data.Bifunctor (first)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int32)+import Data.List (sort)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Time (NominalDiffTime)+import Data.UUID.V4 qualified as UUIDv4+import Keiro.Prelude+import Keiro.Subscription.Shard (+    ShardLease (..),+    WorkerId (..),+    acquireOwnedBuckets,+    ensureShards,+    fairShareTarget,+    ownershipSnapshot,+    relinquish,+ )+import Kiroku.Store.Connection (KirokuStore)+import Kiroku.Store.Effect (runStoreIO)+import Kiroku.Store.Subscription.Stream (AckItem (..), subscriptionAckStream)+import Kiroku.Store.Subscription.Types (+    ConsumerGroup (..),+    DeadLetterReason (..),+    RetryDelay (..),+    RetryPolicy (..),+    SubscriptionName,+    SubscriptionResult (..),+    SubscriptionTarget,+    defaultRetryPolicy,+    defaultSubscriptionConfig,+ )+import Kiroku.Store.Subscription.Types qualified as Sub+import Kiroku.Store.Types (RecordedEvent)+import Numeric.Natural (Natural)+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Stream++data ShardWorkerError+    = ShardSnapshotFailed !Text+    | ShardAcquireFailed !Text+    | ShardReaderDied !Int !Text+    | ShardEnsureFailed !Text+    deriving stock (Generic, Eq, Show)++-- | Per-event disposition returned by an acknowledgement-aware shard handler.+data ShardAck+    = -- | Processing completed; the checkpoint may advance past this event.+      ShardAckOk+    | -- | Redeliver after the delay, bounded by 'retryPolicy'.+      ShardAckRetry !RetryDelay+    | -- | Record the event in kiroku's dead-letter table and advance immediately.+      ShardAckDeadLetter !DeadLetterReason+    deriving stock (Generic, Eq, Show)++-- | One delivery to an acknowledgement-aware shard handler.+data ShardDelivery = ShardDelivery+    { event :: !RecordedEvent+    -- ^ The delivered event.+    , attempt :: !Word+    -- ^ Zero-based redelivery count: 0 initially, 1 after the first retry, and so on.+    , bucket :: !Int+    -- ^ The consumer-group member owned by this reader.+    }+    deriving stock (Generic, Eq, Show)++type ShardEventHandler = ShardDelivery -> IO ShardAck++-- | How a sharded worker pool runs one subscription.+data ShardedWorkerOptions = ShardedWorkerOptions+    { shardCount :: !Int+    -- ^ @N@ buckets, fixed per subscription name (every worker must agree on @N@).+    , leaseTtl :: !NominalDiffTime+    -- ^ How long a claim/renew keeps a bucket before it expires (default 30 s).+    , renewInterval :: !NominalDiffTime+    {- ^ Gap between reconcile passes; well under 'leaseTtl' so a live worker renews+    several times per TTL (default 10 s ⇒ ~3 renews per 30 s TTL). A single+    missed renewal does not lose ownership; a dead worker loses every bucket+    within one TTL.+    -}+    , target :: !SubscriptionTarget+    -- ^ The category (or @AllStreams@) to shard.+    , batchSize :: !Int32+    -- ^ Events per database fetch per bucket reader (default 100).+    , bufferSize :: !Natural+    -- ^ Per-reader bridge queue capacity (default 256; one item is in flight).+    , handlerRetryDelay :: !RetryDelay+    -- ^ Delay before redelivering after a synchronous handler exception (default 1 s).+    , retryPolicy :: !RetryPolicy+    -- ^ Maximum total deliveries before retry exhaustion dead-letters the event.+    , onShardError :: !(Maybe (ShardWorkerError -> IO ()))+    -- ^ Optional error hook. Wire this to the application logger in production.+    }+    deriving stock (Generic)++data ShardedWorkerConfigError+    = InvalidShardCount !Int+    | InvalidShardLeaseTtl !NominalDiffTime+    | InvalidShardRenewInterval !NominalDiffTime+    | InvalidShardLeaseRenewInterval !NominalDiffTime !NominalDiffTime+    | InvalidShardBatchSize !Int32+    | InvalidShardBufferSize !Natural+    | InvalidShardHandlerRetryDelay !RetryDelay+    | InvalidShardRetryMaxAttempts !Int+    deriving stock (Generic, Eq, Show)++{- | Sensible defaults for a sharded worker: 30 s lease, 10 s renew, batch 100,+buffer 256. Supply the category target and the bucket count @N@.+-}+defaultShardedWorkerOptions :: SubscriptionTarget -> Int -> ShardedWorkerOptions+defaultShardedWorkerOptions target' shardCount' =+    ShardedWorkerOptions+        { shardCount = shardCount'+        , leaseTtl = 30+        , renewInterval = 10+        , target = target'+        , batchSize = 100+        , bufferSize = 256+        , handlerRetryDelay = RetryDelay 1+        , retryPolicy = defaultRetryPolicy+        , onShardError = Nothing+        }++-- | Validate sharded worker options before starting a worker pool member.+mkShardedWorkerOptions :: ShardedWorkerOptions -> Either ShardedWorkerConfigError ShardedWorkerOptions+mkShardedWorkerOptions opts+    | opts ^. #shardCount < 1 = Left (InvalidShardCount (opts ^. #shardCount))+    | opts ^. #leaseTtl <= 0 = Left (InvalidShardLeaseTtl (opts ^. #leaseTtl))+    | opts ^. #renewInterval <= 0 = Left (InvalidShardRenewInterval (opts ^. #renewInterval))+    | opts ^. #leaseTtl <= opts ^. #renewInterval =+        Left (InvalidShardLeaseRenewInterval (opts ^. #leaseTtl) (opts ^. #renewInterval))+    | opts ^. #batchSize < 1 = Left (InvalidShardBatchSize (opts ^. #batchSize))+    | opts ^. #bufferSize < 1 = Left (InvalidShardBufferSize (opts ^. #bufferSize))+    | RetryDelay delay <- opts ^. #handlerRetryDelay+    , delay < 0 =+        Left (InvalidShardHandlerRetryDelay (opts ^. #handlerRetryDelay))+    | RetryPolicy attempts <- opts ^. #retryPolicy+    , attempts < 1 =+        Left (InvalidShardRetryMaxAttempts attempts)+    | otherwise = Right opts++{- | A live per-bucket reader: the action that stops it (cancels the kiroku+subscription and kills the drain thread).+-}+newtype RunningReader = RunningReader {stopReader :: IO ()}++reportShardError :: ShardedWorkerOptions -> ShardWorkerError -> IO ()+reportShardError opts err =+    for_ (opts ^. #onShardError) ($ err)++acquireOutcome :: Set Int -> Either Text (Set Int) -> (Set Int, Maybe ShardWorkerError)+acquireOutcome previous = \case+    Right owned -> (owned, Nothing)+    Left err -> (previous, Just (ShardAcquireFailed err))++{- | Run one ownership-reconcile pass and bring the set of running readers in+line with the buckets owned afterwards. Returns the buckets this worker owns+after the pass. The @readers@ ref maps each owned bucket to its live reader.++This is the testable unit: a single call claims/renews/sheds leases and+starts/stops readers once, with no loop of its own.+-}+reconcileShardsOnce ::+    KirokuStore ->+    ShardLease ->+    ShardedWorkerOptions ->+    IORef (Map Int RunningReader) ->+    ShardEventHandler ->+    IO (Set Int)+reconcileShardsOnce store lease opts readers handler = do+    now <- getCurrentTime+    current <- readIORef readers+    -- Estimate live workers: distinct owners with a non-expired lease, plus self.+    snapResult <- runStoreIO store (ownershipSnapshot lease)+    snap <- case snapResult of+        Right rows -> pure rows+        Left err -> do+            reportShardError opts (ShardSnapshotFailed (Text.pack (show err)))+            pure []+    let liveOwners = Set.fromList [w | (_, Just w, Just expiresAt) <- snap, expiresAt > now]+        liveWorkers = Set.size (Set.insert (lease ^. #workerId) liveOwners)+        shareTarget = fairShareTarget (lease ^. #shardCount) liveWorkers+    -- Renew held + claim up to fair share.+    claimedResult <- runStoreIO store (acquireOwnedBuckets lease liveWorkers)+    let previousOwned = Map.keysSet current+        (claimed, mAcquireError) = acquireOutcome previousOwned (first (Text.pack . show) claimedResult)+    for_ mAcquireError (reportShardError opts)+    -- Shed any excess above the fair share so a cold-start over-claim self-balances+    -- (never when alone: a lone worker must own everything).+    owned <-+        if liveWorkers > 1 && Set.size claimed > shareTarget+            then do+                let excess = Set.fromList (drop shareTarget (sort (Set.toList claimed)))+                _ <- runStoreIO store (relinquish lease excess)+                pure (claimed `Set.difference` excess)+            else pure claimed+    -- Bring readers in line with `owned`: start newly-owned, stop newly-lost.+    let running = Map.keysSet current+        toStart = owned `Set.difference` running+        toStop = running `Set.difference` owned+    for_ (Set.toList toStop) $ \bucket ->+        for_ (Map.lookup bucket current) stopReader+    started <-+        traverse+            (\bucket -> (,) bucket <$> startReader store lease opts readers handler bucket)+            (Set.toList toStart)+    atomicModifyIORef' readers $ \m ->+        let afterStop = foldr Map.delete m (Set.toList toStop)+            afterStart = foldr (\(b, r) -> Map.insert b r) afterStop started+         in (afterStart, ())+    pure owned++{- | Open a kiroku consumer-group reader for one bucket and fork a thread that+drains it into the handler. The returned 'RunningReader' cancels the+subscription (which terminates the drain) and kills the thread.+-}+startReader ::+    KirokuStore ->+    ShardLease ->+    ShardedWorkerOptions ->+    IORef (Map Int RunningReader) ->+    ShardEventHandler ->+    Int ->+    IO RunningReader+startReader store lease opts readers handler bucket = do+    stopping <- newIORef False+    let subConfig =+            (defaultSubscriptionConfig (lease ^. #subscriptionName) (opts ^. #target) (\_ -> pure Continue))+                { Sub.batchSize = opts ^. #batchSize+                , Sub.consumerGroup =+                    Just (ConsumerGroup{member = fromIntegral bucket, size = fromIntegral (opts ^. #shardCount)})+                , Sub.retryPolicy = opts ^. #retryPolicy+                }+        handleItem item = do+            outcome <-+                handler+                    ShardDelivery+                        { event = ackEvent item+                        , attempt = ackAttempt item+                        , bucket = bucket+                        }+                    `catch` handlerException+            atomically (putTMVar (ackReply item) (toSubscriptionResult outcome))+        handlerException err =+            case fromException err of+                Just async -> throwIO (async :: SomeAsyncException)+                Nothing -> pure (ShardAckRetry (opts ^. #handlerRetryDelay))+    (stream, cancelAction) <- subscriptionAckStream store subConfig (opts ^. #bufferSize)+    tid <-+        forkFinally (Stream.fold (Fold.drainMapM handleItem) stream) $ \result -> do+            intentional <- readIORef stopping+            unless intentional $ do+                atomicModifyIORef' readers (\m -> (Map.delete bucket m, ()))+                let reason = case result of+                        Left err -> Text.pack (displayException (err :: SomeException))+                        Right _ -> "reader stream ended"+                reportShardError opts (ShardReaderDied bucket reason)+    pure+        ( RunningReader $ do+            writeIORef stopping True+            cancelAction+            killThread tid+        )++toSubscriptionResult :: ShardAck -> SubscriptionResult+toSubscriptionResult = \case+    ShardAckOk -> Continue+    ShardAckRetry delay -> Retry delay+    ShardAckDeadLetter reason -> DeadLetter reason++{- | The loop driver: mint a 'WorkerId', ensure the @N@ shard rows exist, then+'reconcileShardsOnce' every @renewInterval@ forever. On shutdown (the loop thread+is killed) a @finally@ stops every reader this worker holds, so a crashed+worker's buckets stop being read immediately; its leases then expire and a+surviving worker re-claims them.++The fixed @renewInterval@ between passes (the 'threadDelay' in 'loop') is the+__rebalance-signal seam__ (EP-51 Milestone 6). The shipped default is a pure poll:+correctness — disjointness and failover — rests entirely on the lease table and+does not depend on any notification. The EP-50 'Keiro.Wake' channel wakes on event+/appends/ (@kiroku.events@), which is a different event than a shard ownership+/change/; signalling a prompt rebalance on a worker join or a voluntary relinquish+would ride a dedicated @keiro_shard_rebalance@ @NOTIFY@ fired on claim/release, and+the swap is local to this one 'threadDelay' (replace it with a bounded wait on that+channel, exactly as 'Keiro.Workflow.Resume.runPollLoopWith' does for appends). Left+as the poll default here because it is a latency optimisation, not a correctness+requirement.+-}+runShardedSubscriptionGroup ::+    KirokuStore ->+    SubscriptionName ->+    ShardedWorkerOptions ->+    (RecordedEvent -> IO ()) ->+    IO ()+runShardedSubscriptionGroup store subName opts handler =+    runShardedSubscriptionGroupAck store subName opts $ \delivery -> do+        handler (delivery ^. #event)+        pure ShardAckOk++{- | Acknowledgement-aware loop driver. Unlike the compatibility wrapper, the+handler decides whether each event advances, retries, or dead-letters.+-}+runShardedSubscriptionGroupAck ::+    KirokuStore ->+    SubscriptionName ->+    ShardedWorkerOptions ->+    ShardEventHandler ->+    IO ()+runShardedSubscriptionGroupAck store subName opts handler = do+    worker <- WorkerId <$> UUIDv4.nextRandom+    let lease =+            ShardLease+                { subscriptionName = subName+                , workerId = worker+                , shardCount = opts ^. #shardCount+                , leaseTtl = opts ^. #leaseTtl+                }+    ensured <- runStoreIO store (ensureShards lease)+    case ensured of+        Right () -> pure ()+        Left err -> reportShardError opts (ShardEnsureFailed (Text.pack (show err)))+    readers <- newIORef Map.empty+    loop lease readers `finally` cleanup lease readers+  where+    delayMicros = max 1 (round (realToFrac (opts ^. #renewInterval) * 1e6 :: Double))+    loop lease readers =+        forever $ do+            _ <- reconcileShardsOnce store lease opts readers handler+            threadDelay delayMicros+    cleanup lease readers = do+        current <- readIORef readers+        for_ (Map.elems current) stopReader+        _ <- runStoreIO store (relinquish lease (Map.keysSet current))+        pure ()
+ src/Keiro/Telemetry.hs view
@@ -0,0 +1,902 @@+{- | Thin OpenTelemetry surface for the keiro library.++This module is the single place keiro reaches for @hs-opentelemetry-api@+and @hs-opentelemetry-semantic-conventions@. Callers configure a 'Tracer'+on the application side (typically via @hs-opentelemetry-sdk@'s+'OpenTelemetry.Trace.makeTracer'), then pass it through to keiro's+publisher / consumer / command surfaces.++When no tracer is supplied, every helper degrades to a thin pass-through+(it calls the body and returns its value), so applications that do not+yet wire OpenTelemetry are unaffected.++# Attribute keys++keiro links @hs-opentelemetry-semantic-conventions@ @1.40.0.0@ (generated+from spec @v1.40@) directly. Every messaging.* / db.* typed 'AttributeKey'+the keiro audit cites (@docs/research/opentelemetry-semconv-audit.md@) is+imported from @OpenTelemetry.SemanticConventions@ and re-exported from this+module, so 'Keiro.Telemetry' remains the one-stop telemetry surface for the+library while every convention name is anchored to the spec-generated module+rather than a hand-typed string.++Only the @keiro.*@ keys ('keiro_stream_name', 'keiro_retry_attempt',+'keiro_events_appended', 'keiro_replay_divergence') are defined locally: they+are bespoke to keiro and have no upstream equivalent.+-}+module Keiro.Telemetry (+    -- * Span helpers+    Tracer,+    withProducerSpan,+    withConsumerSpan,+    withCommandSpan,+    withWorkflowSpan,++    -- * W3C TraceContext bridge+    traceContextFromCurrentSpan,+    traceContextFromHeaders,+    injectTraceContext,++    -- * Re-exported semantic-convention 'AttributeKey's++    --+    -- $semconv_keys+    messaging_operation_type,+    messaging_operation_name,+    messaging_destination_partition_id,+    messaging_consumer_group_name,+    messaging_client_id,+    messaging_kafka_offset,+    db_system_name,+    db_namespace,+    db_collection_name,+    db_operation_name,++    -- * Bespoke keiro 'AttributeKey's+    keiro_stream_name,+    keiro_retry_attempt,+    keiro_events_appended,+    keiro_replay_divergence,+    keiro_workflow_name,+    keiro_workflow_id,+    keiro_workflow_step,++    -- * Metrics surface++    --+    -- $metrics+    Meter,+    InstrumentationLibrary (..),+    keiroInstrumentationLibrary,+    keiroOutboxBacklogName,+    keiroOutboxPublishedName,+    keiroOutboxRetriedName,+    keiroOutboxDeadletteredName,+    keiroOutboxReclaimedName,+    keiroInboxProcessedName,+    keiroInboxDuplicatesName,+    keiroInboxFailedName,+    keiroInboxPoisonedName,+    keiroInboxBacklogName,+    keiroTimerBacklogName,+    keiroTimerFireLagName,+    keiroTimerAttemptsName,+    keiroTimerStuckName,+    keiroTimerRequeuedName,+    keiroProjectionLagName,+    keiroProjectionWaitTimeoutsName,+    keiroCommandConflictsName,+    keiroCommandRetriesName,+    keiroCommandDuplicatesName,+    keiroSnapshotDecodeFailuresName,+    keiroSnapshotEncodeFailuresName,+    keiroSnapshotReadHitsName,+    keiroSnapshotReadMissesName,+    keiroSnapshotWriteFailuresName,+    keiroSnapshotApplyDivergenceName,+    keiroDispatchFailedName,+    keiroDispatchDeadletteredName,+    keiroSubscriptionDeadletteredName,+    keiroDispatchDuplicatesName,+    keiroDispatchPoisonName,+    keiroWorkflowStepsExecutedName,+    keiroWorkflowStepsReplayedName,+    keiroWorkflowResumedName,+    keiroWorkflowFailedName,+    keiroWorkflowResumeErrorsName,+    keiroWorkflowLeaseSkippedName,+    keiroWorkflowJournalLengthName,+    keiroWorkflowAwakeablesPendingName,+    keiroWorkflowActiveName,+    KeiroMetrics (..),+    newKeiroMetrics,+    recordOutboxBacklog,+    recordOutboxPublished,+    recordOutboxRetried,+    recordOutboxDeadlettered,+    recordOutboxReclaimed,+    recordInboxProcessed,+    recordInboxDuplicates,+    recordInboxFailed,+    recordInboxPoisoned,+    recordInboxBacklog,+    recordTimerBacklog,+    recordTimerFireLag,+    recordTimerAttempts,+    recordTimerStuck,+    recordTimerRequeued,+    recordProjectionLag,+    recordProjectionWaitTimeouts,+    recordCommandConflicts,+    recordCommandRetries,+    recordCommandDuplicates,+    recordSnapshotDecodeFailures,+    recordSnapshotEncodeFailures,+    recordSnapshotReadHits,+    recordSnapshotReadMisses,+    recordSnapshotWriteFailures,+    recordSnapshotApplyDivergence,+    recordDispatchFailed,+    recordDispatchDeadLettered,+    recordSubscriptionDeadLettered,+    recordDispatchDuplicate,+    recordDispatchPoison,+    recordWorkflowStepExecuted,+    recordWorkflowStepReplayed,+    recordWorkflowResumed,+    recordWorkflowFailed,+    recordWorkflowResumeErrors,+    recordWorkflowLeaseSkipped,+    recordWorkflowActive,+    recordWorkflowJournalLength,+    recordWorkflowAwakeablesPending,++    -- * Kiroku observability bridge+    kirokuEventBridge,+)+where++import "base" Control.Exception (bracket)+import "base" GHC.Stack (HasCallStack)+import "bytestring" Data.ByteString qualified as ByteString+import "hs-opentelemetry-api" OpenTelemetry.Attributes (emptyAttributes)+import "hs-opentelemetry-api" OpenTelemetry.Attributes.Key (AttributeKey (..))+import "hs-opentelemetry-api" OpenTelemetry.Context (insertSpan, lookupSpan)+import "hs-opentelemetry-api" OpenTelemetry.Context.ThreadLocal (+    attachContext,+    detachContext,+    getContext,+ )+import "hs-opentelemetry-api" OpenTelemetry.Metric.Core (+    Counter,+    Gauge,+    Histogram,+    Meter,+    counterAdd,+    defaultAdvisoryParameters,+    gaugeRecord,+    histogramRecord,+    meterCreateCounterInt64,+    meterCreateGaugeInt64,+    meterCreateHistogram,+ )+import "hs-opentelemetry-api" OpenTelemetry.Trace.Core (+    InstrumentationLibrary (..),+    Span,+    SpanArguments (..),+    SpanKind (..),+    Tracer,+    addAttribute,+    defaultSpanArguments,+    inSpan',+    wrapSpanContext,+ )+import "hs-opentelemetry-semantic-conventions" OpenTelemetry.SemanticConventions (+    db_collection_name,+    db_namespace,+    db_operation_name,+    db_system_name,+    messaging_client_id,+    messaging_consumer_group_name,+    messaging_destination_name,+    messaging_destination_partition_id,+    messaging_kafka_message_key,+    messaging_kafka_offset,+    messaging_message_id,+    messaging_operation_name,+    messaging_operation_type,+    messaging_system,+ )+import "text" Data.Text qualified as Text+import "text" Data.Text.Encoding qualified as TE+import "unliftio-core" Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)++import Keiro.Inbox.Kafka (KafkaInboundRecord)+import Keiro.Integration.Event (+    IntegrationEvent,+    TraceContext (..),+    headerTraceParent,+    headerTraceState,+ )+import Keiro.Outbox.Kafka (KafkaProducerRecord)+import Keiro.Prelude+import Keiro.Workflow.Types (StepName (..), WorkflowId (..), WorkflowName (..))+import Kiroku.Store.Observability (KirokuEvent (..))++import "hs-opentelemetry-propagator-w3c" OpenTelemetry.Propagator.W3CTraceContext (+    decodeSpanContext,+    encodeSpanContext,+ )++-- ---------------------------------------------------------------------------+-- Bespoke keiro AttributeKeys+-- ---------------------------------------------------------------------------++{- $semconv_keys+The messaging.* / db.* 'AttributeKey's re-exported here are imported+directly from 'OpenTelemetry.SemanticConventions'+(@hs-opentelemetry-semantic-conventions@ @1.40.0.0@). They are surfaced+from this module so 'Keiro.Telemetry' stays the single telemetry import+for the library; their definitions live upstream.++The @keiro_*@ keys below are bespoke to keiro and have no upstream+equivalent, so they are defined locally.+-}++keiro_stream_name :: AttributeKey Text+keiro_stream_name = AttributeKey "keiro.stream.name"++keiro_retry_attempt :: AttributeKey Int64+keiro_retry_attempt = AttributeKey "keiro.retry.attempt"++keiro_events_appended :: AttributeKey Int64+keiro_events_appended = AttributeKey "keiro.events.appended"++keiro_replay_divergence :: AttributeKey Text+keiro_replay_divergence = AttributeKey "keiro.replay.divergence"++keiro_workflow_name :: AttributeKey Text+keiro_workflow_name = AttributeKey "keiro.workflow.name"++keiro_workflow_id :: AttributeKey Text+keiro_workflow_id = AttributeKey "keiro.workflow.id"++keiro_workflow_step :: AttributeKey Text+keiro_workflow_step = AttributeKey "keiro.workflow.step"++-- ---------------------------------------------------------------------------+-- Span helpers+-- ---------------------------------------------------------------------------++{- | Run @body@ inside a @Producer@-kind span named @"send " <> destination@+populated with the messaging attributes prescribed by+@docs/research/opentelemetry-semconv-audit.md@ for the outbox publish+site.++When the supplied 'Tracer' is 'Nothing', the body runs unwrapped and the+helper is a no-op pass-through. This keeps the cost of the helper at+"one 'Maybe' branch" for applications that have not yet configured a+tracer.++The body receives the producer 'Span' so it can record a publish failure+via 'recordPublishError'.+-}+withProducerSpan ::+    (MonadUnliftIO m, HasCallStack) =>+    Maybe Tracer ->+    IntegrationEvent ->+    KafkaProducerRecord ->+    (Maybe Span -> m a) ->+    m a+withProducerSpan Nothing _ _ body = body Nothing+withProducerSpan (Just tracer) event record body =+    inSpan' tracer name args $ \sp -> do+        setProducerAttributes sp event record+        body (Just sp)+  where+    name = "send " <> (event ^. #destination)+    args = defaultSpanArguments{kind = Producer}++{- | Run @body@ inside a @Consumer@-kind span named @"process " <> topic@.++Like 'withProducerSpan', the helper is a pass-through under a 'Nothing'+tracer. The 'KafkaInboundRecord' is required so the helper can populate+@messaging.kafka.offset@ and @messaging.destination.partition.id@+without the caller threading them separately.++The optional 'Text' is a consumer group name, recorded as+@messaging.consumer.group.name@ when present. The 'IntegrationEvent' is+attached when present (decode succeeded), so @messaging.message.id@+is set; otherwise the helper records only the headers known from the+broker record.+-}+withConsumerSpan ::+    (MonadUnliftIO m, HasCallStack) =>+    Maybe Tracer ->+    -- | consumer group name (optional)+    Maybe Text ->+    KafkaInboundRecord ->+    -- | decoded envelope; 'Nothing' on a decode failure path+    Maybe IntegrationEvent ->+    (Maybe Span -> m a) ->+    m a+withConsumerSpan Nothing _ _ _ body = body Nothing+withConsumerSpan (Just tracer) consumerGroup record mEvent body =+    withRemoteParent (record ^. #headers) $+        inSpan' tracer name args $ \sp -> do+            setConsumerAttributes sp consumerGroup record mEvent+            body (Just sp)+  where+    name = "process " <> (record ^. #topic)+    args = defaultSpanArguments{kind = Consumer}++{- | Run @body@ with the OpenTelemetry context temporarily augmented by a+parent span extracted from the supplied header list via the W3C+TraceContext propagator.++When no @traceparent@ header is present (or it cannot be parsed) the+body runs unwrapped, so the helper is safe to call unconditionally.++This is the bridge that makes a 'Consumer'-kind span open in this+process a *child* of the 'Producer'-kind span that emitted the message+in the upstream process, joining the two traces by trace id.+-}+withRemoteParent ::+    (MonadUnliftIO m) => [(Text, Text)] -> m a -> m a+withRemoteParent hs body =+    case parentSpanContext hs of+        Nothing -> body+        Just spanCtx -> withRunInIO $ \runInIO -> do+            ctx <- getContext+            let newCtx = insertSpan (wrapSpanContext spanCtx) ctx+            bracket+                (attachContext newCtx)+                detachContext+                (const (runInIO body))+  where+    parentSpanContext hsList =+        let tp = fmap TE.encodeUtf8 (Prelude.lookup headerTraceParent hsList)+            ts = fmap TE.encodeUtf8 (Prelude.lookup headerTraceState hsList)+         in decodeSpanContext tp ts++{- | Open an @Internal@ span around a command run, named after the resolved+stream identifier. Attributes capture the stream name and (when the+caller supplies it) the retry attempt number. The number of events+appended is attached after a successful append by the caller via+'addAttribute span keiro_events_appended n'.+-}+withCommandSpan ::+    (MonadUnliftIO m, HasCallStack) =>+    Maybe Tracer ->+    -- | resolved stream name+    Text ->+    -- | retry attempt (1-based); 'Nothing' to omit+    Maybe Int64 ->+    (Maybe Span -> m a) ->+    m a+withCommandSpan Nothing _ _ body = body Nothing+withCommandSpan (Just tracer) streamName retryAttempt body =+    inSpan' tracer streamName args $ \sp -> do+        addAttribute sp (unkey keiro_stream_name) streamName+        case retryAttempt of+            Nothing -> pure ()+            Just n -> addAttribute sp (unkey keiro_retry_attempt) n+        body (Just sp)+  where+    args = defaultSpanArguments{kind = Internal}++{- | Open an @Internal@ span around a workflow run (or a single step/resume when+a 'StepName' is supplied), named @"workflow " <> name@. Attributes carry the+bespoke @keiro.workflow.name@, @keiro.workflow.id@, and — when present —+@keiro.workflow.step@ keys. Like 'withCommandSpan', a 'Nothing' tracer makes the+helper a pass-through, so it is safe to call unconditionally.+-}+withWorkflowSpan ::+    (MonadUnliftIO m, HasCallStack) =>+    Maybe Tracer ->+    WorkflowName ->+    WorkflowId ->+    Maybe StepName ->+    (Maybe Span -> m a) ->+    m a+withWorkflowSpan Nothing _ _ _ body = body Nothing+withWorkflowSpan (Just tracer) name wid mStep body =+    inSpan' tracer spanName args $ \sp -> do+        addAttribute sp (unkey keiro_workflow_name) (unWorkflowName name)+        addAttribute sp (unkey keiro_workflow_id) (unWorkflowId wid)+        case mStep of+            Nothing -> pure ()+            Just s -> addAttribute sp (unkey keiro_workflow_step) (unStepName s)+        body (Just sp)+  where+    spanName = "workflow " <> unWorkflowName name+    args = defaultSpanArguments{kind = Internal}++-- ---------------------------------------------------------------------------+-- W3C TraceContext bridge+-- ---------------------------------------------------------------------------++{- | Read the current thread-local span context and format it as a+'TraceContext'. Returns 'Nothing' when no span is active on the current+thread.++The application is expected to have already configured the W3C+propagator on its 'TracerProvider' (so the propagator is responsible for+on-the-wire framing); this helper is the keiro-side bridge between the+in-memory span and the keiro 'TraceContext' record stored on+'IntegrationEvent' envelopes and outbox rows.+-}+traceContextFromCurrentSpan :: (MonadIO m) => m (Maybe TraceContext)+traceContextFromCurrentSpan = do+    ctx <- getContext+    case lookupSpan ctx of+        Nothing -> pure Nothing+        Just sp -> do+            (traceparentBytes, tracestateBytes) <- liftIO (encodeSpanContext sp)+            let traceparent = TE.decodeUtf8 traceparentBytes+                tracestate+                    | ByteString.null tracestateBytes = Nothing+                    | otherwise = Just (TE.decodeUtf8 tracestateBytes)+            pure (Just (TraceContext traceparent tracestate))++{- | Lift a 'TraceContext' out of a flat @[(Text, Text)]@ header list. This+is the mirror image of 'integrationHeaders': it does not validate the+@traceparent@ format (the W3C propagator's parser does that at consume+time); it merely converts the on-the-wire pair of headers to the keiro+envelope record.+-}+traceContextFromHeaders :: [(Text, Text)] -> Maybe TraceContext+traceContextFromHeaders hs = case Prelude.lookup headerTraceParent hs of+    Nothing -> Nothing+    Just tp -> Just (TraceContext tp (Prelude.lookup headerTraceState hs))++{- | Append the W3C @traceparent@ / @tracestate@ headers for the current+thread-local span to the supplied header list. When no span is active+on the current thread, the input list is returned unchanged.++Used by adapters that build a flat header list from their own envelope+(e.g. the outbox publisher) so the headers carry the active span+context even if the caller did not capture a 'TraceContext' onto the+event explicitly.+-}+injectTraceContext :: (MonadIO m) => [(Text, Text)] -> m [(Text, Text)]+injectTraceContext hs = do+    mctx <- traceContextFromCurrentSpan+    pure $ case mctx of+        Nothing -> hs+        Just tc ->+            hs+                ++ [(headerTraceParent, tc ^. #traceparent)]+                ++ maybe [] (\ts -> [(headerTraceState, ts)]) (tc ^. #tracestate)++-- ---------------------------------------------------------------------------+-- Internal helpers+-- ---------------------------------------------------------------------------++setProducerAttributes ::+    (MonadIO m) => Span -> IntegrationEvent -> KafkaProducerRecord -> m ()+setProducerAttributes sp event _record = do+    addAttribute sp (unkey messaging_system) ("kafka" :: Text)+    addAttribute sp (unkey messaging_operation_type) ("publish" :: Text)+    addAttribute sp (unkey messaging_operation_name) ("send" :: Text)+    addAttribute sp (unkey messaging_destination_name) (event ^. #destination)+    addAttribute sp (unkey messaging_message_id) (event ^. #messageId)+    case event ^. #key of+        Nothing -> pure ()+        Just k -> addAttribute sp (unkey messaging_kafka_message_key) k++setConsumerAttributes ::+    (MonadIO m) =>+    Span ->+    Maybe Text ->+    KafkaInboundRecord ->+    Maybe IntegrationEvent ->+    m ()+setConsumerAttributes sp consumerGroup record mEvent = do+    addAttribute sp (unkey messaging_system) ("kafka" :: Text)+    addAttribute sp (unkey messaging_operation_type) ("process" :: Text)+    addAttribute sp (unkey messaging_operation_name) ("process" :: Text)+    addAttribute sp (unkey messaging_destination_name) (record ^. #topic)+    addAttribute sp (unkey messaging_destination_partition_id) (showText (record ^. #partition))+    addAttribute sp (unkey messaging_kafka_offset) (record ^. #offset)+    case record ^. #key of+        Nothing -> pure ()+        Just k -> addAttribute sp (unkey messaging_kafka_message_key) k+    case consumerGroup of+        Nothing -> pure ()+        Just g -> addAttribute sp (unkey messaging_consumer_group_name) g+    case mEvent of+        Nothing -> pure ()+        Just event -> addAttribute sp (unkey messaging_message_id) (event ^. #messageId)++showText :: (Show a) => a -> Text+showText = Text.pack . show++-- ---------------------------------------------------------------------------+-- Metrics surface+-- ---------------------------------------------------------------------------++{- $metrics+Alongside the span helpers above, 'Keiro.Telemetry' exposes the library's+metrics surface: a 'KeiroMetrics' record holding every instrument keiro+records (built once from a 'Meter' by 'newKeiroMetrics'), and one+@record*@ helper per instrument that takes a @'Maybe' 'KeiroMetrics'@ and+no-ops on 'Nothing'. This mirrors the @'Maybe' 'Tracer'@ opt-in the span+helpers use: an application that never configures a 'MeterProvider' pays+only one 'Maybe' branch per recording site. The per-instrument name, unit,+kind, and description are catalogued in+@docs/research/opentelemetry-semconv-audit.md@.+-}++{- | The instrumentation scope keiro tags all its metric instruments with.+Mirrors the @"keiro"@ scope name the span helpers use on the application's+'Tracer'.+-}+keiroInstrumentationLibrary :: InstrumentationLibrary+keiroInstrumentationLibrary =+    InstrumentationLibrary+        { libraryName = "keiro"+        , libraryVersion = ""+        , librarySchemaUrl = ""+        , libraryAttributes = emptyAttributes+        }++keiroOutboxBacklogName :: Text+keiroOutboxBacklogName = "keiro.outbox.backlog"+keiroOutboxPublishedName :: Text+keiroOutboxPublishedName = "keiro.outbox.published"+keiroOutboxRetriedName :: Text+keiroOutboxRetriedName = "keiro.outbox.retried"+keiroOutboxDeadletteredName :: Text+keiroOutboxDeadletteredName = "keiro.outbox.deadlettered"+keiroOutboxReclaimedName :: Text+keiroOutboxReclaimedName = "keiro.outbox.reclaimed"+keiroInboxProcessedName :: Text+keiroInboxProcessedName = "keiro.inbox.processed"+keiroInboxDuplicatesName :: Text+keiroInboxDuplicatesName = "keiro.inbox.duplicates"+keiroInboxFailedName :: Text+keiroInboxFailedName = "keiro.inbox.failed"+keiroInboxPoisonedName :: Text+keiroInboxPoisonedName = "keiro.inbox.poisoned"+keiroInboxBacklogName :: Text+keiroInboxBacklogName = "keiro.inbox.backlog"+keiroTimerBacklogName :: Text+keiroTimerBacklogName = "keiro.timer.backlog"+keiroTimerFireLagName :: Text+keiroTimerFireLagName = "keiro.timer.fire.lag"+keiroTimerAttemptsName :: Text+keiroTimerAttemptsName = "keiro.timer.attempts"+keiroTimerStuckName :: Text+keiroTimerStuckName = "keiro.timer.stuck"+keiroTimerRequeuedName :: Text+keiroTimerRequeuedName = "keiro.timer.requeued"+keiroProjectionLagName :: Text+keiroProjectionLagName = "keiro.projection.lag"+keiroProjectionWaitTimeoutsName :: Text+keiroProjectionWaitTimeoutsName = "keiro.projection.wait.timeouts"+keiroCommandConflictsName :: Text+keiroCommandConflictsName = "keiro.command.conflicts"+keiroCommandRetriesName :: Text+keiroCommandRetriesName = "keiro.command.retries"+keiroCommandDuplicatesName :: Text+keiroCommandDuplicatesName = "keiro.command.duplicates"+keiroSnapshotDecodeFailuresName :: Text+keiroSnapshotDecodeFailuresName = "keiro.snapshot.decode.failures"+keiroSnapshotEncodeFailuresName :: Text+keiroSnapshotEncodeFailuresName = "keiro.snapshot.encode.failures"+keiroSnapshotReadHitsName :: Text+keiroSnapshotReadHitsName = "keiro.snapshot.read.hits"+keiroSnapshotReadMissesName :: Text+keiroSnapshotReadMissesName = "keiro.snapshot.read.misses"+keiroSnapshotWriteFailuresName :: Text+keiroSnapshotWriteFailuresName = "keiro.snapshot.write.failures"+keiroSnapshotApplyDivergenceName :: Text+keiroSnapshotApplyDivergenceName = "keiro.snapshot.apply.divergence"+keiroDispatchFailedName :: Text+keiroDispatchFailedName = "keiro.dispatch.failed"+keiroDispatchDeadletteredName :: Text+keiroDispatchDeadletteredName = "keiro.dispatch.deadlettered"+keiroSubscriptionDeadletteredName :: Text+keiroSubscriptionDeadletteredName = "keiro.subscription.deadlettered"+keiroDispatchDuplicatesName :: Text+keiroDispatchDuplicatesName = "keiro.dispatch.duplicates"+keiroDispatchPoisonName :: Text+keiroDispatchPoisonName = "keiro.dispatch.poison"+keiroWorkflowStepsExecutedName :: Text+keiroWorkflowStepsExecutedName = "keiro.workflow.steps.executed"+keiroWorkflowStepsReplayedName :: Text+keiroWorkflowStepsReplayedName = "keiro.workflow.steps.replayed"+keiroWorkflowResumedName :: Text+keiroWorkflowResumedName = "keiro.workflow.resumed"+keiroWorkflowFailedName :: Text+keiroWorkflowFailedName = "keiro.workflow.failed"+keiroWorkflowResumeErrorsName :: Text+keiroWorkflowResumeErrorsName = "keiro.workflow.resume.errors"+keiroWorkflowLeaseSkippedName :: Text+keiroWorkflowLeaseSkippedName = "keiro.workflow.lease.skipped"+keiroWorkflowJournalLengthName :: Text+keiroWorkflowJournalLengthName = "keiro.workflow.journal.length"+keiroWorkflowAwakeablesPendingName :: Text+keiroWorkflowAwakeablesPendingName = "keiro.workflow.awakeables.pending"+keiroWorkflowActiveName :: Text+keiroWorkflowActiveName = "keiro.workflow.active"++{- | All metric instruments the keiro library records, built once from a+'Meter' by 'newKeiroMetrics'. Workers accept a @'Maybe' 'KeiroMetrics'@ and+treat 'Nothing' as "record nothing"; the per-instrument recording helpers in+this module take @'Maybe' 'KeiroMetrics'@ so call sites stay one-liners.++Instrument kinds follow the keiro metrics policy: backlog and lag are+synchronous gauges recorded by each worker per poll pass; tallies are+monotonic counters; distributions are histograms. See+@docs/research/opentelemetry-semconv-audit.md@ for the per-instrument+name / unit / kind / description catalogue.+-}+data KeiroMetrics = KeiroMetrics+    { outboxBacklog :: Gauge Int64+    , outboxPublished :: Counter Int64+    , outboxRetried :: Counter Int64+    , outboxDeadlettered :: Counter Int64+    , outboxReclaimed :: Counter Int64+    , inboxProcessed :: Counter Int64+    , inboxDuplicates :: Counter Int64+    , inboxFailed :: Counter Int64+    , inboxPoisoned :: Counter Int64+    , inboxBacklog :: Gauge Int64+    , timerBacklog :: Gauge Int64+    , timerFireLag :: Histogram+    , timerAttempts :: Histogram+    , timerStuck :: Gauge Int64+    , timerRequeued :: Counter Int64+    , projectionLag :: Gauge Int64+    , projectionWaitTimeouts :: Counter Int64+    , commandConflicts :: Counter Int64+    , commandRetries :: Counter Int64+    , commandDuplicates :: Counter Int64+    , snapshotDecodeFailures :: Counter Int64+    , snapshotEncodeFailures :: Counter Int64+    , snapshotReadHits :: Counter Int64+    , snapshotReadMisses :: Counter Int64+    , snapshotWriteFailures :: Counter Int64+    , snapshotApplyDivergence :: Counter Int64+    , dispatchFailed :: Counter Int64+    , dispatchDeadlettered :: Counter Int64+    , subscriptionDeadlettered :: Counter Int64+    , dispatchDuplicates :: Counter Int64+    , dispatchPoison :: Counter Int64+    , workflowStepsExecuted :: Counter Int64+    , workflowStepsReplayed :: Counter Int64+    , workflowResumed :: Counter Int64+    , workflowFailed :: Counter Int64+    , workflowResumeErrors :: Counter Int64+    , workflowLeaseSkipped :: Counter Int64+    , workflowActive :: Gauge Int64+    , workflowJournalLength :: Histogram+    , workflowAwakeablesPending :: Gauge Int64+    }++{- | Construct every keiro metric instrument from a 'Meter'. Call this once at+application start after building an SDK 'OpenTelemetry.Metric.Core.MeterProvider'+and obtaining a 'Meter' (e.g. @getMeter mp keiroInstrumentationLibrary@), then+thread the resulting 'KeiroMetrics' into workers as @'Just' metrics@. Under a+no-op meter every instrument is itself a no-op, so this is safe to call+unconditionally.+-}+newKeiroMetrics :: (MonadIO m) => Meter -> m KeiroMetrics+newKeiroMetrics meter = liftIO $ do+    outboxBacklog' <- gaugeI64 keiroOutboxBacklogName "{event}" "Outbox rows awaiting publish."+    outboxPublished' <- counterI64 keiroOutboxPublishedName "{event}" "Outbox events successfully published."+    outboxRetried' <- counterI64 keiroOutboxRetriedName "{event}" "Outbox publish attempts that failed and will retry."+    outboxDeadlettered' <- counterI64 keiroOutboxDeadletteredName "{event}" "Outbox events parked after exhausting retries."+    outboxReclaimed' <- counterI64 keiroOutboxReclaimedName "{event}" "Outbox rows reclaimed from a crashed or stalled publisher."+    inboxProcessed' <- counterI64 keiroInboxProcessedName "{message}" "Inbox messages processed successfully."+    inboxDuplicates' <- counterI64 keiroInboxDuplicatesName "{message}" "Inbox messages skipped as duplicates."+    inboxFailed' <- counterI64 keiroInboxFailedName "{message}" "Inbox messages whose handler failed."+    inboxPoisoned' <- counterI64 keiroInboxPoisonedName "{message}" "Inbox messages dead-lettered after exhausting handler attempts."+    inboxBacklog' <- gaugeI64 keiroInboxBacklogName "{message}" "Inbox messages awaiting processing."+    timerBacklog' <- gaugeI64 keiroTimerBacklogName "{timer}" "Due timers awaiting firing."+    timerFireLag' <- histogram keiroTimerFireLagName "ms" "Delay between a timer's scheduled time and when it fired."+    timerAttempts' <- histogram keiroTimerAttemptsName "{attempt}" "Number of attempts a timer took to fire."+    timerStuck' <- gaugeI64 keiroTimerStuckName "{timer}" "Timers stuck in the Firing state past threshold."+    timerRequeued' <- counterI64 keiroTimerRequeuedName "{timer}" "Timers moved from firing back to scheduled after a stale claim."+    projectionLag' <- gaugeI64 keiroProjectionLagName "{event}" "Events between the log head and a projection's checkpoint."+    projectionWaitTimeouts' <- counterI64 keiroProjectionWaitTimeoutsName "{timeout}" "Position-wait calls that timed out before the projection caught up."+    commandConflicts' <- counterI64 keiroCommandConflictsName "{conflict}" "Optimistic-concurrency conflicts observed by command runners."+    commandRetries' <- counterI64 keiroCommandRetriesName "{retry}" "Command retry attempts started after an optimistic-concurrency conflict."+    commandDuplicates' <- counterI64 keiroCommandDuplicatesName "{event}" "Command appends rejected as duplicate deterministic event ids."+    snapshotDecodeFailures' <- counterI64 keiroSnapshotDecodeFailuresName "{failure}" "Snapshot rows whose bytes failed to decode; hydration fell back to full replay."+    snapshotEncodeFailures' <- counterI64 keiroSnapshotEncodeFailuresName "{failure}" "Post-commit snapshot encodes that failed and were swallowed."+    snapshotReadHits' <- counterI64 keiroSnapshotReadHitsName "{read}" "Snapshot lookups that yielded a usable hydration seed."+    snapshotReadMisses' <- counterI64 keiroSnapshotReadMissesName "{read}" "Snapshot lookups that fell back to full replay."+    snapshotWriteFailures' <- counterI64 keiroSnapshotWriteFailuresName "{failure}" "Post-commit snapshot writes that failed and were swallowed."+    snapshotApplyDivergence' <- counterI64 keiroSnapshotApplyDivergenceName "{failure}" "Just-appended event batches that failed to replay from the pre-command state; the stream is poisoned and its next hydration will fail."+    dispatchFailed' <- counterI64 keiroDispatchFailedName "{command}" "Process-manager/router dispatch commands that failed."+    dispatchDeadlettered' <- counterI64 keiroDispatchDeadletteredName "{command}" "Rejected process-manager/router dispatch commands handled by dead-letter or skip policy."+    subscriptionDeadlettered' <- counterI64 keiroSubscriptionDeadletteredName "{event}" "Kiroku source events dead-lettered by an explicit disposition or retry exhaustion."+    dispatchDuplicates' <- counterI64 keiroDispatchDuplicatesName "{command}" "Process-manager/router dispatch commands skipped as duplicate deterministic event ids."+    dispatchPoison' <- counterI64 keiroDispatchPoisonName "{message}" "Process-manager/router worker messages classified as poison."+    workflowStepsExecuted' <- counterI64 keiroWorkflowStepsExecutedName "{step}" "Workflow steps that ran their action (a journal miss)."+    workflowStepsReplayed' <- counterI64 keiroWorkflowStepsReplayedName "{step}" "Workflow steps short-circuited to a recorded result (a journal hit)."+    workflowResumed' <- counterI64 keiroWorkflowResumedName "{workflow}" "Workflow re-invocations performed by the resume worker."+    workflowFailed' <- counterI64 keiroWorkflowFailedName "{workflow}" "Workflow instances marked terminally failed by the resume worker."+    workflowResumeErrors' <- counterI64 keiroWorkflowResumeErrorsName "{error}" "Transient store errors observed by the workflow resume worker."+    workflowLeaseSkipped' <- counterI64 keiroWorkflowLeaseSkippedName "{workflow}" "Workflow instances skipped because another worker owns their lease."+    workflowActive' <- gaugeI64 keiroWorkflowActiveName "{workflow}" "Workflow runs currently in progress in this process."+    workflowJournalLength' <- histogram keiroWorkflowJournalLengthName "{event}" "Journal event count of a workflow at completion."+    workflowAwakeablesPending' <- gaugeI64 keiroWorkflowAwakeablesPendingName "{awakeable}" "Awakeables awaiting an external signal."+    pure+        KeiroMetrics+            { outboxBacklog = outboxBacklog'+            , outboxPublished = outboxPublished'+            , outboxRetried = outboxRetried'+            , outboxDeadlettered = outboxDeadlettered'+            , outboxReclaimed = outboxReclaimed'+            , inboxProcessed = inboxProcessed'+            , inboxDuplicates = inboxDuplicates'+            , inboxFailed = inboxFailed'+            , inboxPoisoned = inboxPoisoned'+            , inboxBacklog = inboxBacklog'+            , timerBacklog = timerBacklog'+            , timerFireLag = timerFireLag'+            , timerAttempts = timerAttempts'+            , timerStuck = timerStuck'+            , timerRequeued = timerRequeued'+            , projectionLag = projectionLag'+            , projectionWaitTimeouts = projectionWaitTimeouts'+            , commandConflicts = commandConflicts'+            , commandRetries = commandRetries'+            , commandDuplicates = commandDuplicates'+            , snapshotDecodeFailures = snapshotDecodeFailures'+            , snapshotEncodeFailures = snapshotEncodeFailures'+            , snapshotReadHits = snapshotReadHits'+            , snapshotReadMisses = snapshotReadMisses'+            , snapshotWriteFailures = snapshotWriteFailures'+            , snapshotApplyDivergence = snapshotApplyDivergence'+            , dispatchFailed = dispatchFailed'+            , dispatchDeadlettered = dispatchDeadlettered'+            , subscriptionDeadlettered = subscriptionDeadlettered'+            , dispatchDuplicates = dispatchDuplicates'+            , dispatchPoison = dispatchPoison'+            , workflowStepsExecuted = workflowStepsExecuted'+            , workflowStepsReplayed = workflowStepsReplayed'+            , workflowResumed = workflowResumed'+            , workflowFailed = workflowFailed'+            , workflowResumeErrors = workflowResumeErrors'+            , workflowLeaseSkipped = workflowLeaseSkipped'+            , workflowActive = workflowActive'+            , workflowJournalLength = workflowJournalLength'+            , workflowAwakeablesPending = workflowAwakeablesPending'+            }+  where+    counterI64 :: Text -> Text -> Text -> IO (Counter Int64)+    counterI64 name unit desc =+        meterCreateCounterInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters+    gaugeI64 :: Text -> Text -> Text -> IO (Gauge Int64)+    gaugeI64 name unit desc =+        meterCreateGaugeInt64 meter name (Just unit) (Just desc) defaultAdvisoryParameters+    histogram :: Text -> Text -> Text -> IO Histogram+    histogram name unit desc =+        meterCreateHistogram meter name (Just unit) (Just desc) defaultAdvisoryParameters++-- Internal: record an Int64 on the counter selected by @sel@, or do nothing.+recordCounter ::+    (MonadIO m) => (KeiroMetrics -> Counter Int64) -> Maybe KeiroMetrics -> Int64 -> m ()+recordCounter _ Nothing _ = pure ()+recordCounter sel (Just ms) n = liftIO (counterAdd (sel ms) n emptyAttributes)++-- Internal: record an Int64 on the gauge selected by @sel@, or do nothing.+recordGaugeI64 ::+    (MonadIO m) => (KeiroMetrics -> Gauge Int64) -> Maybe KeiroMetrics -> Int64 -> m ()+recordGaugeI64 _ Nothing _ = pure ()+recordGaugeI64 sel (Just ms) n = liftIO (gaugeRecord (sel ms) n emptyAttributes)++-- Internal: record a Double on the histogram selected by @sel@, or do nothing.+recordHistogram ::+    (MonadIO m) => (KeiroMetrics -> Histogram) -> Maybe KeiroMetrics -> Double -> m ()+recordHistogram _ Nothing _ = pure ()+recordHistogram sel (Just ms) v = liftIO (histogramRecord (sel ms) v emptyAttributes)++recordOutboxBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordOutboxBacklog = recordGaugeI64 outboxBacklog+recordOutboxPublished :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordOutboxPublished = recordCounter outboxPublished+recordOutboxRetried :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordOutboxRetried = recordCounter outboxRetried+recordOutboxDeadlettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordOutboxDeadlettered = recordCounter outboxDeadlettered+recordOutboxReclaimed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordOutboxReclaimed = recordCounter outboxReclaimed+recordInboxProcessed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordInboxProcessed = recordCounter inboxProcessed+recordInboxDuplicates :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordInboxDuplicates = recordCounter inboxDuplicates+recordInboxFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordInboxFailed = recordCounter inboxFailed+recordInboxPoisoned :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordInboxPoisoned = recordCounter inboxPoisoned+recordInboxBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordInboxBacklog = recordGaugeI64 inboxBacklog+recordTimerBacklog :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordTimerBacklog = recordGaugeI64 timerBacklog+recordTimerFireLag :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m ()+recordTimerFireLag = recordHistogram timerFireLag+recordTimerAttempts :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m ()+recordTimerAttempts = recordHistogram timerAttempts+recordTimerStuck :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordTimerStuck = recordGaugeI64 timerStuck+recordTimerRequeued :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordTimerRequeued = recordCounter timerRequeued+recordProjectionLag :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordProjectionLag = recordGaugeI64 projectionLag+recordProjectionWaitTimeouts :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordProjectionWaitTimeouts = recordCounter projectionWaitTimeouts+recordCommandConflicts :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordCommandConflicts = recordCounter commandConflicts+recordCommandRetries :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordCommandRetries = recordCounter commandRetries+recordCommandDuplicates :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordCommandDuplicates = recordCounter commandDuplicates+recordSnapshotDecodeFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordSnapshotDecodeFailures = recordCounter snapshotDecodeFailures+recordSnapshotEncodeFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordSnapshotEncodeFailures = recordCounter snapshotEncodeFailures+recordSnapshotReadHits :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordSnapshotReadHits = recordCounter snapshotReadHits+recordSnapshotReadMisses :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordSnapshotReadMisses = recordCounter snapshotReadMisses+recordSnapshotWriteFailures :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordSnapshotWriteFailures = recordCounter snapshotWriteFailures+recordSnapshotApplyDivergence :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordSnapshotApplyDivergence = recordCounter snapshotApplyDivergence+recordDispatchFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordDispatchFailed = recordCounter dispatchFailed+recordDispatchDeadLettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordDispatchDeadLettered = recordCounter dispatchDeadlettered+recordSubscriptionDeadLettered :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordSubscriptionDeadLettered = recordCounter subscriptionDeadlettered+recordDispatchDuplicate :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordDispatchDuplicate = recordCounter dispatchDuplicates+recordDispatchPoison :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordDispatchPoison = recordCounter dispatchPoison+recordWorkflowStepExecuted :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordWorkflowStepExecuted = recordCounter workflowStepsExecuted+recordWorkflowStepReplayed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordWorkflowStepReplayed = recordCounter workflowStepsReplayed+recordWorkflowResumed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordWorkflowResumed = recordCounter workflowResumed+recordWorkflowFailed :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordWorkflowFailed = recordCounter workflowFailed+recordWorkflowResumeErrors :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordWorkflowResumeErrors = recordCounter workflowResumeErrors+recordWorkflowLeaseSkipped :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordWorkflowLeaseSkipped = recordCounter workflowLeaseSkipped+recordWorkflowActive :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordWorkflowActive = recordGaugeI64 workflowActive+recordWorkflowJournalLength :: (MonadIO m) => Maybe KeiroMetrics -> Double -> m ()+recordWorkflowJournalLength = recordHistogram workflowJournalLength+recordWorkflowAwakeablesPending :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordWorkflowAwakeablesPending = recordGaugeI64 workflowAwakeablesPending++{- | Feed Kiroku store events into Keiro metrics, then delegate every event to+the application's existing event handler. Install this as (or inside) the+@eventHandler@ on Kiroku's @ConnectionSettings@ at store construction; pass+@const (pure ())@ when there is no other handler.++'KirokuEventSubscriptionDeadLettered' is the terminal retry-exhaustion signal:+the acknowledgement bridge exposes the current delivery attempt, but does not+tell a handler that its retry reply consumed the final attempt. For current+dead-letter depth, query Kiroku's durable table rather than treating this+monotonic counter as a gauge:++> SELECT count(*) FROM kiroku.dead_letters WHERE subscription_name = $1++The delegate runs synchronously, matching Kiroku's event-handler contract, so+it should remain fast and non-blocking.+-}+kirokuEventBridge :: Maybe KeiroMetrics -> (KirokuEvent -> IO ()) -> KirokuEvent -> IO ()+kirokuEventBridge metrics delegate event = do+    case event of+        KirokuEventSubscriptionDeadLettered{} -> recordSubscriptionDeadLettered metrics 1+        _ -> pure ()+    delegate event
+ src/Keiro/Timer.hs view
@@ -0,0 +1,179 @@+{- | Durable timers for process managers.++A process manager schedules a timer ('scheduleTimerTx', in its own append+transaction) to be woken at a future time — a saga timeout, a retry delay, a+deadline. The 'runTimerWorker' loop claims one due timer at a time with+@FOR UPDATE SKIP LOCKED@ (so multiple workers can run safely), hands it to a+caller-supplied @fire@ action that typically dispatches a command back into+the manager, and marks it fired once the resulting event id is known. A+timer left @Firing@ by a crash becomes claimable again after the worker's+configured stale-claim timeout, giving at-least-once firing.++The wire types live in "Keiro.Timer.Types" and the SQL storage in+"Keiro.Timer.Schema"; both are re-exported here so most callers need only+import @Keiro.Timer@.+-}+module Keiro.Timer (+    -- * Timer types+    TimerId (..),+    TimerRequest (..),+    TimerRow (..),+    TimerStatus (..),++    -- * Storage+    scheduleTimerTx,+    scheduleTimerOnceTx,+    claimDueTimer,+    markTimerFired,+    countDueTimers,+    countStuckTimers,++    -- * Recovery+    StuckTimerFilter (..),+    anyStuckTimer,+    findStuckTimers,+    requeueStuckTimers,+    requeueStuckTimer,+    cancelTimer,+    deadLetterTimer,++    -- * Worker+    TimerWorkerOptions (..),+    TimerWorkerConfigError (..),+    defaultTimerWorkerOptions,+    mkTimerWorkerOptions,+    runTimerWorker,+    runTimerWorkerWith,+)+where++import Data.Text qualified as Text+import Data.Time.Clock (NominalDiffTime, diffUTCTime)+import Effectful (Eff, IOE, (:>))+import Keiro.Prelude+import Keiro.Telemetry (+    KeiroMetrics,+    recordTimerAttempts,+    recordTimerBacklog,+    recordTimerFireLag,+    recordTimerRequeued,+    recordTimerStuck,+ )+import Keiro.Timer.Schema+import Keiro.Timer.Types+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Types (EventId)++-- | Options controlling 'runTimerWorkerWith'.+data TimerWorkerOptions = TimerWorkerOptions+    { maxAttempts :: Maybe Int+    {- ^ When @Just n@, a claimed timer whose post-claim @attempts@ exceeds @n@ is+    moved to 'Dead' (via 'deadLetterTimer') instead of being fired. @Nothing@+    never auto-dead-letters (the historical behavior).+    -}+    , requeueStuckAfter :: !(Maybe NominalDiffTime)+    {- ^ When @Just ttl@, each worker pass first moves @Firing@ timers whose+    @updated_at@ is at least @ttl@ old back to 'Scheduled'. A fire action that+    runs longer than this timeout may be fired again; timer handlers must be+    idempotent under keiro's at-least-once timer contract. @Nothing@ disables+    automatic requeue for callers that run their own recovery.+    -}+    }+    deriving stock (Generic, Eq, Show)++data TimerWorkerConfigError+    = InvalidTimerMaxAttempts !Int+    | InvalidTimerRequeueStuckAfter !NominalDiffTime+    deriving stock (Generic, Eq, Show)++-- | The default worker policy: never auto-dead-letter; requeue stale firings after five minutes.+defaultTimerWorkerOptions :: TimerWorkerOptions+defaultTimerWorkerOptions = TimerWorkerOptions{maxAttempts = Nothing, requeueStuckAfter = Just 300}++-- | Validate timer worker options before starting a worker loop.+mkTimerWorkerOptions :: TimerWorkerOptions -> Either TimerWorkerConfigError TimerWorkerOptions+mkTimerWorkerOptions opts =+    case (opts ^. #maxAttempts, opts ^. #requeueStuckAfter) of+        (Just attempts, _) | attempts < 0 -> Left (InvalidTimerMaxAttempts attempts)+        (_, Just ttl) | ttl <= 0 -> Left (InvalidTimerRequeueStuckAfter ttl)+        _ -> Right opts++{- | Claim and fire at most one timer due at @now@, applying the given+'TimerWorkerOptions'.++Atomically claims the earliest due timer (marking it @Firing@). If the options+set @maxAttempts = Just n@ and the timer's post-claim @attempts@ exceeds @n@, it+is dead-lettered ('Dead', with an explanatory @last_error@) instead of fired —+rather than ping-ponging forever on a timer that never completes. Before+claiming, the worker requeues stale @Firing@ rows according to+'requeueStuckAfter'. Otherwise the caller's @fire@ action runs and — if it+returns the id of the event it produced — the timer is marked @Fired@. Returns+the claimed 'TimerRow' (the row as claimed, before any dead-letter or fire+UPDATE), or 'Nothing' when nothing is due. A @fire@ that returns 'Nothing'+leaves the timer @Firing@ until it becomes stale and is requeued on a later+worker pass.++A timer may fire more than once if a worker crashes after the external action+but before 'markTimerFired', or if @fire@ takes longer than 'requeueStuckAfter'.+Handlers must therefore be idempotent.++Note 'claimDueTimer' increments @attempts@ before this check, so the comparison+sees the post-claim count: with @maxAttempts = Just 0@ the very first claim+dead-letters; with @Just 2@ the third claim does.+-}+runTimerWorkerWith ::+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    TimerWorkerOptions ->+    UTCTime ->+    (TimerRow -> Eff es (Maybe EventId)) ->+    Eff es (Maybe TimerRow)+runTimerWorkerWith metrics options now fire = do+    for_ (options ^. #requeueStuckAfter) $ \ttl -> do+        requeued <- requeueStuckTimers ttl now+        recordTimerRequeued metrics (fromIntegral requeued)+    -- Gauges recorded once per pass, before the claim, off the counts the worker+    -- already needs its 'Store' for: the backlog as the worker sees it at the+    -- start of the pass (including the row it is about to claim), and the number+    -- of rows stranded in 'Firing' by earlier passes that never completed. Each+    -- is a no-op under a 'Nothing' handle.+    backlog <- countDueTimers now+    recordTimerBacklog metrics (fromIntegral backlog)+    stuck <- countStuckTimers now anyStuckTimer+    recordTimerStuck metrics (fromIntegral stuck)+    due <- claimDueTimer now+    case due of+        Nothing -> pure Nothing+        Just timer -> do+            -- Histograms for the claimed timer: how late it fired and how many+            -- attempts it has now taken. EP-33 declared 'keiro.timer.fire.lag' in+            -- milliseconds, so the seconds 'diffUTCTime' yields are scaled by 1000.+            -- The lag is non-negative because only fire_at <= now rows are claimable.+            recordTimerFireLag metrics (realToFrac (now `diffUTCTime` (timer ^. #fireAt)) * 1000)+            recordTimerAttempts metrics (fromIntegral (timer ^. #attempts))+            case options ^. #maxAttempts of+                Just attemptCeiling+                    | (timer ^. #attempts) > attemptCeiling -> do+                        _ <-+                            deadLetterTimer+                                (timer ^. #timerId)+                                ("timer exceeded attempt ceiling of " <> Text.pack (show attemptCeiling))+                        pure (Just timer)+                _ -> do+                    fired <- fire timer+                    for_ fired (\eventId -> void (markTimerFired (timer ^. #timerId) eventId))+                    pure (Just timer)++{- | Claim and fire at most one timer due at @now@ using+'defaultTimerWorkerOptions' (no attempt ceiling). Equivalent to+@'runTimerWorkerWith' 'defaultTimerWorkerOptions'@; the default has no attempt+ceiling and requeues claims left @Firing@ for five minutes. See+'runTimerWorkerWith' for the full semantics.+-}+runTimerWorker ::+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    UTCTime ->+    (TimerRow -> Eff es (Maybe EventId)) ->+    Eff es (Maybe TimerRow)+runTimerWorker metrics = runTimerWorkerWith metrics defaultTimerWorkerOptions
+ src/Keiro/Timer/Schema.hs view
@@ -0,0 +1,457 @@+{- | The @keiro_timers@ table: storage and claim logic for durable timers.++Holds one row per scheduled timer with its 'TimerStatus' lifecycle.+'scheduleTimerTx' inserts (or re-arms a still-@Scheduled@ timer with the same+id) inside the caller's transaction; 'claimDueTimer' atomically picks the+single earliest due timer with @FOR UPDATE SKIP LOCKED@ and moves it to+@Firing@, so competing workers never claim the same timer; 'markTimerFired'+records completion and the produced event id. Stale @Firing@ rows are requeued+by 'requeueStuckTimers' so a crashed worker does not strand a timer forever.++Callers normally use the re-exports from "Keiro.Timer" rather than this+module directly.+-}+module Keiro.Timer.Schema (+    -- * Rows and status+    TimerStatus (..),+    TimerRow (..),++    -- * Storage+    scheduleTimerTx,+    scheduleTimerOnceTx,+    claimDueTimer,+    markTimerFired,++    -- * Read-only counts+    countDueTimers,+    countStuckTimers,++    -- * Recovery+    StuckTimerFilter (..),+    anyStuckTimer,+    findStuckTimers,+    requeueStuckTimers,+    requeueStuckTimer,+    cancelTimer,+    deadLetterTimer,+)+where++import Contravariant.Extras (contrazip2, contrazip6)+import Data.Time (NominalDiffTime, addUTCTime)+import Data.UUID (UUID)+import Effectful (Eff, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Prelude+import Keiro.Timer.Types (TimerId (..), TimerRequest (..))+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (EventId (..))+import "hasql-transaction" Hasql.Transaction qualified as Tx++{- | A timer's lifecycle state.++* 'Scheduled' — waiting for its 'fireAt'; claimable.+* 'Firing' — claimed by a worker and being processed; stale rows become+  claimable again when 'requeueStuckTimers' moves them back to 'Scheduled'.+* 'Fired' — successfully fired; terminal.+* 'Cancelled' — withdrawn before firing.+* 'Dead' — abandoned after exceeding the attempt ceiling; terminal; carries an+  optional @last_error@ describing why it was given up on.+-}+data TimerStatus+    = Scheduled+    | Firing+    | Fired+    | Cancelled+    | Dead+    deriving stock (Generic, Eq, Show)++{- | A timer row as stored: the original 'TimerRequest' fields plus the live+'status', the 'attempts' count (incremented on each claim), and the+'firedEventId' recorded once it fires.+-}+data TimerRow = TimerRow+    { timerId :: !TimerId+    , processManagerName :: !Text+    , correlationId :: !Text+    , fireAt :: !UTCTime+    , payload :: !Value+    , status :: !TimerStatus+    , attempts :: !Int+    , firedEventId :: !(Maybe EventId)+    }+    deriving stock (Generic, Eq, Show)++{- | Criteria selecting timers stranded in 'Firing'. A row is "stuck" when its+'status' is @firing@ and it matches every set bound: 'minAge' (it has been+firing at least this long, measured from @updated_at@) and 'minAttempts' (it+has been claimed at least this many times). Both unset selects every @firing@+row.+-}+data StuckTimerFilter = StuckTimerFilter+    { minAge :: !(Maybe NominalDiffTime)+    , minAttempts :: !(Maybe Int)+    }+    deriving stock (Generic, Eq, Show)++-- | Select every @firing@ row regardless of age or attempts.+anyStuckTimer :: StuckTimerFilter+anyStuckTimer = StuckTimerFilter Nothing Nothing++{- | Schedule a timer inside the caller's transaction (typically a process+manager's append). Upserts on 'timerId': a conflicting row is re-armed only+while it is still @Scheduled@, so a timer that has already fired or been+cancelled is not resurrected.+-}+scheduleTimerTx :: TimerRequest -> Tx.Transaction ()+scheduleTimerTx request =+    Tx.statement+        ( timerIdToUuid (request ^. #timerId)+        , request ^. #processManagerName+        , request ^. #correlationId+        , request ^. #fireAt+        , request ^. #payload+        , statusToText Scheduled+        )+        scheduleTimerStmt++{- | Schedule a timer only if no row with the same 'timerId' already exists.++This is for callers whose first arm must win, such as durable workflow sleeps:+every resume pass re-runs the sleep arm until the timer fires, and preserving+the original 'fireAt' keeps the sleep measured from the first arm. Process+managers that intentionally push a deadline back should keep using+'scheduleTimerTx'.+-}+scheduleTimerOnceTx :: TimerRequest -> Tx.Transaction ()+scheduleTimerOnceTx request =+    Tx.statement+        ( timerIdToUuid (request ^. #timerId)+        , request ^. #processManagerName+        , request ^. #correlationId+        , request ^. #fireAt+        , request ^. #payload+        , statusToText Scheduled+        )+        scheduleTimerOnceStmt++{- | Atomically claim the single earliest timer due at @now@, moving it to+@Firing@ and bumping its attempt count. Uses @FOR UPDATE SKIP LOCKED@ so+concurrent workers each get a distinct timer. Returns 'Nothing' when none is+due.+-}+claimDueTimer :: (Store :> es) => UTCTime -> Eff es (Maybe TimerRow)+claimDueTimer now =+    runTransaction $+        Tx.statement now claimDueTimerStmt++{- | Mark a claimed timer @Fired@, recording the id of the event its firing+produced. Returns 'False' when the row left @Firing@ while the fire action was+running (for example, it was requeued, cancelled, or dead-lettered).+-}+markTimerFired :: (Store :> es) => TimerId -> EventId -> Eff es Bool+markTimerFired timerId eventId =+    runTransaction $+        Tx.statement (timerIdToUuid timerId, eventIdToUuid eventId) markTimerFiredStmt++{- | Count timers that are @scheduled@ and already due at @now@ — the timer+backlog. Read-only; mirrors 'claimDueTimer''s WHERE clause but counts rather+than locking, so it never claims or mutates a row.+-}+countDueTimers :: (Store :> es) => UTCTime -> Eff es Int+countDueTimers now =+    runTransaction $+        Tx.statement now countDueTimersStmt++{- | Count timers stranded in @Firing@ that match the given 'StuckTimerFilter' —+the same "stuck" predicate 'findStuckTimers' lists, evaluated against @now@.+Read-only. 'anyStuckTimer' counts every @firing@ row.+-}+countStuckTimers :: (Store :> es) => UTCTime -> StuckTimerFilter -> Eff es Int+countStuckTimers now stuckFilter =+    runTransaction $+        Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) countStuckTimersStmt+  where+    cutoff = fmap (\age -> addUTCTime (negate age) now) (stuckFilter ^. #minAge)++{- | List timers stranded in @Firing@ that match the given 'StuckTimerFilter'.+The @minAge@ bound is evaluated against @now@: a row qualifies when its+@updated_at@ is at least @minAge@ in the past (cutoff @now - minAge@). Results+are ordered oldest-first by @updated_at@.+-}+findStuckTimers ::+    (Store :> es) => UTCTime -> StuckTimerFilter -> Eff es [TimerRow]+findStuckTimers now stuckFilter =+    runTransaction $+        Tx.statement (cutoff, fmap fromIntegral (stuckFilter ^. #minAttempts)) findStuckTimersStmt+  where+    cutoff = fmap (\age -> addUTCTime (negate age) now) (stuckFilter ^. #minAge)++{- | Move every timer stranded in @Firing@ for at least @olderThan@ back to+@Scheduled@. The statement preserves @fire_at@, so a due timer becomes+claimable on the same worker pass. Returns the number of rows requeued.+-}+requeueStuckTimers :: (Store :> es) => NominalDiffTime -> UTCTime -> Eff es Int+requeueStuckTimers olderThan now =+    runTransaction $+        Tx.statement cutoff requeueStuckTimersStmt+  where+    cutoff = addUTCTime (negate olderThan) now++{- | Move a timer from @Firing@ back to @Scheduled@ so the ordinary claim loop+re-fires it. Leaves @fire_at@ unchanged, so a due timer becomes immediately+re-claimable. Idempotent: only @firing@ rows match, so re-running on an+already-requeued row affects nothing. Returns 'True' when a row changed.+-}+requeueStuckTimer :: (Store :> es) => TimerId -> Eff es Bool+requeueStuckTimer timerId =+    runTransaction $+        Tx.statement (timerIdToUuid timerId) requeueStuckTimerStmt++{- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Cancelled@+state so it never fires. Terminal rows (@fired@, @cancelled@, @dead@) are left+untouched. Idempotent. Returns 'True' when a row changed.+-}+cancelTimer :: (Store :> es) => TimerId -> Eff es Bool+cancelTimer timerId =+    runTransaction $+        Tx.statement (timerIdToUuid timerId) cancelTimerStmt++{- | Move a timer from @Scheduled@ or @Firing@ to the terminal @Dead@ state,+recording @reason@ in @last_error@ so an operator can see why it was abandoned+(@SELECT * FROM keiro_timers WHERE status = 'dead'@). Terminal rows are left+untouched. Idempotent. Returns 'True' when a row changed.+-}+deadLetterTimer :: (Store :> es) => TimerId -> Text -> Eff es Bool+deadLetterTimer timerId reason =+    runTransaction $+        Tx.statement (timerIdToUuid timerId, reason) deadLetterTimerStmt++scheduleTimerStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) ()+scheduleTimerStmt =+    preparable+        """+        INSERT INTO keiro.keiro_timers+          (timer_id, process_manager_name, correlation_id, fire_at, payload, status)+        VALUES+          ($1, $2, $3, $4, $5, $6)+        ON CONFLICT (timer_id) DO UPDATE+          SET process_manager_name = EXCLUDED.process_manager_name,+              correlation_id = EXCLUDED.correlation_id,+              fire_at = EXCLUDED.fire_at,+              payload = EXCLUDED.payload,+              status = EXCLUDED.status,+              updated_at = now()+          WHERE keiro_timers.status = 'scheduled'+        """+        ( contrazip6+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.jsonb))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++scheduleTimerOnceStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) ()+scheduleTimerOnceStmt =+    preparable+        """+        INSERT INTO keiro.keiro_timers+          (timer_id, process_manager_name, correlation_id, fire_at, payload, status)+        VALUES+          ($1, $2, $3, $4, $5, $6)+        ON CONFLICT (timer_id) DO NOTHING+        """+        ( contrazip6+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.jsonb))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++claimDueTimerStmt :: Statement UTCTime (Maybe TimerRow)+claimDueTimerStmt =+    preparable+        """+        WITH due AS (+          SELECT timer_id+          FROM keiro.keiro_timers+          WHERE status = 'scheduled'+            AND fire_at <= $1+          ORDER BY fire_at, timer_id+          LIMIT 1+          FOR UPDATE SKIP LOCKED+        )+        UPDATE keiro.keiro_timers kt+        SET status = 'firing',+            attempts = kt.attempts + 1,+            updated_at = now()+        FROM due+        WHERE kt.timer_id = due.timer_id+        RETURNING kt.timer_id, kt.process_manager_name, kt.correlation_id, kt.fire_at,+          kt.payload, kt.status, kt.attempts, kt.fired_event_id+        """+        (E.param (E.nonNullable E.timestamptz))+        (D.rowMaybe timerRowDecoder)++markTimerFiredStmt :: Statement (UUID, UUID) Bool+markTimerFiredStmt =+    preparable+        """+        UPDATE keiro.keiro_timers+        SET status = 'fired',+            fired_event_id = $2,+            updated_at = now()+        WHERE timer_id = $1+          AND status = 'firing'+        """+        ( contrazip2+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.uuid))+        )+        ((> 0) <$> D.rowsAffected)++countDueTimersStmt :: Statement UTCTime Int+countDueTimersStmt =+    preparable+        """+        SELECT count(*)+        FROM keiro.keiro_timers+        WHERE status = 'scheduled'+          AND fire_at <= $1+        """+        (E.param (E.nonNullable E.timestamptz))+        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++countStuckTimersStmt :: Statement (Maybe UTCTime, Maybe Int64) Int+countStuckTimersStmt =+    preparable+        """+        SELECT count(*)+        FROM keiro.keiro_timers+        WHERE status = 'firing'+          AND ($1::timestamptz IS NULL OR updated_at <= $1)+          AND ($2::bigint IS NULL OR attempts >= $2)+        """+        ( contrazip2+            (E.param (E.nullable E.timestamptz))+            (E.param (E.nullable E.int8))+        )+        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++findStuckTimersStmt :: Statement (Maybe UTCTime, Maybe Int64) [TimerRow]+findStuckTimersStmt =+    preparable+        """+        SELECT timer_id, process_manager_name, correlation_id, fire_at,+          payload, status, attempts, fired_event_id+        FROM keiro.keiro_timers+        WHERE status = 'firing'+          AND ($1::timestamptz IS NULL OR updated_at <= $1)+          AND ($2::bigint IS NULL OR attempts >= $2)+        ORDER BY updated_at, timer_id+        """+        ( contrazip2+            (E.param (E.nullable E.timestamptz))+            (E.param (E.nullable E.int8))+        )+        (D.rowList timerRowDecoder)++requeueStuckTimersStmt :: Statement UTCTime Int+requeueStuckTimersStmt =+    preparable+        """+        UPDATE keiro.keiro_timers+        SET status = 'scheduled',+            updated_at = now()+        WHERE status = 'firing'+          AND updated_at <= $1+        """+        (E.param (E.nonNullable E.timestamptz))+        (fromIntegral <$> D.rowsAffected)++requeueStuckTimerStmt :: Statement UUID Bool+requeueStuckTimerStmt =+    preparable+        """+        UPDATE keiro.keiro_timers+        SET status = 'scheduled',+            updated_at = now()+        WHERE timer_id = $1+          AND status = 'firing'+        """+        (E.param (E.nonNullable E.uuid))+        ((> 0) <$> D.rowsAffected)++cancelTimerStmt :: Statement UUID Bool+cancelTimerStmt =+    preparable+        """+        UPDATE keiro.keiro_timers+        SET status = 'cancelled',+            updated_at = now()+        WHERE timer_id = $1+          AND status IN ('scheduled', 'firing')+        """+        (E.param (E.nonNullable E.uuid))+        ((> 0) <$> D.rowsAffected)++deadLetterTimerStmt :: Statement (UUID, Text) Bool+deadLetterTimerStmt =+    preparable+        """+        UPDATE keiro.keiro_timers+        SET status = 'dead',+            last_error = $2,+            updated_at = now()+        WHERE timer_id = $1+          AND status IN ('scheduled', 'firing')+        """+        ( contrazip2+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.text))+        )+        ((> 0) <$> D.rowsAffected)++timerRowDecoder :: D.Row TimerRow+timerRowDecoder =+    TimerRow+        <$> (TimerId <$> D.column (D.nonNullable D.uuid))+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nonNullable D.jsonb)+        <*> D.column (D.nonNullable (D.refine statusFromText D.text))+        <*> (fromIntegral <$> D.column (D.nonNullable D.int8))+        <*> (fmap EventId <$> D.column (D.nullable D.uuid))++statusToText :: TimerStatus -> Text+statusToText = \case+    Scheduled -> "scheduled"+    Firing -> "firing"+    Fired -> "fired"+    Cancelled -> "cancelled"+    Dead -> "dead"++statusFromText :: Text -> Either Text TimerStatus+statusFromText = \case+    "scheduled" -> Right Scheduled+    "firing" -> Right Firing+    "fired" -> Right Fired+    "cancelled" -> Right Cancelled+    "dead" -> Right Dead+    other -> Left ("unknown keiro_timers.status: " <> other)++timerIdToUuid :: TimerId -> UUID+timerIdToUuid (TimerId uuid) = uuid++eventIdToUuid :: EventId -> UUID+eventIdToUuid (EventId uuid) = uuid
+ src/Keiro/Timer/Types.hs view
@@ -0,0 +1,35 @@+{- | Identity and request types for durable timers, separated from their SQL+storage ("Keiro.Timer.Schema") so process-manager code can construct timer+requests without depending on the persistence layer.+-}+module Keiro.Timer.Types (+    TimerId (..),+    TimerRequest (..),+)+where++import Data.UUID (UUID)+import Keiro.Prelude++{- | A timer's stable identifier. A caller-chosen id makes scheduling+idempotent (rescheduling the same id updates rather than duplicates).+-}+newtype TimerId = TimerId UUID+    deriving stock (Generic, Eq, Ord, Show)++{- | A request to schedule a timer.++* 'timerId' — stable id; rescheduling the same id is idempotent.+* 'processManagerName' \/ 'correlationId' — identify the saga instance the+  timer belongs to, so the firing can be routed back to it.+* 'fireAt' — the earliest time the timer becomes due.+* 'payload' — opaque JSON carried through to the @fire@ action.+-}+data TimerRequest = TimerRequest+    { timerId :: !TimerId+    , processManagerName :: !Text+    , correlationId :: !Text+    , fireAt :: !UTCTime+    , payload :: !Value+    }+    deriving stock (Generic, Eq, Show)
+ src/Keiro/Wake.hs view
@@ -0,0 +1,112 @@+{- | A wake signal for keiro's poll-loop workers (EP-50, LISTEN/NOTIFY push delivery).++keiro's background workers — the workflow resume worker, the durable-timer worker,+the outbox publisher — make progress by polling: run one "claim, process, commit"+pass, then sleep a fixed interval. That fixed sleep is also the worst-case latency+(the resume worker's default is a full second). This module lets a worker instead+/wait to be woken/: it blocks until either a relevant append notification arrives —+meaning "something was appended, go look" — or a bounded fallback timeout elapses.++== Where the wake comes from (no new connection)++The kiroku event store already fires a Postgres @NOTIFY@ on channel @\<schema\>.events@+(default @kiroku.events@) on every append, via a @notify_events()@ trigger on the+@streams@ table, and already runs __one dedicated long-lived listener connection per+store__ ('Kiroku.Store.Notification.Notifier', started once by+'Kiroku.Store.Connection.withStore'). That listener fans every notification out to an+in-process broadcast channel, @notifier.tickChan :: 'Control.Concurrent.STM.TChan' ()@.++A 'WakeSignal' built by 'wakeSignalFromStore' duplicates that broadcast channel+('Control.Concurrent.STM.dupTChan' — an STM operation, __not__ a database connection),+so N keiro workers over one store share the single existing listener connection and N+cheap STM cursors. Push therefore adds __zero__ new long-lived connections: the only+listener connection is kiroku's pre-existing @kiroku-listener@, amortized across all+subscribers. The query pool is sized exactly as before.++== Push is an optimization over a durable poll, never a replacement++A Postgres @NOTIFY@ is best-effort: if the listener is momentarily disconnected the+notification is dropped, and the payload is advisory. So correctness must never depend+on a notification arriving. 'waitForWake' always takes a fallback timeout: a missed+notification only delays the next pass to that fallback interval, exactly as the old+fixed-poll loop did. The channel and payload are kiroku's+(@\<schema\>.events@; @stream_name,stream_id,stream_version@); keiro treats the+notification as an opaque wake and re-queries durably, so it ignores the payload.+-}+module Keiro.Wake (+    WakeSignal (..),+    WakeReason (..),+    wakeSignalFromStore,+    neverWake,+)+where++import Control.Concurrent.STM (+    TChan,+    atomically,+    check,+    dupTChan,+    isEmptyTChan,+    orElse,+    readTChan,+    readTVar,+    registerDelay,+ )+import Kiroku.Store.Connection (KirokuStore (..))+import Kiroku.Store.Notification (Notifier (..))++{- | Why a 'waitForWake' returned: a notification arrived, or the fallback timeout+elapsed. Both mean "run another pass"; the distinction is available for telemetry.+-}+data WakeReason = WokenByNotify | WokenByTimeout+    deriving stock (Eq, Show)++{- | A source of "something was appended, go look" wake-ups, layered over a bounded+fallback timeout so a missed notification never stalls progress.+-}+newtype WakeSignal = WakeSignal+    { waitForWake :: Int -> IO WakeReason+    {- ^ Block until a notification arrives OR the given fallback timeout+    (microseconds) elapses, whichever is first. Returns which happened.+    -}+    }++{- | Build a 'WakeSignal' from a running kiroku store's notifier. Duplicates the+store's broadcast tick channel ('dupTChan') __once__ here, so this consumer has its+own cursor and never steals another consumer's ticks, and so ticks arriving between+waits queue in the duplicated channel rather than being lost. Opens __no__ new+database connection: it rides the single dedicated listener connection the store+already holds.+-}+wakeSignalFromStore :: KirokuStore -> IO WakeSignal+wakeSignalFromStore store = do+    myChan <- atomically (dupTChan (tickChan (notifier store)))+    pure (WakeSignal (waitOn myChan))+  where+    waitOn :: TChan () -> Int -> IO WakeReason+    waitOn myChan timeoutMicros = do+        timer <- registerDelay timeoutMicros+        atomically $+            ( do+                -- A tick is queued: collapse any backlog so one wait returns once per+                -- "there is new work" episode (the worker re-queries durably anyway).+                _ <- readTChan myChan+                drain myChan+                pure WokenByNotify+            )+                `orElse` (readTVar timer >>= check >> pure WokenByTimeout)++    drain ch = do+        empty <- isEmptyTChan ch+        if empty then pure () else readTChan ch >> drain ch++{- | A 'WakeSignal' that never fires a notification — every wait elapses the fallback+timeout. Used to simulate "all NOTIFYs dropped" (proving push is an optimization over+the durable poll) and to give a fixed-poll worker an unchanged cadence under the same+push-aware driver.+-}+neverWake :: WakeSignal+neverWake = WakeSignal $ \timeoutMicros -> do+    timer <- registerDelay timeoutMicros+    atomically (readTVar timer >>= check)+    pure WokenByTimeout
+ src/Keiro/Workflow.hs view
@@ -0,0 +1,948 @@+{-# LANGUAGE TypeFamilies #-}++{- | The durable workflow runtime: the @Workflow@ effect, named-step+journaling, replay, and suspension.++== What this gives you++Write a long-running process as an ordinary @effectful@ computation and run+it with 'runWorkflow'. Each @'step' name action@ either runs @action@ and+records ("journals") its result, or — on a replay after a crash — returns the+previously recorded result /without/ re-running the side effect. The journal+is a kiroku stream named @wf:\<name\>-\<id\>@ ('workflowStreamName'); there is+no separate history table. Because a workflow can pause (waiting for a timer,+an external signal, or a child), 'runWorkflow' returns a 'WorkflowOutcome'+('Completed' or 'Suspended').++Step side effects are at-least-once across process crashes. If the process+crashes after @action@ runs but before the journal append commits, a later+resume has no record of that step and runs @action@ again. Step bodies that call+external systems must therefore be idempotent, typically by deriving an+idempotency key from the workflow identity and step name and passing it to the+external system.++Replay is keyed by step name, not by source position or code identity. Renaming+a step intentionally orphans the old journal entry and runs the renamed step as+new work; changing the meaning of a step while keeping the same name is the+author's responsibility. Use 'patch' for cross-cutting workflow-body changes+that need an explicit old/new branch.++== Contract recap for downstream plans (the v2 MasterPlan)++* The authoring surface is the @Workflow@ effect with 'step', 'awaitStep',+  'currentWorkflow', and 'freshOrdinal'. Add new primitives (sleep,+  awakeable, child) as functions that go /through/ this effect so a single+  import stays the workflow surface.+* 'awaitStep' is the suspension primitive every wake source builds on: it+  returns a journaled result if present, otherwise runs an idempotent+  /arming/ action once and suspends the run. The arming action MUST be+  idempotent — a suspended-then-resumed workflow re-enters 'awaitStep' from+  the top on every resume until the result is journaled, so it re-runs @arm@+  each time (e.g. schedule a timer with a deterministic id so repeats+  collapse to a no-op).+* A wake source's external completion path (a timer firing,+  @signalAwakeable@, a child finishing) calls 'appendJournalEntry' (or+  'appendJournalEntryReturningId') with a 'StepRecorded' whose @stepName@ is+  the awaited step name; the next 'runWorkflow' then takes the 'awaitStep'+  hit path and proceeds.+* The journal codec ('workflowJournalCodec') and the reserved step-name+  prefixes ('sleepStepPrefix' = @"sleep:"@, 'awakeableStepPrefix' = @"awk:"@,+  'childStepPrefix' = @"child:"@) are integration contracts: suspensions are+  journaled as ordinary 'StepRecorded' events with these prefixes, never as+  new event types, so the replay loop stays uniform.+* Per-run options live in one record, 'WorkflowRunOptions' (EP-41 adds a+  snapshot policy, EP-44 adds metrics/tracer); 'runWorkflowWith' is the+  single canonical entry EP-42's resume worker re-invokes through.+* The derived @keiro_workflows@ instance row is maintained by journal append+  transactions. Terminal markers ('WorkflowCompleted', 'WorkflowCancelled',+  'WorkflowFailed') freeze the instance as completed/cancelled/failed, and the+  resume worker uses its attempt/lease fields for crash recovery.+* Discovery (EP-42) is 'findUnfinishedWorkflowIds' plus 'completedStepName';+  it needs no kiroku prefix subscription.++> __Build gotcha__ (EP-38's migration adds @keiro_workflow_steps@): adding a+> new @.sql@ file under @keiro-migrations/sql-migrations/@ does not trigger+> recompilation of @Keiro.Migrations@ (cabal says "Up to date" even with+> @-fforce-recomp@, because @embedDir@ is a Template Haskell directory read+> GHC's recompilation checker does not track per-file). After adding a+> migration, edit a comment in @keiro-migrations/src/Keiro/Migrations.hs@ or+> run @cabal clean@ before building.+-}+module Keiro.Workflow (+    -- * The effect and authoring surface+    Workflow,+    step,+    awaitStep,+    currentWorkflow,+    currentRunGeneration,+    freshOrdinal,+    continueAsNew,+    restoreSeed,+    patch,++    -- * Running a workflow+    runWorkflow,+    runWorkflowWith,+    WorkflowRunOptions (..),+    defaultWorkflowRunOptions,++    -- * Journal append helpers (used by wake-source plans)+    JournalAppendOutcome (..),+    prepareJournalAppend,+    appendJournalEntry,+    appendJournalEntryReturningId,++    -- * Errors thrown by the runtime+    WorkflowError (..),++    -- * Re-exported core contracts+    module Keiro.Workflow.Types,+    WorkflowStepRow (..),+    recordStepTx,+    loadStepIndex,+    stepExists,+    currentGeneration,+    findUnfinishedWorkflowIds,+    setWorkflowWakeAfterTx,+)+where++import Control.Exception (Exception)+import Data.Aeson qualified as Aeson+import Data.IORef (+    IORef,+    atomicModifyIORef',+    newIORef,+    readIORef,+ )+import Data.Int (Int32)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.UUID.V5 qualified as UUID.V5+import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, (:>))+import Effectful.Dispatch.Dynamic (EffectHandler, interpret, localSeqUnlift, send)+import Effectful.Error.Static (Error, tryError)+import Effectful.Exception (bracket_, catch, throwIO)+import Keiro.Codec (decodeRecorded, encodeForAppendWithMetadata)+import Keiro.EventStream (SnapshotPolicy (..), Terminality (..))+import Keiro.Prelude+import Keiro.Snapshot (SnapshotMissReason (..))+import Keiro.Snapshot.Policy (shouldSnapshot)+import Keiro.Telemetry (+    KeiroMetrics,+    Tracer,+    recordSnapshotDecodeFailures,+    recordSnapshotReadHits,+    recordSnapshotReadMisses,+    recordSnapshotWriteFailures,+    recordWorkflowActive,+    recordWorkflowJournalLength,+    recordWorkflowStepExecuted,+    recordWorkflowStepReplayed,+    withWorkflowSpan,+ )+import Keiro.Workflow.Instance (+    WorkflowStatus (..),+    markInstanceSuspended,+    upsertInstanceTx,+ )+import Keiro.Workflow.Schema (WorkflowStepRow (..), currentGeneration, findUnfinishedWorkflowIds, loadStepIndex, lockWorkflowStepTx, lookupStepResultTx, recordStepTx, setWorkflowWakeAfterTx, stepExists)+import Keiro.Workflow.Snapshot (lookupWorkflowSnapshot, writeWorkflowSnapshot)+import Keiro.Workflow.Types+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Error (StoreError)+import Kiroku.Store.Read (readStreamForwardStream)+import Kiroku.Store.Transaction (AppendConflict, appendToStreamTx, prepareEventsIO, runTransaction)+import Kiroku.Store.Types (AppendResult (..), EventData, EventId (..), ExpectedVersion (..), StreamId, StreamVersion (..))+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Streamly+import System.IO.Unsafe (unsafePerformIO)+import "hasql-transaction" Hasql.Transaction qualified as Tx++-- ---------------------------------------------------------------------------+-- The effect+-- ---------------------------------------------------------------------------++{- | The durable workflow effect. Its operations are interpreted by+'runWorkflow' / 'runWorkflowWith', which journal and replay them.+-}+data Workflow :: Effect where+    {- | Run a side-effecting action under a name, journaling its result; on+    replay, return the recorded result without re-running the action.+    -}+    Step :: (Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> m a -> Workflow m a+    {- | Return the awaited step's journaled result, or run the (idempotent)+    arming action once and suspend the run.+    -}+    Await :: (Aeson.FromJSON a) => StepName -> m () -> Workflow m a+    -- | The running workflow's identity (for keying wake sources).+    CurrentWorkflow :: Workflow m (WorkflowName, WorkflowId)+    -- | The journal generation this run is operating on.+    CurrentRunGeneration :: Workflow m Int+    -- | A per-run, per-namespace counter for deterministic ordinal step names.+    FreshOrdinal :: Text -> Workflow m Int+    {- | EP-48: snapshot the carried seed, rotate onto a fresh journal generation,+    and unwind this run; the next run/resume continues from the seed. Never+    returns to the caller within this run (result type is fully polymorphic).+    -}+    ContinueAsNew :: (Aeson.ToJSON s) => s -> Workflow m a+    {- | EP-49: decide and journal a cross-cutting branch — returns the stable+    'Bool' branch decision for the given patch. Fresh instances get 'True'+    (new branch); instances already in flight when the patch shipped get+    'False' (old branch). The decision is journaled on first encounter and+    replayed verbatim thereafter.+    -}+    Patch :: PatchId -> Workflow m Bool++type instance DispatchOf Workflow = Dynamic++{- | Run @action@ under @name@, journaling its encoded result. On a replay where+@name@ is already journaled, the recorded result is returned and @action@ is+not run. If the process crashed after @action@ ran but before the journal+commit, the action runs again on resume: workflow step side effects are+at-least-once at the step boundary.++The returned value is always the JSON round-trip of the recorded result,+including on the first run. A lossy or rejecting @ToJSON@\/@FromJSON@ pair is+therefore observed immediately rather than only after a crash and replay.++Requires @'Aeson.ToJSON' a@ (to journal the result) and @'Aeson.FromJSON' a@+(to decode it on replay).+-}+step :: (Workflow :> es, Aeson.ToJSON a, Aeson.FromJSON a) => StepName -> Eff es a -> Eff es a+step name action = send (Step name action)++{- | Look up @name@ in the journal. If a wake source has already recorded its+completion (a 'StepRecorded' whose @stepName@ is @name@, carrying the+resolved result), decode and return it. Otherwise run @arm@ exactly once+(the wake source's idempotent job — schedule a timer, register an awakeable,+spawn a child) and __suspend__ this run, so 'runWorkflow' returns 'Suspended'.++@arm@ must be idempotent: every resume re-runs it until the result is+journaled.+-}+awaitStep :: (Workflow :> es, Aeson.FromJSON a) => StepName -> Eff es () -> Eff es a+awaitStep name arm = send (Await name arm)++-- | The identity of the workflow currently running.+currentWorkflow :: (Workflow :> es) => Eff es (WorkflowName, WorkflowId)+currentWorkflow = send CurrentWorkflow++{- | The journal generation this run is operating on. Wake sources include it+in their durable identities so a generation opened by 'continueAsNew' never+collides with prior-generation rows.+-}+currentRunGeneration :: (Workflow :> es) => Eff es Int+currentRunGeneration = send CurrentRunGeneration++{- | A per-run, per-namespace counter (starting at 0). Used by convenience+forms of wake sources (e.g. @sleep@ → @"sleep:0"@) to derive a deterministic,+replay-stable ordinal name. Note: ordinal names are only stable if the order+of @awaitStep@-style calls does not change across deploys; the named forms+are the stable primitives.+-}+freshOrdinal :: (Workflow :> es) => Text -> Eff es Int+freshOrdinal namespace = send (FreshOrdinal namespace)++{- | Continue this workflow /as new/ (EP-48): snapshot the carried @seed@ onto a+fresh journal generation, journal a terminal rotation marker on the current+generation, and unwind this run. The next run or resume of the same logical+@('WorkflowName', 'WorkflowId')@ starts against the fresh generation, hydrated+from the seed, with an empty (bounded) journal.++This is how a workflow that runs an /unbounded/ number of steps — a poller, a+per-day rolling process — keeps its per-generation journal bounded so replay+and hydration stay fast forever. The result type is fully polymorphic (@a@)+because control never returns to the caller within /this/ run: the rotated+continuation runs in the next run/resume. Read the carried seed back at the top+of the workflow body with 'restoreSeed'.+-}+continueAsNew :: (Workflow :> es, Aeson.ToJSON s) => s -> Eff es a+continueAsNew seed = send (ContinueAsNew seed)++{- | Restore the seed carried by the previous generation's 'continueAsNew', or+return @def@ on the first generation (EP-48). Implemented as an ordinary+journaled @step@ under the reserved 'continueSeedStepName': on a generation that+was rotated into, the seed step was journaled (and snapshotted) by the rotation,+so this @step@ hits it and returns the carried value without re-running; on the+very first generation it misses and records @def@. Call it once at the top of a+workflow body that uses 'continueAsNew'.+-}+restoreSeed :: (Workflow :> es, Aeson.ToJSON s, Aeson.FromJSON s) => s -> Eff es s+restoreSeed def = step (StepName continueSeedStepName) (pure def)++{- | Decide a cross-cutting branch for an in-flight-vs-fresh code change, and+journal the decision so every later replay observes the same branch (EP-49).++@patch (PatchId "fraud-check-v2")@ returns 'True' only when that id was present+in 'activePatches' when this workflow generation first started. The generation+records its active set under 'patchSetStepName' exactly once; on the first+encounter each individual patch decision is journaled under @patch:\<patchId\>@,+and every replay returns the recorded 'Bool'. Add a patch id to 'activePatches'+in the deploy that introduces the corresponding 'patch' call; remove it only+after deleting that call from the workflow body.++This is an /escape hatch/ for changes that cross-cut multiple steps. For the+common case — one step changed — do __not__ use 'patch': rename the step's+'StepName' instead. A renamed step has no journaled history under its new name,+so its action runs fresh on the next replay, which is exactly the right+behaviour for a single-step change. Reach for 'patch' only when an in-flight+instance would be left incoherent by the new code (e.g. the change adds, removes,+or reorders steps, or changes the meaning of an already-journaled step result).+-}+patch :: (Workflow :> es) => PatchId -> Eff es Bool+patch pid = send (Patch pid)++-- ---------------------------------------------------------------------------+-- Per-run options+-- ---------------------------------------------------------------------------++{- | Options for a single workflow run. This is the canonical home for+per-run options across the v2 initiative — EP-41 adds the snapshot policy,+EP-44 adds metrics/tracer fields, all additive. Extend it additively; never+break the field set EP-38/EP-41 established.+-}+data WorkflowRunOptions = WorkflowRunOptions+    { snapshotPolicy :: !(SnapshotPolicy WorkflowState)+    {- ^ When to persist a snapshot of the accumulated step-result map after a+    step append (and at completion, for 'OnTerminal'). Default 'Never'+    (EP-38 behaviour: every run/resume does a full version-0 replay).+    -}+    , pageSize :: !Int32+    -- ^ Page size for the journal pre-load read.+    , metrics :: !(Maybe KeiroMetrics)+    {- ^ EP-44: when 'Just', the runtime records the @keiro.workflow.*@ instruments+    (steps executed/replayed, active count, journal length). 'Nothing' is the+    no-op default, so a run with 'defaultWorkflowRunOptions' records nothing.+    -}+    , tracer :: !(Maybe Tracer)+    {- ^ EP-44: when 'Just', the runtime opens a @workflow \<name\>@ 'Internal' span+    around the run. 'Nothing' runs the body unwrapped.+    -}+    , activePatches :: !(Set PatchId)+    {- ^ Patch ids currently active in this deployed workflow code. A fresh+    workflow generation records this set once under 'patchSetStepName', and+    each 'patch' call returns 'True' iff its id was in that recorded set.+    -}+    }+    deriving stock (Generic)++{- | Sensible defaults: no snapshotting, a journal pre-load page size of 100,+and no telemetry (metrics/tracer 'Nothing'). A default-options run replays+and behaves exactly as EP-38 did.+-}+defaultWorkflowRunOptions :: WorkflowRunOptions+defaultWorkflowRunOptions =+    WorkflowRunOptions+        { snapshotPolicy = Never+        , pageSize = 100+        , metrics = Nothing+        , tracer = Nothing+        , activePatches = Set.empty+        }++-- ---------------------------------------------------------------------------+-- Errors and the suspension sentinel+-- ---------------------------------------------------------------------------++{- | Errors the workflow runtime raises (via 'throwIO', so they surface+through the surrounding store/IO error channel).+-}+data WorkflowError+    = {- | A journaled step result could not be decoded into the type the+      replaying @step@/@awaitStep@ expects (step name, decode message). The+      result type changed incompatibly — a programmer error.+      -}+      WorkflowStepDecodeError !Text !Text+    | -- | A journal event could not be decoded during pre-load.+      WorkflowJournalDecodeError !Text+    | -- | A journal event could not be encoded for append.+      WorkflowJournalEncodeError !Text+    | -- | Appending a journal entry failed for a non-conflict reason.+      WorkflowJournalAppendError !Text+    deriving stock (Eq, Show)++instance Exception WorkflowError++-- | Internal sentinel thrown to unwind a suspended run up to 'runWorkflowWith'.+data WorkflowSuspend = WorkflowSuspend+    deriving stock (Show)++instance Exception WorkflowSuspend++-- | Internal sentinel thrown when a cancellation marker appears mid-run.+data WorkflowCancelPending = WorkflowCancelPending+    deriving stock (Show)++instance Exception WorkflowCancelPending++{- | Internal sentinel thrown by the 'ContinueAsNew' handler to unwind a+rotating run up to 'runWorkflowWith' (EP-48), carrying the JSON-encoded seed for+the next generation. Mirrors 'WorkflowSuspend': a non-returning unwind the run+entry point catches and turns into an outcome ('ContinuedAsNew').+-}+newtype WorkflowRotate = WorkflowRotate Aeson.Value+    deriving stock (Show)++instance Exception WorkflowRotate++-- ---------------------------------------------------------------------------+-- Running+-- ---------------------------------------------------------------------------++{- | Process-wide count of workflow runs currently in flight, backing the+@keiro.workflow.active@ gauge (EP-44). 'runWorkflowWith' brackets each run with+@+1@/@-1@ and samples the gauge on both edges, so the exported last-value+reflects the true live count whether a run is mid-flight or finished. A+process-global 'IORef' is the lightest faithful implementation (the gauge is a+last-value-wins level, not a per-run delta), mirroring how the other keiro+backlog/level gauges are recorded with a value the runtime already holds.+-}+{-# NOINLINE activeCountRef #-}+activeCountRef :: IORef Int64+activeCountRef = unsafePerformIO (newIORef 0)++{- | Run a workflow computation, journaling each 'step' and replaying any+already-journaled steps. Returns 'Completed' when the computation finishes+(a 'WorkflowCompleted' marker is journaled) or 'Suspended' when it pauses at+an unresolved 'awaitStep'.++Equivalent to @'runWorkflowWith' 'defaultWorkflowRunOptions'@.+-}+runWorkflow ::+    (IOE :> es, Store :> es, Error StoreError :> es) =>+    WorkflowName ->+    WorkflowId ->+    Eff (Workflow : es) a ->+    Eff es (WorkflowOutcome a)+runWorkflow = runWorkflowWith defaultWorkflowRunOptions++{- | 'runWorkflow' with explicit 'WorkflowRunOptions'. This is the single+canonical run entry point; EP-42's resume worker re-invokes through it so+resumed runs honor the same options.++If the workflow's journal already carries a 'WorkflowCancelled' marker (a child+cancelled by its parent, EP-43), the run short-circuits immediately and returns+'Cancelled' without executing any step. The handler also re-checks that marker+on step/await/patch miss paths and after a fresh step action returns, so a+mid-run cancellation stops at the next workflow boundary. A cancellation that+lands after the check but before/during the user action may still let that one+action run; durable workflow steps remain at-least-once at boundaries. If the+journal carries a 'WorkflowFailed' marker, the run likewise short-circuits to+'Failed'. To /propagate/ a finished child's result to its parent, drive the+child through 'Keiro.Workflow.Child.runChildWorkflow' rather than this function+directly.+-}+runWorkflowWith ::+    forall a es.+    (IOE :> es, Store :> es, Error StoreError :> es) =>+    WorkflowRunOptions ->+    WorkflowName ->+    WorkflowId ->+    Eff (Workflow : es) a ->+    Eff es (WorkflowOutcome a)+runWorkflowWith options name wid action = do+    -- EP-48: resolve the CURRENT (highest) generation once per run and operate+    -- only on it. A never-rotating workflow stays at generation 0, so naming,+    -- load, and append are byte-for-byte as before. A rotated workflow resolves+    -- to its newest generation, so discovery/resume transparently continue there.+    gen <- currentGeneration name wid+    -- Cancellation short-circuit (EP-43): a workflow whose journal carries a+    -- WorkflowCancelled marker makes no further progress. The index row for that+    -- marker is keyed under 'cancelledStepName' on the current generation, so a+    -- single existence check is enough and we never run the user action.+    cancelled <- stepExists name wid gen cancelledStepName+    failed <- stepExists name wid gen failedStepName+    case (cancelled, failed) of+        (True, _) -> pure Cancelled+        (_, True) -> pure Failed+        _ -> runActive gen+  where+    -- EP-44 telemetry handles, pulled from the run options once. Both default+    -- to 'Nothing' (see 'defaultWorkflowRunOptions'), so a default-options run+    -- records nothing and opens no span — the no-op idiom holds end to end.+    mMetrics = options ^. #metrics+    mTracer = options ^. #tracer+    runActive :: Int -> Eff es (WorkflowOutcome a)+    runActive gen =+        -- EP-44: maintain the process-wide live-run count and sample the+        -- @keiro.workflow.active@ gauge on both entry and exit, and open the+        -- whole-run @workflow \<name\>@ span (step 'Nothing'). The body is+        -- unchanged from EP-41 except for the journal-length recording below.+        bracket_+            (liftIO (atomicModifyIORef' activeCountRef (\n -> (n + 1, ()))) >> sampleActive)+            (liftIO (atomicModifyIORef' activeCountRef (\n -> (n - 1, ()))) >> sampleActive)+            (withWorkflowSpan mTracer name wid Nothing (\_sp -> interpreted))+      where+        sampleActive = liftIO (readIORef activeCountRef) >>= recordWorkflowActive mMetrics+        interpreted = do+            initial <- loadJournal options name wid gen+            initial' <- recordPatchSetIfFresh gen initial+            journalRef <- liftIO (newIORef initial')+            ordinalRef <- liftIO (newIORef Map.empty)+            let runHandler = interpret (handler gen journalRef ordinalRef) action+            outcome <-+                (Completed <$> runHandler)+                    `catch` (\WorkflowSuspend -> pure Suspended)+                    `catch` (\WorkflowCancelPending -> pure Cancelled)+                    `catch` (\(WorkflowRotate seedJson) -> rotateGeneration mMetrics name wid gen seedJson)+            case outcome of+                Completed result -> do+                    now <- liftIO getCurrentTime+                    finalMap <- liftIO (readIORef journalRef)+                    -- Idempotent: only appends (and so only snapshots) when the completion+                    -- marker is not already journaled. On a replay of an already-completed+                    -- workflow this is 'Nothing' and no terminal snapshot is taken (one was+                    -- already taken on the original completing run, if the policy fired).+                    mAppend <- appendCompletion name wid gen now+                    for_ mAppend $ \appendResult ->+                        when+                            ( shouldSnapshot+                                (options ^. #snapshotPolicy)+                                Terminal+                                finalMap+                                (appendResult ^. #streamVersion)+                            )+                            (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) finalMap)+                    -- EP-44: record one @keiro.workflow.journal.length@ observation per+                    -- completing run (the 'Completed' path only, never 'Suspended'),+                    -- including a replay that completes again. Length is the recorded+                    -- step map plus the WorkflowCompleted marker.+                    recordWorkflowJournalLength mMetrics (fromIntegral (Map.size finalMap + 1))+                    pure (Completed result)+                Suspended -> markInstanceSuspended name wid >> pure Suspended+                Cancelled -> pure Cancelled+                Failed -> pure Failed+                -- EP-48: the run unwound via 'WorkflowRotate'; 'rotateGeneration'+                -- already journaled the seed step on the next generation and the+                -- rotation marker on this one, so there is nothing more to do here.+                ContinuedAsNew -> pure ContinuedAsNew+        recordPatchSetIfFresh runGen initial = do+            let patches = options ^. #activePatches+                freshStart = Map.keysSet initial `Set.isSubsetOf` Set.singleton continueSeedStepName+            if freshStart && not (Set.null patches)+                then do+                    let encoded = Aeson.toJSON (map unPatchId (Set.toList patches))+                    now <- liftIO getCurrentTime+                    appendJournal name wid runGen (StepRecorded patchSetStepName encoded now) >>= \case+                        JournalAppended{} -> pure (Map.insert patchSetStepName encoded initial)+                        JournalAlreadyPresent stored -> pure (Map.insert patchSetStepName stored initial)+                        JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))+                else pure initial+    handler ::+        Int ->+        IORef (Map Text Aeson.Value) ->+        IORef (Map Text Int) ->+        EffectHandler Workflow es+    handler gen journalRef ordinalRef env operation = case operation of+        Step (StepName key) act -> do+            journal <- liftIO (readIORef journalRef)+            case Map.lookup key journal of+                Just stored -> do+                    -- Hit: the step is already journaled, so its recorded result is+                    -- returned without re-running @act@ — a replay.+                    recordWorkflowStepReplayed mMetrics 1+                    decodeStored key stored+                Nothing -> do+                    checkCancellationPending name wid gen+                    a <- localSeqUnlift env (\unlift -> unlift act)+                    checkCancellationPending name wid gen+                    let encoded = Aeson.toJSON a+                    now <- liftIO getCurrentTime+                    appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now)+                    case appendOutcome of+                        JournalAppended appendResult -> do+                            -- Miss: @act@ ran and was journaled — a fresh execution.+                            recordWorkflowStepExecuted mMetrics 1+                            newMap <-+                                liftIO+                                    ( atomicModifyIORef' journalRef $ \m ->+                                        let m' = Map.insert key encoded m in (m', m')+                                    )+                            -- Evaluate the snapshot policy on the post-append map and version;+                            -- a step is never the terminal marker, hence @False@.+                            when+                                ( shouldSnapshot+                                    (options ^. #snapshotPolicy)+                                    NotTerminal+                                    newMap+                                    (appendResult ^. #streamVersion)+                                )+                                (writeWorkflowSnapshotAdvisory mMetrics (appendResult ^. #streamId) (appendResult ^. #streamVersion) newMap)+                            decodeStored key encoded+                        JournalAlreadyPresent stored -> do+                            liftIO+                                ( atomicModifyIORef' journalRef $ \m ->+                                    (Map.insert key stored m, ())+                                )+                            decodeStored key stored+                        JournalAppendConflict err ->+                            throwIO (WorkflowJournalAppendError (Text.pack (show err)))+        Await (StepName key) arm -> do+            journal <- liftIO (readIORef journalRef)+            case Map.lookup key journal of+                Just stored -> do+                    -- An awaitStep hit means the wake source already resolved this step;+                    -- the recorded result is returned without arming — a replay. An+                    -- awaitStep miss arms and suspends: no user @action@ ran, so it is+                    -- not a step execution and records nothing here.+                    recordWorkflowStepReplayed mMetrics 1+                    decodeStored key stored+                Nothing -> do+                    checkCancellationPending name wid gen+                    localSeqUnlift env (\unlift -> unlift arm)+                    throwIO WorkflowSuspend+        CurrentWorkflow -> pure (name, wid)+        CurrentRunGeneration -> pure gen+        FreshOrdinal namespace ->+            liftIO . atomicModifyIORef' ordinalRef $ \counters ->+                let n = Map.findWithDefault 0 namespace counters+                 in (Map.insert namespace (n + 1) counters, n)+        -- EP-48: encode the carried seed and throw the rotation sentinel, which+        -- 'runWorkflowWith' catches and turns into 'rotateGeneration'. Never+        -- returns to the caller within this run (result type is polymorphic).+        ContinueAsNew seed -> throwIO (WorkflowRotate (Aeson.toJSON seed))+        -- EP-49: decide and journal a cross-cutting branch. Mirrors the 'Step'+        -- hit/miss shape, but the miss path computes the decision from the+        -- patch set recorded when this workflow generation first started.+        Patch pid -> do+            let key = patchStepName pid+            journal <- liftIO (readIORef journalRef)+            case Map.lookup key journal of+                Just stored ->+                    -- Hit: the decision was made on an earlier run; replay it verbatim.+                    decodeStored key stored+                Nothing -> do+                    checkCancellationPending name wid gen+                    recordedSet <- case Map.lookup patchSetStepName journal of+                        Nothing -> pure []+                        Just stored -> decodeStored patchSetStepName stored+                    let decision = unPatchId pid `elem` (recordedSet :: [Text])+                        encoded = Aeson.toJSON decision+                    now <- liftIO getCurrentTime+                    appendOutcome <- appendJournal name wid gen (StepRecorded key encoded now)+                    case appendOutcome of+                        JournalAppended{} -> do+                            liftIO+                                ( atomicModifyIORef' journalRef $ \m ->+                                    (Map.insert key encoded m, ())+                                )+                            pure decision+                        JournalAlreadyPresent stored -> do+                            liftIO+                                ( atomicModifyIORef' journalRef $ \m ->+                                    (Map.insert key stored m, ())+                                )+                            decodeStored key stored+                        JournalAppendConflict err ->+                            throwIO (WorkflowJournalAppendError (Text.pack (show err)))++-- | Decode a stored journal result into the type the caller expects.+decodeStored :: (Aeson.FromJSON a) => Text -> Aeson.Value -> Eff es a+decodeStored key stored = case Aeson.fromJSON stored of+    Aeson.Success a -> pure a+    Aeson.Error message -> throwIO (WorkflowStepDecodeError key (Text.pack message))++checkCancellationPending :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Eff es ()+checkCancellationPending name wid gen = do+    cancelled <- stepExists name wid gen cancelledStepName+    when cancelled (throwIO WorkflowCancelPending)++{- | Pre-load a workflow's journal stream into a @step name -> result@ map.++If a compatible snapshot exists ('loadWorkflowSnapshot'), seed the map from it+and read only the journal events /after/ the snapshot's version ("tail+replay"); the resulting map is byte-for-byte the one a full version-0 replay+would produce, because every 'StepRecorded' at or before the snapshot version+is already captured in the seed. A missing, mismatched, or undecodable+snapshot is recorded as a miss (and, for undecodable bytes, a decode failure)+before the read falls back to a full replay from version 0.+'WorkflowCompleted' contributes nothing to the map.+-}+loadJournal ::+    (IOE :> es, Store :> es) =>+    WorkflowRunOptions ->+    WorkflowName ->+    WorkflowId ->+    Int ->+    Eff es (Map Text Aeson.Value)+loadJournal options name wid gen = do+    let journalName = workflowGenerationStreamName name wid gen+    snapshot <- lookupWorkflowSnapshot journalName+    (seedMap, fromVersion) <- case snapshot of+        Right (m, v) -> do+            recordSnapshotReadHits (options ^. #metrics) 1+            pure (m, v)+        Left reason -> do+            recordSnapshotReadMisses (options ^. #metrics) 1+            case reason of+                SnapshotDecodeFailed _ -> recordSnapshotDecodeFailures (options ^. #metrics) 1+                _ -> pure ()+            pure (Map.empty, StreamVersion 0)+    let+        events = readStreamForwardStream journalName fromVersion (options ^. #pageSize)+    Streamly.fold (Fold.foldlM' accumulate (pure seedMap)) events+  where+    accumulate journal recorded =+        case decodeRecorded workflowJournalCodec recorded of+            Right (StepRecorded key value _) -> pure (Map.insert key value journal)+            Right (WorkflowCompleted _) -> pure journal+            Right (WorkflowCancelled _) -> pure journal+            Right (WorkflowFailed _ _) -> pure journal+            Right (WorkflowContinuedAsNew _ _) -> pure journal -- a rotation marker carries no step result+            Left err -> throwIO (WorkflowJournalDecodeError (Text.pack (show err)))++-- ---------------------------------------------------------------------------+-- Journal append helpers+-- ---------------------------------------------------------------------------++data JournalAppendOutcome+    = JournalAppended !AppendResult+    | JournalAlreadyPresent !Aeson.Value+    | JournalAppendConflict !AppendConflict+    deriving stock (Eq, Show)++prepareJournalAppend ::+    (IOE :> es) =>+    WorkflowName ->+    WorkflowId ->+    Int ->+    WorkflowJournalEvent ->+    Eff es (Tx.Transaction JournalAppendOutcome)+prepareJournalAppend name wid gen event = do+    let key = journalKey event+        entryId = deterministicJournalId name wid gen key+        row = journalRow name wid gen event+        (status, mLastError) = instanceStatusForEvent event+        journalName = workflowGenerationStreamName name wid gen+        lockKey =+            Text.intercalate+                "/"+                [unWorkflowId wid, unWorkflowName name, Text.pack (show gen), key]+    base <- case encodeForAppendWithMetadata workflowJournalCodec Nothing event of+        Right encoded -> pure encoded+        Left err -> throwIO (WorkflowJournalEncodeError (Text.pack (show err)))+    let entry = base & #eventId .~ Just entryId :: EventData+    prepared <- prepareEventsIO [entry]+    now <- liftIO getCurrentTime+    pure $ do+        lockWorkflowStepTx lockKey+        lookupStepResultTx (unWorkflowId wid) (unWorkflowName name) gen key >>= \case+            Just stored -> pure (JournalAlreadyPresent stored)+            Nothing ->+                appendToStreamTx journalName AnyVersion prepared now >>= \case+                    Left err -> pure (JournalAppendConflict err)+                    Right appendResult ->+                        JournalAppended appendResult+                            <$ recordStepTx row+                            <* upsertInstanceTx+                                (unWorkflowId wid)+                                (unWorkflowName name)+                                (fromIntegral gen)+                                status+                                mLastError++appendJournal :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> Eff es JournalAppendOutcome+appendJournal name wid gen event =+    prepareJournalAppend name wid gen event >>= runTransaction++{- | Append a journal event to a workflow's journal stream (and keep its+index row consistent), idempotently. If the entry already exists this is a+no-op returning the would-be event id.++This is the integration helper a wake source's external-completion path uses+to record an awaited step's resolution. The append uses a deterministic event+id derived from @("keiro" : "workflow" : name : id : stepName)@ so concurrent+or retried writes collapse to one row.+-}+appendJournalEntry :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es ()+appendJournalEntry name wid event = void (appendJournalEntryReturningId name wid event)++{- | Like 'appendJournalEntry' but returns the (deterministic) 'EventId' of+the entry. EP-39's fired timer needs this for @markTimerFired@.+-}+appendJournalEntryReturningId :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> WorkflowJournalEvent -> Eff es EventId+appendJournalEntryReturningId name wid event = do+    -- EP-48: a wake source (timer fired, signalAwakeable, child completion)+    -- resolves the awaited step on whichever generation the suspended run is+    -- parked on — always the current (highest) one, since runs only ever operate+    -- on the current generation. Resolve it here so the append and its+    -- deterministic id are namespaced by that generation.+    gen <- currentGeneration name wid+    let key = journalKey event+        entryId = deterministicJournalId name wid gen key+    appendJournal name wid gen event >>= \case+        JournalAppended{} -> pure entryId+        JournalAlreadyPresent{} -> pure entryId+        JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))++{- | Append a journal entry only if it is not already journaled, returning the+'AppendResult' of the fresh append (or 'Nothing' if it already existed). Used+on the completion path so a terminal ('OnTerminal') snapshot can be taken from+the completing run's 'AppendResult', while a replay of an already-completed+workflow is a no-op.+-}+appendCompletion :: (IOE :> es, Store :> es) => WorkflowName -> WorkflowId -> Int -> UTCTime -> Eff es (Maybe AppendResult)+appendCompletion name wid gen now = do+    appendJournal name wid gen (WorkflowCompleted now) >>= \case+        JournalAppended appendResult -> pure (Just appendResult)+        JournalAlreadyPresent{} -> pure Nothing+        JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))++{- | Perform a continue-as-new rotation (EP-48): close generation @gen@ and open+generation @gen + 1@, seeded with @seedJson@. Returns 'ContinuedAsNew'.++The two appends are ordered for crash-safety. We append the next generation's+seed step __first__ (a single @StepRecorded continueSeedStepName seedJson@),+which advances @MAX(generation)@ — and therefore 'currentGeneration' — to+@gen + 1@. After that commits, any re-run resolves the current generation to+@gen + 1@, hydrates from the seed, and never re-enters generation @gen@; so even+a crash between the two appends converges to "continue from the seed", never+re-running generation @gen@'s work. We then append the terminal+'WorkflowContinuedAsNew' marker on generation @gen@. Both appends are guarded by+an existence check and use deterministic, generation-namespaced ids, so the+whole rotation is idempotent.++The seed step alone carries the state forward (the next run's 'loadJournal'+reads it and 'restoreSeed' hits it); we additionally snapshot the one-entry seed+map at the seed step's version so the next generation hydrates in O(1) rather+than re-reading even that one event. The snapshot is advisory (a miss only costs+a single event read), so it is written unconditionally on rotation regardless of+the run's 'snapshotPolicy' — rotation is exactly when a fresh snapshot earns its+keep.+-}+rotateGeneration ::+    forall a es.+    (IOE :> es, Store :> es, Error StoreError :> es) =>+    Maybe KeiroMetrics ->+    WorkflowName ->+    WorkflowId ->+    Int ->+    Aeson.Value ->+    Eff es (WorkflowOutcome a)+rotateGeneration mMetrics name wid gen seedJson = do+    let nextGen = gen + 1+    now <- liftIO getCurrentTime+    -- 1. Seed step on the NEXT generation first (advances the current generation).+    appendJournal name wid nextGen (StepRecorded continueSeedStepName seedJson now) >>= \case+        JournalAppended appendResult ->+            writeWorkflowSnapshotAdvisory+                mMetrics+                (appendResult ^. #streamId)+                (appendResult ^. #streamVersion)+                (Map.singleton continueSeedStepName seedJson)+        JournalAlreadyPresent{} -> pure ()+        JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))+    -- 2. Terminal rotation marker on the CURRENT generation (audit + closes it).+    appendJournal name wid gen (WorkflowContinuedAsNew nextGen now) >>= \case+        JournalAppended{} -> pure ()+        JournalAlreadyPresent{} -> pure ()+        JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))+    pure ContinuedAsNew++{- | Snapshot a workflow state after its journal append has committed. The+snapshot is advisory: a store failure is counted and cannot turn the+already-durable workflow transition into a failed run.+-}+writeWorkflowSnapshotAdvisory ::+    (IOE :> es, Store :> es, Error StoreError :> es) =>+    Maybe KeiroMetrics ->+    StreamId ->+    StreamVersion ->+    WorkflowState ->+    Eff es ()+writeWorkflowSnapshotAdvisory mMetrics streamId version state = do+    -- WorkflowState is already a Map Text Value assembled from journaled step+    -- results, so this path has no aggregate RegFile/uninit encode to guard.+    outcome <- tryError @StoreError (writeWorkflowSnapshot streamId version state)+    case outcome of+        Right () -> pure ()+        Left _ -> recordSnapshotWriteFailures mMetrics 1++instanceStatusForEvent :: WorkflowJournalEvent -> (WorkflowStatus, Maybe Text)+instanceStatusForEvent = \case+    StepRecorded{} -> (WfRunning, Nothing)+    WorkflowCompleted{} -> (WfCompleted, Nothing)+    WorkflowCancelled{} -> (WfCancelled, Nothing)+    WorkflowFailed reason _ -> (WfFailed, Just reason)+    WorkflowContinuedAsNew{} -> (WfRunning, Nothing)++-- | The reserved step-name key a journal event indexes under.+journalKey :: WorkflowJournalEvent -> Text+journalKey = \case+    StepRecorded{stepName = key} -> key+    WorkflowCompleted{} -> completedStepName+    WorkflowCancelled{} -> cancelledStepName+    WorkflowFailed{} -> failedStepName+    WorkflowContinuedAsNew{} -> continuedAsNewStepName++-- | The index row corresponding to a journal event, on the given generation.+journalRow :: WorkflowName -> WorkflowId -> Int -> WorkflowJournalEvent -> WorkflowStepRow+journalRow name wid gen = \case+    StepRecorded key value t ->+        WorkflowStepRow+            { workflowId = unWorkflowId wid+            , workflowName = unWorkflowName name+            , generation = gen+            , stepName = key+            , result = value+            , recordedAt = t+            }+    WorkflowCompleted t ->+        WorkflowStepRow+            { workflowId = unWorkflowId wid+            , workflowName = unWorkflowName name+            , generation = gen+            , stepName = completedStepName+            , result = Aeson.Null+            , recordedAt = t+            }+    WorkflowCancelled t ->+        WorkflowStepRow+            { workflowId = unWorkflowId wid+            , workflowName = unWorkflowName name+            , generation = gen+            , stepName = cancelledStepName+            , result = Aeson.Null+            , recordedAt = t+            }+    WorkflowFailed r t ->+        WorkflowStepRow+            { workflowId = unWorkflowId wid+            , workflowName = unWorkflowName name+            , generation = gen+            , stepName = failedStepName+            , result = Aeson.toJSON r+            , recordedAt = t+            }+    WorkflowContinuedAsNew g t ->+        WorkflowStepRow+            { workflowId = unWorkflowId wid+            , workflowName = unWorkflowName name+            , generation = gen+            , stepName = continuedAsNewStepName+            , result = Aeson.toJSON g -- the NEXT generation this rotation opens+            , recordedAt = t+            }++{- | A stable, collision-resistant journal-event id from+@("keiro" : "workflow" : name : id : generation : stepName)@ via a v5 UUID.+Mirrors 'Keiro.ProcessManager.deterministicCommandId': the same inputs always+yield the same id, so a re-append of the same step collapses to the same row.++The /generation/ (EP-48) is part of the id so a step named @"s1"@ in+generation 0 and the same name in generation 1 produce __different__ kiroku+event ids — they live on different physical streams, but the event id is+global, so namespacing it by generation keeps rotated generations from+colliding on the deterministic id.+-}+deterministicJournalId :: WorkflowName -> WorkflowId -> Int -> Text -> EventId+deterministicJournalId (WorkflowName name) (WorkflowId wid) gen key =+    EventId $+        UUID.V5.generateNamed UUID.V5.namespaceURL $+            fmap (fromIntegral . fromEnum) $+                Text.unpack $+                    Text.intercalate ":" ["keiro", "workflow", name, wid, Text.pack (show gen), key]
+ src/Keiro/Workflow/Awakeable.hs view
@@ -0,0 +1,340 @@+{- | Awakeables: durable promises an external system resolves.++== What this gives you++A workflow allocates an opaque 'AwakeableId', hands it to some external system+(a webhook handler, a human approver, an LLM tool call), and suspends until+that system /signals/ the id with a result — no polling, no bespoke+"wait for event X then react in a process manager" wiring.++@+approvalFlow :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text+approvalFlow = do+  (aid, await) <- 'awakeableNamed' (StepName \"approval\")  -- allocate the promise+  -- (hand @aid@ to a webhook handler / human / LLM tool here)+  decision <- await                                       -- SUSPEND until signalled+  'Keiro.Workflow.step' (StepName \"use\") (pure (decision <> \"!\"))+@++On the __first__ 'Keiro.Workflow.runWorkflow' this returns 'Suspended' (the run+parked on @await@) and a @pending@ row appears in @keiro_awakeables@. An+external caller later runs @'signalAwakeable' aid \"ok\"@, which flips the row+to @completed@ /and/ appends a @StepRecorded \"awk:\<uuid\>\"@ to the workflow's+journal. The __next__ run replays past the now-resolved @await@ and 'Completed's.++== Contract recap for downstream plans (the v2 MasterPlan)++* 'AwakeableId' is journaled randomness: new allocations generate an opaque v4+  UUID and record it under @awkid:\<label\>@ before awaiting @awk:\<uuid\>@.+  Replay reads the journaled id, so a resumed workflow allocates the same id it+  already handed out without making that id guessable from public coordinates.+* 'awakeableNamed' (caller-supplied label) is the __stable primitive__;+  'awakeable' is an ordinal convenience whose label is positional (a fragile+  derivation across code edits — see its Haddock).+* Awakeables journal their completion as ordinary 'StepRecorded' events under+  the reserved @awk:@ prefix ('Keiro.Workflow.awakeableStepPrefix'), never a+  new event type, so EP-38's replay loop stays uniform.+* 'signalAwakeable' is idempotent /and/ crash-safe: it commits the row update+  and journal append in one transaction for new signals, a double signal+  returns 'False' and does not change the recorded value, and a signal of an+  already-@completed@ awakeable re-appends the journal entry from the stored+  payload to repair historical wedges.+* 'cancelAwakeable' abandons a still-@pending@ promise; a workflow that+  re-enters its @await@ then throws 'WorkflowAwakeableCancelled', which the+  author can @catch@ for compensation. If uncaught, EP-42's resume worker+  records an attempt, backs off, and eventually appends 'WorkflowFailed' at the+  configured failure ceiling.+* @countPendingAwakeables@ (in "Keiro.Workflow.Awakeable.Schema") backs EP-44's+  @keiro.workflow.awakeables.pending@ gauge.+-}+module Keiro.Workflow.Awakeable (+    -- * Awakeable ids+    AwakeableId (..),+    awakeableIdToUuid,+    awakeableIdText,+    deterministicAwakeableId,++    -- * Authoring surface (inside a workflow)+    awakeableNamed,+    awakeable,++    -- * External completion (outside a workflow)+    signalAwakeable,+    cancelAwakeable,++    -- * Errors+    WorkflowAwakeableCancelled (..),+)+where++import Control.Exception (Exception)+import Data.Text qualified as Text+import Data.UUID (UUID)+import Data.UUID qualified as UUID+import Data.UUID.V4 qualified as UUID.V4+import Data.UUID.V5 qualified as UUID.V5+import Effectful (Eff, IOE, (:>))+import Effectful.Exception (throwIO)+import Keiro.Prelude+import Keiro.Workflow (+    JournalAppendOutcome (..),+    StepName (..),+    Workflow,+    WorkflowError (..),+    WorkflowId (..),+    WorkflowJournalEvent (..),+    WorkflowName (..),+    appendJournalEntry,+    awaitStep,+    awakeableAllocStepPrefix,+    awakeableStepPrefix,+    currentGeneration,+    currentRunGeneration,+    currentWorkflow,+    freshOrdinal,+    prepareJournalAppend,+    step,+ )+import Keiro.Workflow.Awakeable.Schema (+    AwakeableStatus (..),+    cancelAwakeableTx,+    completeAwakeableTx,+    lookupAwakeable,+    registerAwakeableTx,+ )+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import "hasql-transaction" Hasql.Transaction qualified as Tx++-- ---------------------------------------------------------------------------+-- Awakeable ids+-- ---------------------------------------------------------------------------++{- | The opaque id of an awakeable. New allocations are random and journaled by+'awakeableNamed'; 'deterministicAwakeableId' is retained only as a legacy+generation-0 adoption helper. The @ToJSON@\/@FromJSON@ instances are over the+inner UUID, so the workflow journal can replay the id and webhook payloads may+carry it.+-}+newtype AwakeableId = AwakeableId UUID+    deriving stock (Eq, Show, Generic)+    deriving newtype (ToJSON, FromJSON)++-- | The raw UUID inside an 'AwakeableId'.+awakeableIdToUuid :: AwakeableId -> UUID+awakeableIdToUuid (AwakeableId u) = u++{- | The 'AwakeableId' rendered as text — the suffix of the @awk:\<uuid\>@+journal step name an awakeable's completion is recorded under.+-}+awakeableIdText :: AwakeableId -> Text+awakeableIdText = UUID.toText . awakeableIdToUuid++{- | The legacy deterministic 'AwakeableId' for a @(workflow name, workflow id,+label)@: a v5 UUID over @(\"keiro\":\"awakeable\":name:id:label)@.++This is predictable from public coordinates, so new code must not hand-derive+ids with it. It remains exported for operators and for generation-0 adoption:+if a pre-change workflow already registered a row under this id, the first+post-change allocation adopts that row so the in-flight promise keeps working.+-}+deterministicAwakeableId :: WorkflowName -> WorkflowId -> Text -> AwakeableId+deterministicAwakeableId (WorkflowName name) (WorkflowId wid) label =+    AwakeableId $+        UUID.V5.generateNamed UUID.V5.namespaceURL $+            fmap (fromIntegral . fromEnum) $+                Text.unpack $+                    Text.intercalate ":" ["keiro", "awakeable", name, wid, label]++-- ---------------------------------------------------------------------------+-- Errors+-- ---------------------------------------------------------------------------++{- | Thrown out of 'Keiro.Workflow.runWorkflow' when a workflow re-enters the+@await@ of an awakeable that was 'cancelAwakeable'd. A cancelled awakeable will+never be signalled, so suspending forever would be wrong and silently+completing would fabricate a result; the workflow author can @catch@ this to+run compensation. If uncaught, the resume worker records the attempt and+eventually marks the workflow failed at its configured ceiling.+-}+newtype WorkflowAwakeableCancelled = WorkflowAwakeableCancelled AwakeableId+    deriving stock (Eq, Show)++instance Exception WorkflowAwakeableCancelled++-- ---------------------------------------------------------------------------+-- Authoring surface+-- ---------------------------------------------------------------------------++{- | Allocate an awakeable under the stable, caller-supplied @label@. Returns+the 'AwakeableId' (hand it to the external system) and an @await@ action that+'Suspended's the workflow until the awakeable is signalled, then yields the+decoded payload on a later run.++The @label@ is the only fully-deterministic option: it survives code edits that+insert or remove awakeables elsewhere in the workflow (the same robustness+argument EP-38 makes for named steps over positional history). Prefer this over+'awakeable' for anything that may outlive a code change mid-flight.+-}+awakeableNamed ::+    (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>+    StepName ->+    Eff es (AwakeableId, Eff es a)+awakeableNamed (StepName label) = do+    (name, wid) <- currentWorkflow+    gen <- currentRunGeneration+    aid <-+        step (StepName (awakeableAllocStepPrefix <> label)) $+            allocateAwakeableId name wid gen label+    let+        stepNm = StepName (awakeableStepPrefix <> awakeableIdText aid)+        await = awaitCancellable name wid aid stepNm+    pure (aid, await)++allocateAwakeableId ::+    (Store :> es, IOE :> es) =>+    WorkflowName ->+    WorkflowId ->+    Int ->+    Text ->+    Eff es AwakeableId+allocateAwakeableId name wid gen label+    | gen <= 0 = do+        let legacy = deterministicAwakeableId name wid label+        existing <- lookupAwakeable (awakeableIdToUuid legacy)+        case existing of+            Just _ -> pure legacy+            Nothing -> AwakeableId <$> liftIO UUID.V4.nextRandom+    | otherwise = AwakeableId <$> liftIO UUID.V4.nextRandom++{- | Allocate an awakeable under an ordinal label (the @N@th awakeable in a run+becomes @ord:N@). Convenient, but its determinism is __conditional__: adding or+removing an 'awakeable' call earlier in the workflow shifts every later ordinal+and so changes their derived ids, which corrupts an in-flight workflow exactly+the way EP-38 warns positional history does. Prefer 'awakeableNamed' for+anything that may outlive a code edit.+-}+awakeable ::+    (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>+    Eff es (AwakeableId, Eff es a)+awakeable = do+    n <- freshOrdinal awakeableStepPrefix+    awakeableNamed (StepName ("ord:" <> Text.pack (show n)))++{- | EP-38's 'awaitStep', wrapped so that a re-entered @await@ on a+'Cancelled' awakeable throws 'WorkflowAwakeableCancelled' instead of suspending+forever. The check lives /inside/ the arming action because 'awaitStep' runs+@arm@ only on the miss path (the awakeable not yet journaled) and re-runs it on+every resume until it resolves: on a miss we either notice the cancel and throw,+or (re-)register the idempotent @pending@ row and suspend. On the hit path+('signalAwakeable' already journaled the result) @arm@ is never run, so a+signalled-then-cancelled race still returns the signalled value (signal wins — a+resolved promise cannot be un-resolved).+-}+awaitCancellable ::+    (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>+    WorkflowName -> WorkflowId -> AwakeableId -> StepName -> Eff es a+awaitCancellable name wid aid stepNm =+    awaitStep stepNm $ do+        existing <- lookupAwakeable (awakeableIdToUuid aid)+        case existing of+            Just row+                | row ^. #status == Cancelled ->+                    throwIO (WorkflowAwakeableCancelled aid)+                | row ^. #status == Completed+                , Just payload <- row ^. #payload -> do+                    now <- liftIO getCurrentTime+                    appendJournalEntry+                        name+                        wid+                        StepRecorded+                            { stepName = unStepName stepNm+                            , result = payload+                            , recordedAt = now+                            }+            _ ->+                runTransaction $+                    registerAwakeableTx (awakeableIdToUuid aid) (unWorkflowName name) (unWorkflowId wid)++-- ---------------------------------------------------------------------------+-- External completion+-- ---------------------------------------------------------------------------++{- | Resolve an awakeable from outside the workflow: store @result@ in the+@keiro_awakeables@ row /and/ append a @StepRecorded@ to the owning workflow's+journal so the next run replays past the @await@.++Idempotent and crash-safe:++* Returns 'True' only when /this/ call transitioned the row @pending@ ->+  @completed@; a second signal (or a signal of a @cancelled@ row) returns+  'False' and leaves the stored payload unchanged.+* For a @pending@ row, the row transition and journal append happen in one+  transaction. For an already-@completed@ row, the journal entry is re-appended+  from the stored payload to repair rows wedged before that atomic path existed.+  The append path is idempotent (deterministic event id plus step-index check),+  so a re-append collapses to a no-op once the entry is present.++A 'False' return therefore does not mean "nothing happened": the journal may+still have been repaired. Returns 'False' for an unknown id.+-}+signalAwakeable :: (IOE :> es, Store :> es, ToJSON r) => AwakeableId -> r -> Eff es Bool+signalAwakeable aid result = do+    mrow <- lookupAwakeable (awakeableIdToUuid aid)+    case mrow of+        Nothing -> pure False+        Just row+            | row ^. #status == Cancelled -> pure False+            | otherwise -> do+                now <- liftIO getCurrentTime+                let payload =+                        if row ^. #status == Completed+                            then row ^. #payload+                            else Just (toJSON result)+                case payload of+                    Nothing -> pure False+                    Just payloadValue -> do+                        let ownerName = WorkflowName (row ^. #ownerWorkflowName)+                            ownerId = WorkflowId (row ^. #ownerWorkflowId)+                        gen <- currentGeneration ownerName ownerId+                        appendTx <-+                            prepareJournalAppend+                                ownerName+                                ownerId+                                gen+                                StepRecorded+                                    { stepName = awakeableStepPrefix <> awakeableIdText aid+                                    , result = payloadValue+                                    , recordedAt = now+                                    }+                        (transitioned, appendOutcome) <-+                            runTransaction $ do+                                transitioned <-+                                    if row ^. #status == Pending+                                        then completeAwakeableTx (awakeableIdToUuid aid) (toJSON result) now+                                        else pure False+                                appendOutcome <- appendTx+                                condemnOnAppendConflict appendOutcome+                                pure (transitioned, appendOutcome)+                        throwOnAppendConflict appendOutcome+                        pure transitioned++condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction ()+condemnOnAppendConflict = \case+    JournalAppendConflict{} -> Tx.condemn+    _ -> pure ()++throwOnAppendConflict :: JournalAppendOutcome -> Eff es ()+throwOnAppendConflict = \case+    JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))+    _ -> pure ()++{- | Abandon a still-@pending@ awakeable: flips its row to @cancelled@ and+writes __no__ journal entry (there is no result value to record). Returns 'True'+when it transitioned a @pending@ row, 'False' otherwise (already completed,+already cancelled, or unknown). A workflow that later re-enters the awakeable's+@await@ then throws 'WorkflowAwakeableCancelled'.+-}+cancelAwakeable :: (Store :> es) => AwakeableId -> Eff es Bool+cancelAwakeable aid =+    runTransaction $ cancelAwakeableTx (awakeableIdToUuid aid)
+ src/Keiro/Workflow/Awakeable/Schema.hs view
@@ -0,0 +1,214 @@+{- | The @keiro_awakeables@ table: durable storage for awakeables (external+promises a workflow suspends on).++Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ split: this module owns the+row type, the 'AwakeableStatus' lifecycle, and the hasql statements;+"Keiro.Workflow.Awakeable" owns the effectful authoring\/completion surface.++* 'registerAwakeableTx' inserts a @pending@ row idempotently (the+  @ON CONFLICT DO NOTHING@ EP-38's @awaitStep@ arming contract requires).+* 'lookupAwakeable' reads a row back.+* 'completeAwakeableTx' transitions a @pending@ row to @completed@ (guarded so+  a double signal is a no-op), and 'cancelAwakeableTx' transitions it to+  @cancelled@.+* 'countPendingAwakeables' counts outstanding promises — the seam EP-44 reads+  for its @keiro.workflow.awakeables.pending@ gauge.++Callers normally use the re-exports / surface from "Keiro.Workflow.Awakeable"+rather than this module directly; EP-44 imports 'countPendingAwakeables' here+without pulling in the effect surface.+-}+module Keiro.Workflow.Awakeable.Schema (+    -- * Rows and status+    AwakeableStatus (..),+    AwakeableRow (..),+    statusToText,+    statusFromText,++    -- * Storage (run inside the caller's transaction)+    registerAwakeableTx,+    completeAwakeableTx,+    cancelAwakeableTx,++    -- * Read-only lookups+    lookupAwakeable,+    countPendingAwakeables,+)+where++import Contravariant.Extras (contrazip3)+import Data.UUID (UUID)+import Effectful (Eff, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Prelude+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import "hasql-transaction" Hasql.Transaction qualified as Tx++{- | An awakeable's lifecycle state.++* 'Pending' — allocated and waiting for an external signal; the workflow is+  suspended on it.+* 'Completed' — signalled with a payload; terminal.+* 'Cancelled' — abandoned before it was signalled; terminal; also the decode+  fallback for an unrecognized stored value (the same defensive choice+  "Keiro.Timer.Schema" makes).+-}+data AwakeableStatus+    = Pending+    | Completed+    | Cancelled+    deriving stock (Generic, Eq, Show)++{- | An awakeable row as stored: the deterministic id, the owning workflow's+name and instance id, the live 'status', the signalled 'payload' (JSON, set+only once 'Completed'), and the timestamps.+-}+data AwakeableRow = AwakeableRow+    { awakeableId :: !UUID+    , ownerWorkflowName :: !Text+    , ownerWorkflowId :: !Text+    , status :: !AwakeableStatus+    , payload :: !(Maybe Value)+    , createdAt :: !UTCTime+    , updatedAt :: !UTCTime+    , completedAt :: !(Maybe UTCTime)+    }+    deriving stock (Generic, Eq, Show)++{- | Insert a @pending@ awakeable row inside the caller's transaction.+Idempotent by @ON CONFLICT (awakeable_id) DO NOTHING@ — exactly what EP-38's+"arm must be idempotent" contract needs, since a resumed workflow re-runs the+arming action on every resume until the awakeable resolves.+-}+registerAwakeableTx :: UUID -> Text -> Text -> Tx.Transaction ()+registerAwakeableTx aid name wid =+    Tx.statement (aid, name, wid) registerAwakeableStmt++{- | Transition a @pending@ awakeable to @completed@, storing @payload@ and the+completion time, inside the caller's transaction. The @status = 'pending'@+guard makes a double-signal a no-op; returns 'True' only when this call+performed the transition (so the caller knows whether it was the one that+resolved the promise).+-}+completeAwakeableTx :: UUID -> Value -> UTCTime -> Tx.Transaction Bool+completeAwakeableTx aid result now =+    Tx.statement (aid, result, now) completeAwakeableStmt++{- | Transition a @pending@ awakeable to @cancelled@ inside the caller's+transaction. Only @pending@ rows match, so an already-completed (or+already-cancelled) awakeable is left untouched and the call returns 'False'.+-}+cancelAwakeableTx :: UUID -> Tx.Transaction Bool+cancelAwakeableTx aid =+    Tx.statement aid cancelAwakeableStmt++-- | Read an awakeable row by id. 'Nothing' if no such awakeable exists.+lookupAwakeable :: (Store :> es) => UUID -> Eff es (Maybe AwakeableRow)+lookupAwakeable aid =+    runTransaction (Tx.statement aid lookupAwakeableStmt)++{- | Count awakeables currently @pending@. Read-only. EP-44 backs the+@keiro.workflow.awakeables.pending@ gauge with this.+-}+countPendingAwakeables :: (Store :> es) => Eff es Int+countPendingAwakeables =+    runTransaction (Tx.statement () countPendingAwakeablesStmt)++registerAwakeableStmt :: Statement (UUID, Text, Text) ()+registerAwakeableStmt =+    preparable+        """+        INSERT INTO keiro.keiro_awakeables+          (awakeable_id, owner_workflow_name, owner_workflow_id, status)+        VALUES ($1, $2, $3, 'pending')+        ON CONFLICT (awakeable_id) DO NOTHING+        """+        ( contrazip3+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++completeAwakeableStmt :: Statement (UUID, Value, UTCTime) Bool+completeAwakeableStmt =+    preparable+        """+        UPDATE keiro.keiro_awakeables+        SET status = 'completed',+            payload = $2,+            completed_at = $3,+            updated_at = now()+        WHERE awakeable_id = $1+          AND status = 'pending'+        """+        ( contrazip3+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.jsonb))+            (E.param (E.nonNullable E.timestamptz))+        )+        ((> 0) <$> D.rowsAffected)++cancelAwakeableStmt :: Statement UUID Bool+cancelAwakeableStmt =+    preparable+        """+        UPDATE keiro.keiro_awakeables+        SET status = 'cancelled',+            updated_at = now()+        WHERE awakeable_id = $1+          AND status = 'pending'+        """+        (E.param (E.nonNullable E.uuid))+        ((> 0) <$> D.rowsAffected)++lookupAwakeableStmt :: Statement UUID (Maybe AwakeableRow)+lookupAwakeableStmt =+    preparable+        """+        SELECT awakeable_id, owner_workflow_name, owner_workflow_id, status,+          payload, created_at, updated_at, completed_at+        FROM keiro.keiro_awakeables+        WHERE awakeable_id = $1+        """+        (E.param (E.nonNullable E.uuid))+        (D.rowMaybe awakeableRowDecoder)++countPendingAwakeablesStmt :: Statement () Int+countPendingAwakeablesStmt =+    preparable+        """+        SELECT count(*)+        FROM keiro.keiro_awakeables+        WHERE status = 'pending'+        """+        E.noParams+        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++awakeableRowDecoder :: D.Row AwakeableRow+awakeableRowDecoder =+    AwakeableRow+        <$> D.column (D.nonNullable D.uuid)+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> (statusFromText <$> D.column (D.nonNullable D.text))+        <*> D.column (D.nullable D.jsonb)+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nullable D.timestamptz)++statusToText :: AwakeableStatus -> Text+statusToText = \case+    Pending -> "pending"+    Completed -> "completed"+    Cancelled -> "cancelled"++statusFromText :: Text -> AwakeableStatus+statusFromText = \case+    "pending" -> Pending+    "completed" -> Completed+    "cancelled" -> Cancelled+    _ -> Cancelled
+ src/Keiro/Workflow/Child.hs view
@@ -0,0 +1,462 @@+{- | Child workflows: spawn, wait on, and cancel a workflow from inside another.++== What this gives you++Fan-out\/fan-in composition of durable workflows. A /parent/ workflow spawns a+/child/ (a second workflow with its own journal stream), waits for the child's+result, and may cancel a child it no longer needs — with the whole relationship+surviving a crash, because the spawn is recorded in the parent's journal and the+link is stored in @keiro_workflow_children@.++@+parent :: ('Workflow' ':>' es, 'Store' ':>' es, 'IOE' ':>' es) => Eff es Text+parent = do+  h      <- 'spawnChild' (WorkflowName \"ship-order\") (WorkflowId \"ord-7\") shipWorkflow+  result <- 'awaitChild' h                  -- SUSPEND until the child completes+  _      <- 'Keiro.Workflow.step' (StepName \"notify\") (pure (\"shipped: \" <> result))+  pure result+@++== How it works (contract recap for downstream plans)++* __'spawnChild' is a journaled step.__ It records a @StepRecorded+  \"child:\<childId\>\"@ in the /parent/ journal (so a replay short-circuits the+  spawn and never re-spawns) and inserts a @running@ row in+  @keiro_workflow_children@ linking the child back to the parent plus the+  parent-journal step the parent awaits (@child:\<childId\>:result@). It does+  __not__ run the child inline — the EP-42 resume worker drives the child to+  completion from the application's @WorkflowRegistry@, so __a child's+  'WorkflowName' must be registered there__, exactly like any resumable+  workflow. (The @childDef@ argument is taken for authoring ergonomics; the+  registry, keyed by 'WorkflowName', is the source of truth for the child's+  body.)+* __'awaitChild' reuses EP-38's suspension primitive__ — it is+  @'awaitStep' (StepName \"child:\<childId\>:result\") arm@. On the miss path it+  re-delivers a completed child's stored result onto the current parent+  generation (attach semantics), throws 'WorkflowChildCancelled' if the child+  was cancelled meanwhile, and otherwise re-asserts nothing new (the spawn+  already registered the link). On the hit path+  it decodes a tagged parent-journal envelope: @{"ok": result}@ returns the+  child result, @{"cancelled": true}@ throws 'WorkflowChildCancelled',+  @{"failed": reason}@ throws 'WorkflowChildFailed', and legacy raw values are+  still decoded as pre-envelope successful results.+* __'runChildWorkflow'__ is what the resume worker selects (instead of bare+  'Keiro.Workflow.runWorkflowWith') for any workflow that is some parent's child:+  on 'Completed' it runs 'childCompletionHook', which flips the child row to+  @completed@ and appends @{"ok": result}@ to the parent's+  @child:\<childId\>:result@ step. If it finds a historically+  @cancelled@-but-unmarked row, it ensures the child cancellation marker and+  parent sentinel before returning 'Cancelled'.+* __'cancelChild'__ flips the child row to @cancelled@ and, in the same+  transaction, writes a 'Keiro.Workflow.WorkflowCancelled' marker to the+  /child/ journal plus a @{"cancelled": true}@ sentinel as the parent's+  await-step result. Retrying after a historical row-only cancel repairs both+  markers even though the return value remains 'False' ("this call did not+  transition the row").+* @'Keiro.Workflow.Child.Schema.countActiveChildren'@ backs a potential+  @keiro.workflow.children.active@ gauge for EP-44.+-}+module Keiro.Workflow.Child (+    -- * Child handles and reserved step names+    ChildHandle (..),+    childSpawnStepName,+    childResultStepName,++    -- * Authoring surface (inside a parent workflow)+    spawnChild,+    awaitChild,++    -- * External control+    cancelChild,++    -- * Driving a child to completion (used by the resume worker)+    runChildWorkflow,+    childCompletionHook,++    -- * Errors+    WorkflowChildCancelled (..),+    WorkflowChildFailed (..),+)+where++import Control.Exception (Exception)+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Text qualified as Text+import Effectful (Eff, IOE, (:>))+import Effectful.Error.Static (Error)+import Effectful.Exception (throwIO)+import Keiro.Prelude+import Keiro.Workflow (+    JournalAppendOutcome (..),+    StepName (..),+    Workflow,+    WorkflowError (..),+    WorkflowId (..),+    WorkflowJournalEvent (..),+    WorkflowName (..),+    WorkflowOutcome (..),+    WorkflowRunOptions,+    appendJournalEntry,+    awaitStep,+    childStepPrefix,+    currentGeneration,+    currentWorkflow,+    prepareJournalAppend,+    runWorkflowWith,+    step,+ )+import Keiro.Workflow.Child.Schema (+    ChildRow,+    ChildStatus (..),+    lookupChild,+    markChildCancelledTx,+    markChildResultTx,+    registerChildTx,+ )+import Keiro.Workflow.Instance (WorkflowStatus (..), upsertInstanceTx)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Error (StoreError)+import Kiroku.Store.Transaction (runTransaction)+import "hasql-transaction" Hasql.Transaction qualified as Tx++-- ---------------------------------------------------------------------------+-- Handles and reserved step names+-- ---------------------------------------------------------------------------++{- | An in-memory handle to a spawned child, returned by 'spawnChild' and taken+by 'awaitChild' \/ 'cancelChild'. The phantom type parameter @a@ records the+child's result type so 'awaitChild' decodes without an extra annotation; the+handle itself carries only the child's name and id (the child journal is+@wf:\<childName\>-\<childWfId\>@).+-}+data ChildHandle a = ChildHandle+    { childName :: !WorkflowName+    , childWfId :: !WorkflowId+    }+    deriving stock (Eq, Show)++{- | The reserved /spawn/ step name a child is recorded under in its parent's+journal: @child:\<childId\>@ (uses EP-38's 'childStepPrefix').+-}+childSpawnStepName :: WorkflowId -> Text+childSpawnStepName (WorkflowId wid) = childStepPrefix <> wid++{- | The reserved /result/ step name the parent awaits and the child's+completion is propagated under: @child:\<childId\>:result@.+-}+childResultStepName :: WorkflowId -> Text+childResultStepName (WorkflowId wid) = childStepPrefix <> wid <> ":result"++-- ---------------------------------------------------------------------------+-- Errors+-- ---------------------------------------------------------------------------++{- | Thrown out of 'awaitChild' when the awaited child was 'cancelChild'led. A+cancelled child never produces a result, so suspending forever would be wrong+and fabricating a result would be wrong; the parent author can @catch@ this to+run compensation. If uncaught, the resume worker records the parent attempt,+backs it off, and eventually marks the parent failed at its configured ceiling.+Mirrors EP-40's 'Keiro.Workflow.Awakeable.WorkflowAwakeableCancelled'.+-}+data WorkflowChildCancelled = WorkflowChildCancelled WorkflowName WorkflowId+    deriving stock (Eq, Show)++instance Exception WorkflowChildCancelled++{- | Thrown out of 'awaitChild' when the child was terminally failed by the+resume worker. Carries the child's identity plus the persisted failure reason.+-}+data WorkflowChildFailed = WorkflowChildFailed WorkflowName WorkflowId Text+    deriving stock (Eq, Show)++instance Exception WorkflowChildFailed++-- ---------------------------------------------------------------------------+-- Authoring surface+-- ---------------------------------------------------------------------------++{- | Spawn a child workflow. Records a @StepRecorded \"child:\<childId\>\"@ in+the /parent/ journal (so a replay short-circuits and never re-spawns) and+inserts an idempotent @running@ link row, then returns a 'ChildHandle'. The+child is driven to completion by the resume worker from the registry, so+@childNm@ __must be registered there__; @childDef@ is accepted for authoring+ergonomics but is not run here.++A child id names one execution globally. Spawning an id whose child row already+completed attaches to that execution: 'awaitChild' re-delivers the stored+result onto the parent's current generation. To run a fresh child after+'Keiro.Workflow.continueAsNew', derive a fresh child id from the carried seed.+-}+spawnChild ::+    (Workflow :> es, Store :> es) =>+    -- | The child's name (must be in the resume worker's registry).+    WorkflowName ->+    -- | The child's id (names the child journal).+    WorkflowId ->+    -- | The child workflow definition (for authoring; the registry actually runs it).+    Eff (Workflow : es) a ->+    Eff es (ChildHandle a)+spawnChild childNm childWid _childDef = do+    (parentNm, parentWid) <- currentWorkflow+    let spawnStep = StepName (childSpawnStepName childWid)+        resultStep = childResultStepName childWid+    -- Journaled as a step in the PARENT journal: a parent replay short-circuits+    -- this body, and the ON CONFLICT DO NOTHING register collapses on re-run.+    _ <-+        step spawnStep $ do+            runTransaction $+                registerChildTx+                    (unWorkflowId childWid)+                    (unWorkflowName childNm)+                    (unWorkflowId parentWid)+                    (unWorkflowName parentNm)+                    resultStep+                    *> upsertInstanceTx+                        (unWorkflowId childWid)+                        (unWorkflowName childNm)+                        0+                        WfRunning+                        Nothing+            pure ()+    pure (ChildHandle childNm childWid)++{- | Suspend the parent until the child completes, then return the child's+result. This is EP-38's 'awaitStep' on the @child:\<childId\>:result@ step:+'childCompletionHook' journals that step into the parent when the child+finishes, so the next parent run replays past the wait and decodes the result.++If the child was cancelled or failed, throws 'WorkflowChildCancelled' or+'WorkflowChildFailed'. Parent-journal values are tagged envelopes+(@{"ok": ...}@, @{"cancelled": true}@, @{"failed": reason}@) with a legacy raw+success fallback; a decode mismatch throws 'WorkflowStepDecodeError'.+-}+awaitChild ::+    (Workflow :> es, Store :> es, IOE :> es, FromJSON a) =>+    ChildHandle a ->+    Eff es a+awaitChild (ChildHandle childNm childWid) = do+    let resultStep = StepName (childResultStepName childWid)+        arm = do+            mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)+            case mrow of+                Just row+                    | (row ^. #status) == ChildCancelled ->+                        throwIO (WorkflowChildCancelled childNm childWid)+                    | (row ^. #status) == ChildCompleted+                    , Just resultValue <- row ^. #result ->+                        appendJournalEntry+                            (WorkflowName (row ^. #parentName))+                            (WorkflowId (row ^. #parentId))+                            StepRecorded+                                { stepName = row ^. #awaitStep+                                , result = childOkEnvelope resultValue+                                , recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt)+                                }+                -- The spawn already registered the link; nothing more to (re-)arm.+                _ -> pure ()+    raw <- awaitStep resultStep arm+    decodeChildResult childNm childWid (unStepName resultStep) raw++-- ---------------------------------------------------------------------------+-- External control+-- ---------------------------------------------------------------------------++{- | Cancel a child. For a @running@ child, flips its+@keiro_workflow_children@ row to @cancelled@ and, in the same transaction,+writes both the child's 'WorkflowCancelled' marker and the parent's+@{"cancelled": true}@ await-step sentinel. Returns 'True' only when this call+performed the row transition. For an already-@cancelled@ row, returns 'False'+but still ensures both markers, repairing historical crashes that committed the+row flip before either journal append. Already completed/failed/unknown+children return 'False' and no marker is fabricated.+-}+cancelChild ::+    (IOE :> es, Store :> es) =>+    ChildHandle a ->+    Eff es Bool+cancelChild (ChildHandle childNm childWid) = do+    mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)+    case mrow of+        Nothing -> pure False+        Just row -> do+            (transitioned, childOutcome, parentOutcome) <- ensureChildCancelled row+            throwOnAppendConflict childOutcome+            throwOnAppendConflict parentOutcome+            pure transitioned++-- ---------------------------------------------------------------------------+-- Completion propagation+-- ---------------------------------------------------------------------------++{- | Drive a child workflow to completion, propagating its result to the parent.+This is 'runWorkflowWith' followed by 'childCompletionHook' on 'Completed': the+resume worker selects this (instead of bare 'runWorkflowWith') for any workflow+that is some parent's child, so a finished child wakes its waiting parent. A+'Suspended' child propagates nothing. A child row already marked 'ChildCancelled'+is repaired by ensuring the child cancellation marker and parent sentinel, then+returns 'Cancelled'; a 'ChildFailed' row returns 'Failed'.+-}+runChildWorkflow ::+    (IOE :> es, Store :> es, Error StoreError :> es, ToJSON a) =>+    WorkflowRunOptions ->+    WorkflowName ->+    WorkflowId ->+    Eff (Workflow : es) a ->+    Eff es (WorkflowOutcome a)+runChildWorkflow opts childNm childWid action = do+    mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)+    case fmap (^. #status) mrow of+        Just ChildCancelled -> do+            for_ mrow $ \row -> do+                (_, childOutcome, parentOutcome) <- ensureChildCancelled row+                throwOnAppendConflict childOutcome+                throwOnAppendConflict parentOutcome+            pure Cancelled+        Just ChildFailed -> pure Failed+        _ -> do+            outcome <- runWorkflowWith opts childNm childWid action+            case outcome of+                Completed result -> do+                    childCompletionHook childNm childWid (toJSON result)+                    pure (Completed result)+                other -> pure other++{- | Propagate a finished child's result to its parent: flip the child row to+@completed@ (storing the raw result in the child row) and append an+@{"ok": result}@ @child:\<childId\>:result@ 'StepRecorded' to the /parent/+journal — exactly the wake source the parent's 'awaitChild' resolves on. The+running-row transition and parent append happen in one transaction. An+already-@completed@ row re-appends from the stored result, repairing historical+wedges; cancelled/failed children do not fabricate a success. Normally invoked+via 'runChildWorkflow'.+-}+childCompletionHook ::+    (IOE :> es, Store :> es) =>+    WorkflowName ->+    WorkflowId ->+    Aeson.Value ->+    Eff es ()+childCompletionHook childNm childWid resultValue = do+    mrow <- lookupChild (unWorkflowId childWid) (unWorkflowName childNm)+    for_ mrow $ \row -> case row ^. #status of+        Running -> do+            now <- liftIO getCurrentTime+            let parentName = WorkflowName (row ^. #parentName)+                parentId = WorkflowId (row ^. #parentId)+            gen <- currentGeneration parentName parentId+            appendTx <-+                prepareJournalAppend+                    parentName+                    parentId+                    gen+                    StepRecorded+                        { stepName = row ^. #awaitStep+                        , result = childOkEnvelope resultValue+                        , recordedAt = now+                        }+            appendOutcome <-+                runTransaction $ do+                    transitioned <- markChildResultTx (unWorkflowId childWid) (unWorkflowName childNm) resultValue now+                    if transitioned+                        then do+                            appendOutcome <- appendTx+                            condemnOnAppendConflict appendOutcome+                            pure appendOutcome+                        else pure (JournalAlreadyPresent resultValue)+            throwOnAppendConflict appendOutcome+        ChildCompleted ->+            for_ (row ^. #result) $ \stored ->+                appendJournalEntry+                    (WorkflowName (row ^. #parentName))+                    (WorkflowId (row ^. #parentId))+                    StepRecorded+                        { stepName = row ^. #awaitStep+                        , result = childOkEnvelope stored+                        , recordedAt = fromMaybe (row ^. #updatedAt) (row ^. #completedAt)+                        }+        ChildCancelled -> pure ()+        ChildFailed -> pure ()++condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction ()+condemnOnAppendConflict = \case+    JournalAppendConflict{} -> Tx.condemn+    _ -> pure ()++throwOnAppendConflict :: JournalAppendOutcome -> Eff es ()+throwOnAppendConflict = \case+    JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))+    _ -> pure ()++ensureChildCancelled ::+    (IOE :> es, Store :> es) =>+    ChildRow ->+    Eff es (Bool, JournalAppendOutcome, JournalAppendOutcome)+ensureChildCancelled row = do+    now <- liftIO getCurrentTime+    let childNm = WorkflowName (row ^. #childName)+        childWid = WorkflowId (row ^. #childId)+        parentNm = WorkflowName (row ^. #parentName)+        parentWid = WorkflowId (row ^. #parentId)+    childGen <- currentGeneration childNm childWid+    parentGen <- currentGeneration parentNm parentWid+    childAppendTx <- prepareJournalAppend childNm childWid childGen WorkflowCancelled{recordedAt = now}+    parentAppendTx <-+        prepareJournalAppend+            parentNm+            parentWid+            parentGen+            StepRecorded+                { stepName = row ^. #awaitStep+                , result = cancelledSentinel+                , recordedAt = now+                }+    runTransaction $ do+        transitioned <-+            if row ^. #status == Running+                then markChildCancelledTx (row ^. #childId) (row ^. #childName)+                else pure False+        if transitioned || row ^. #status == ChildCancelled+            then do+                childOutcome <- childAppendTx+                parentOutcome <- parentAppendTx+                condemnOnAppendConflict childOutcome+                condemnOnAppendConflict parentOutcome+                pure (transitioned, childOutcome, parentOutcome)+            else pure (False, JournalAlreadyPresent Aeson.Null, JournalAlreadyPresent Aeson.Null)++-- ---------------------------------------------------------------------------+-- The cancellation sentinel+-- ---------------------------------------------------------------------------++{- | The @{"cancelled": true}@ value 'cancelChild' writes as a cancelled child's+await-step result so 'awaitChild' can detect it and throw.+-}+cancelledSentinel :: Aeson.Value+cancelledSentinel = Aeson.object ["cancelled" Aeson..= True]++childOkEnvelope :: Aeson.Value -> Aeson.Value+childOkEnvelope value = Aeson.object ["ok" Aeson..= value]++decodeChildResult ::+    (FromJSON a) =>+    WorkflowName ->+    WorkflowId ->+    Text ->+    Aeson.Value ->+    Eff es a+decodeChildResult childNm childWid key raw =+    case raw of+        Aeson.Object obj+            | Just okValue <- KeyMap.lookup "ok" obj ->+                decodeOrThrow okValue+            | Just (Aeson.Bool True) <- KeyMap.lookup "cancelled" obj ->+                throwIO (WorkflowChildCancelled childNm childWid)+            | Just (Aeson.String reason) <- KeyMap.lookup "failed" obj ->+                throwIO (WorkflowChildFailed childNm childWid reason)+        _ -> decodeOrThrow raw+  where+    decodeOrThrow value =+        case Aeson.fromJSON value of+            Aeson.Success a -> pure a+            Aeson.Error e -> throwIO (WorkflowStepDecodeError key (Text.pack e))
+ src/Keiro/Workflow/Child/Schema.hs view
@@ -0,0 +1,315 @@+{- | The @keiro_workflow_children@ table: durable parent↔child workflow links.++Mirrors the @Keiro.Timer@ \/ @Keiro.Timer.Schema@ and+@Keiro.Workflow.Awakeable.Schema@ split: this module owns the row type, the+'ChildStatus' lifecycle, and the hasql statements; "Keiro.Workflow.Child" owns+the effectful spawn\/await\/cancel surface.++* 'registerChildTx' inserts a @running@ row idempotently (the+  @ON CONFLICT (child_id, child_name) DO NOTHING@ EP-38's @awaitStep@ arming+  contract requires — a resumed parent re-runs the arm on every resume).+* 'lookupChild' \/ 'lookupChildrenOfParent' read rows back (operator+  inspection and the @awaitChild@ arm's cancellation check).+* 'markChildResultTx' transitions a @running@ row to @completed@ (storing the+  child's result), and 'markChildCancelledTx' transitions it to @cancelled@;+  both guard on @status = 'running'@ so a double-resolve is a no-op.+* 'findRunningChildIds' is the resume worker's discovery seed for a zero-step+  child (one that has been spawned but not yet driven, so has no+  @keiro_workflow_steps@ rows for 'findUnfinishedWorkflowIds' to find).+* 'countActiveChildren' counts outstanding children — the seam EP-44 may read+  for a @keiro.workflow.children.active@ gauge.++Callers normally use the surface from "Keiro.Workflow.Child" rather than this+module directly.+-}+module Keiro.Workflow.Child.Schema (+    -- * Rows and status+    ChildStatus (..),+    ChildRow (..),+    statusToText,+    statusFromText,++    -- * Storage (run inside the caller's transaction)+    registerChildTx,+    markChildResultTx,+    markChildCancelledTx,+    markChildFailedTx,++    -- * Read-only lookups+    lookupChild,+    lookupChildrenOfParent,+    childStatus,+    countActiveChildren,+    findRunningChildIds,+)+where++import Contravariant.Extras (contrazip2, contrazip4, contrazip5)+import Effectful (Eff, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Prelude+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import "hasql-transaction" Hasql.Transaction qualified as Tx++{- | A child workflow's lifecycle, as seen from its parent.++* 'Running' — spawned and not yet finished; the resume worker drives it.+* 'ChildCompleted' — the child reached its own 'Keiro.Workflow.WorkflowCompleted'+  and its result was propagated to the parent journal; terminal.+* 'ChildCancelled' — the parent 'Keiro.Workflow.Child.cancelChild'led it;+  terminal; also the decode fallback for an unrecognized stored value (the same+  defensive choice "Keiro.Timer.Schema" makes).++The constructors are prefixed @Child@ to avoid clashing with+'Keiro.Workflow.WorkflowOutcome''s @Completed@ and the awakeable\/timer+@Cancelled@ constructors.+-}+data ChildStatus+    = Running+    | ChildCompleted+    | ChildCancelled+    | ChildFailed+    deriving stock (Generic, Eq, Show)++{- | A child link row as stored: the child's (id, name), the parent's (id,+name), the parent-journal step the parent awaits ('awaitStep' =+@child:\<childId\>:result@), the live 'status', the child's 'result' (set only+once 'ChildCompleted'), and the timestamps.+-}+data ChildRow = ChildRow+    { childId :: !Text+    , childName :: !Text+    , parentId :: !Text+    , parentName :: !Text+    , awaitStep :: !Text+    , status :: !ChildStatus+    , result :: !(Maybe Value)+    , createdAt :: !UTCTime+    , updatedAt :: !UTCTime+    , completedAt :: !(Maybe UTCTime)+    }+    deriving stock (Generic, Eq, Show)++{- | Insert a @running@ child link row inside the caller's transaction, given+the child's @(id, name)@, the parent's @(id, name)@, and the parent-journal+step the parent awaits (@await_step@). Idempotent by+@ON CONFLICT (child_id, child_name) DO NOTHING@ — exactly what EP-38's "arm+must be idempotent" contract needs, since the spawn step and every resume's arm+re-run it. @status@, @result@, and the timestamps take their table defaults, so+no clock read is needed at the spawn site (mirrors+'Keiro.Workflow.Awakeable.Schema.registerAwakeableTx').+-}+registerChildTx :: Text -> Text -> Text -> Text -> Text -> Tx.Transaction ()+registerChildTx cid cname pid pname awaitStep =+    Tx.statement (cid, cname, pid, pname, awaitStep) registerChildStmt++{- | Transition a @running@ child to @completed@, storing @result@ and the+completion time, inside the caller's transaction. The @status = 'running'@+guard makes a double-complete a no-op; returns 'True' only when this call+performed the transition.+-}+markChildResultTx :: Text -> Text -> Value -> UTCTime -> Tx.Transaction Bool+markChildResultTx cid cname result now =+    Tx.statement (cid, cname, result, now) markChildResultStmt++{- | Transition a @running@ child to @cancelled@ inside the caller's+transaction. Only @running@ rows match, so an already-completed (or+already-cancelled) child is left untouched and the call returns 'False'.+-}+markChildCancelledTx :: Text -> Text -> Tx.Transaction Bool+markChildCancelledTx cid cname =+    Tx.statement (cid, cname) markChildCancelledStmt++markChildFailedTx :: Text -> Text -> Tx.Transaction Bool+markChildFailedTx cid cname =+    Tx.statement (cid, cname) markChildFailedStmt++-- | Read a child link row by @(child_id, child_name)@. 'Nothing' if absent.+lookupChild :: (Store :> es) => Text -> Text -> Eff es (Maybe ChildRow)+lookupChild cid cname =+    runTransaction (Tx.statement (cid, cname) lookupChildStmt)++-- | Read every child link of a parent @(parent_id, parent_name)@.+lookupChildrenOfParent :: (Store :> es) => Text -> Text -> Eff es [ChildRow]+lookupChildrenOfParent pid pname =+    runTransaction (Tx.statement (pid, pname) lookupChildrenOfParentStmt)++-- | The 'ChildStatus' of a child by @(child_id, child_name)@, if it exists.+childStatus :: (Store :> es) => Text -> Text -> Eff es (Maybe ChildStatus)+childStatus cid cname = fmap (^. #status) <$> lookupChild cid cname++{- | Count children currently @running@. Read-only. EP-44 may back a+@keiro.workflow.children.active@ gauge with this.+-}+countActiveChildren :: (Store :> es) => Eff es Int+countActiveChildren =+    runTransaction (Tx.statement () countActiveChildrenStmt)++{- | The @(child_id, child_name)@ of every @running@ child. The resume worker+unions this with 'Keiro.Workflow.findUnfinishedWorkflowIds' so a freshly+spawned child that has no @keiro_workflow_steps@ rows yet is still discovered+and driven. The tuple order matches 'findUnfinishedWorkflowIds' — @(id, name)@.+-}+findRunningChildIds :: (Store :> es) => Eff es [(Text, Text)]+findRunningChildIds =+    runTransaction (Tx.statement () findRunningChildIdsStmt)++registerChildStmt :: Statement (Text, Text, Text, Text, Text) ()+registerChildStmt =+    preparable+        """+        INSERT INTO keiro.keiro_workflow_children+          (child_id, child_name, parent_id, parent_name, await_step, status)+        VALUES ($1, $2, $3, $4, $5, 'running')+        ON CONFLICT (child_id, child_name) DO NOTHING+        """+        ( contrazip5+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++markChildResultStmt :: Statement (Text, Text, Value, UTCTime) Bool+markChildResultStmt =+    preparable+        """+        UPDATE keiro.keiro_workflow_children+        SET status = 'completed',+            result = $3,+            completed_at = $4,+            updated_at = now()+        WHERE child_id = $1+          AND child_name = $2+          AND status = 'running'+        """+        ( contrazip4+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.jsonb))+            (E.param (E.nonNullable E.timestamptz))+        )+        ((> 0) <$> D.rowsAffected)++markChildCancelledStmt :: Statement (Text, Text) Bool+markChildCancelledStmt =+    preparable+        """+        UPDATE keiro.keiro_workflow_children+        SET status = 'cancelled',+            updated_at = now()+        WHERE child_id = $1+          AND child_name = $2+          AND status = 'running'+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        ((> 0) <$> D.rowsAffected)++markChildFailedStmt :: Statement (Text, Text) Bool+markChildFailedStmt =+    preparable+        """+        UPDATE keiro.keiro_workflow_children+        SET status = 'failed',+            updated_at = now()+        WHERE child_id = $1+          AND child_name = $2+          AND status = 'running'+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        ((> 0) <$> D.rowsAffected)++lookupChildStmt :: Statement (Text, Text) (Maybe ChildRow)+lookupChildStmt =+    preparable+        """+        SELECT child_id, child_name, parent_id, parent_name, await_step,+          status, result, created_at, updated_at, completed_at+        FROM keiro.keiro_workflow_children+        WHERE child_id = $1+          AND child_name = $2+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        (D.rowMaybe childRowDecoder)++lookupChildrenOfParentStmt :: Statement (Text, Text) [ChildRow]+lookupChildrenOfParentStmt =+    preparable+        """+        SELECT child_id, child_name, parent_id, parent_name, await_step,+          status, result, created_at, updated_at, completed_at+        FROM keiro.keiro_workflow_children+        WHERE parent_id = $1+          AND parent_name = $2+        ORDER BY created_at, child_id+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        (D.rowList childRowDecoder)++countActiveChildrenStmt :: Statement () Int+countActiveChildrenStmt =+    preparable+        """+        SELECT count(*)+        FROM keiro.keiro_workflow_children+        WHERE status = 'running'+        """+        E.noParams+        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++findRunningChildIdsStmt :: Statement () [(Text, Text)]+findRunningChildIdsStmt =+    preparable+        """+        SELECT child_id, child_name+        FROM keiro.keiro_workflow_children+        WHERE status = 'running'+        """+        E.noParams+        (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))++childRowDecoder :: D.Row ChildRow+childRowDecoder =+    ChildRow+        <$> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> (statusFromText <$> D.column (D.nonNullable D.text))+        <*> D.column (D.nullable D.jsonb)+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nullable D.timestamptz)++statusToText :: ChildStatus -> Text+statusToText = \case+    Running -> "running"+    ChildCompleted -> "completed"+    ChildCancelled -> "cancelled"+    ChildFailed -> "failed"++statusFromText :: Text -> ChildStatus+statusFromText = \case+    "running" -> Running+    "completed" -> ChildCompleted+    "cancelled" -> ChildCancelled+    "failed" -> ChildFailed+    _ -> ChildCancelled
+ src/Keiro/Workflow/Gc.hs view
@@ -0,0 +1,193 @@+{- | Optional garbage collection for terminal workflow instances.++The hot-path schema modules keep lifecycle writes and lookup statements. This+module owns only cleanup statements used by an operator-scheduled GC pass.+Eligibility is based on the derived @keiro_workflows@ row: terminal instances+older than the retention cutoff are deleted, except completed children whose+parent is still non-terminal and may still attach to their result.+-}+module Keiro.Workflow.Gc (+    WorkflowGcPolicy (..),+    WorkflowGcSummary (..),+    gcWorkflowsOnce,+    runWorkflowGcWorker,+)+where++import Contravariant.Extras (contrazip2, contrazip3, contrazip4)+import Control.Concurrent (threadDelay)+import Control.Monad (forever)+import Data.Int (Int32)+import Data.Time (NominalDiffTime, addUTCTime)+import Effectful (Eff, IOE, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Prelude+import Keiro.Workflow.Schema (currentGeneration)+import Keiro.Workflow.Types (WorkflowId (..), WorkflowName (..), workflowGenerationStreamName)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Lifecycle (hardDeleteStream)+import Kiroku.Store.Read (lookupStreamId)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (StreamId (..))+import "hasql-transaction" Hasql.Transaction qualified as Tx++data WorkflowGcPolicy = WorkflowGcPolicy+    { retention :: !NominalDiffTime+    , batchSize :: !Int+    }+    deriving stock (Generic, Eq, Show)++data WorkflowGcSummary = WorkflowGcSummary+    { scanned :: !Int+    , deleted :: !Int+    }+    deriving stock (Generic, Eq, Show)++gcWorkflowsOnce :: (Store :> es) => UTCTime -> WorkflowGcPolicy -> Eff es WorkflowGcSummary+gcWorkflowsOnce now policy = do+    let cutoff = addUTCTime (negate (policy ^. #retention)) now+        limit = max 0 (policy ^. #batchSize)+    eligible <- runTransaction (Tx.statement (cutoff, fromIntegral limit :: Int32) eligibleWorkflowsStmt)+    deletedCount <- length <$> traverse deleteWorkflow eligible+    pure WorkflowGcSummary{scanned = length eligible, deleted = deletedCount}++runWorkflowGcWorker :: (IOE :> es, Store :> es) => WorkflowGcPolicy -> Int -> Eff es ()+runWorkflowGcWorker policy pollMicros =+    forever $ do+        now <- liftIO getCurrentTime+        void (gcWorkflowsOnce now policy)+        liftIO (threadDelay pollMicros)++deleteWorkflow :: (Store :> es) => (Text, Text) -> Eff es ()+deleteWorkflow (widText, nameText) = do+    let name = WorkflowName nameText+        wid = WorkflowId widText+    gen <- currentGeneration name wid+    for_ [0 .. gen] $ \generation -> do+        let streamName = workflowGenerationStreamName name wid generation+        mStreamId <- lookupStreamId streamName+        for_ mStreamId $ \(StreamId sid) ->+            runTransaction (Tx.statement sid deleteSnapshotStmt)+        void (hardDeleteStream streamName)+    runTransaction $ do+        Tx.statement (widText, nameText) deleteStepsStmt+        Tx.statement (nameText, widText) deleteAwakeablesStmt+        Tx.statement (widText, nameText, widText, nameText) deleteChildrenStmt+        -- Keep this literal in sync with Keiro.Workflow.Sleep.workflowSleepKind.+        Tx.statement (widText, nameText, workflowSleepKindLiteral) deleteTerminalSleepTimersStmt+        Tx.statement (widText, nameText) deleteWorkflowStmt++workflowSleepKindLiteral :: Text+workflowSleepKindLiteral = "keiro.workflow.sleep"++eligibleWorkflowsStmt :: Statement (UTCTime, Int32) [(Text, Text)]+eligibleWorkflowsStmt =+    preparable+        """+        SELECT w.workflow_id, w.workflow_name+        FROM keiro.keiro_workflows w+        WHERE w.status IN ('completed', 'cancelled', 'failed')+          AND w.completed_at IS NOT NULL+          AND w.completed_at <= $1+          AND NOT EXISTS (+            SELECT 1+            FROM keiro.keiro_workflow_children c+            JOIN keiro.keiro_workflows p+              ON p.workflow_id = c.parent_id+             AND p.workflow_name = c.parent_name+            WHERE c.child_id = w.workflow_id+              AND c.child_name = w.workflow_name+              AND p.status NOT IN ('completed', 'cancelled', 'failed')+          )+        ORDER BY w.completed_at+        LIMIT $2+        """+        ( contrazip2+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.int4))+        )+        (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))++deleteSnapshotStmt :: Statement Int64 ()+deleteSnapshotStmt =+    preparable+        """+        DELETE FROM keiro.keiro_snapshots+        WHERE stream_id = $1+        """+        (E.param (E.nonNullable E.int8))+        D.noResult++deleteStepsStmt :: Statement (Text, Text) ()+deleteStepsStmt =+    preparable+        """+        DELETE FROM keiro.keiro_workflow_steps+        WHERE workflow_id = $1 AND workflow_name = $2+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++deleteAwakeablesStmt :: Statement (Text, Text) ()+deleteAwakeablesStmt =+    preparable+        """+        DELETE FROM keiro.keiro_awakeables+        WHERE owner_workflow_name = $1 AND owner_workflow_id = $2+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++deleteChildrenStmt :: Statement (Text, Text, Text, Text) ()+deleteChildrenStmt =+    preparable+        """+        DELETE FROM keiro.keiro_workflow_children+        WHERE (parent_id = $1 AND parent_name = $2)+           OR (child_id = $3 AND child_name = $4)+        """+        ( contrazip4+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++deleteTerminalSleepTimersStmt :: Statement (Text, Text, Text) ()+deleteTerminalSleepTimersStmt =+    preparable+        """+        DELETE FROM keiro.keiro_timers+        WHERE correlation_id = $1+          AND process_manager_name = $2+          AND payload->>'kind' = $3+          AND status IN ('fired', 'cancelled', 'dead')+        """+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++deleteWorkflowStmt :: Statement (Text, Text) ()+deleteWorkflowStmt =+    preparable+        """+        DELETE FROM keiro.keiro_workflows+        WHERE workflow_id = $1 AND workflow_name = $2+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult
+ src/Keiro/Workflow/Instance.hs view
@@ -0,0 +1,278 @@+{- | Durable workflow instance summaries.++The journal stream and @keiro_workflow_steps@ index remain the source of truth+for replay. This module maintains one @keiro_workflows@ row per logical+workflow instance so the resume worker can track lifecycle, attempts, and+leases without scanning journal history.+-}+module Keiro.Workflow.Instance (+    WorkflowStatus (..),+    WorkflowInstanceRow (..),+    statusToText,+    statusFromText,+    upsertInstanceTx,+    markInstanceSuspended,+    lookupInstance,+    claimInstance,+    releaseInstance,+    recordCrashTx,+    resetInstanceAttempts,+)+where++import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5)+import Data.Int (Int32)+import Data.Time (NominalDiffTime, addUTCTime)+import Effectful (Eff, IOE, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Prelude+import Keiro.Workflow.Schema (currentGeneration)+import Keiro.Workflow.Types (WorkflowId (..), WorkflowName (..))+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import "hasql-transaction" Hasql.Transaction qualified as Tx++data WorkflowStatus+    = WfRunning+    | WfSuspended+    | WfCompleted+    | WfCancelled+    | WfFailed+    deriving stock (Generic, Eq, Show)++data WorkflowInstanceRow = WorkflowInstanceRow+    { workflowId :: !Text+    , workflowName :: !Text+    , generation :: !Int32+    , status :: !WorkflowStatus+    , attempts :: !Int32+    , lastError :: !(Maybe Text)+    , nextAttemptAt :: !(Maybe UTCTime)+    , leasedBy :: !(Maybe Text)+    , leaseExpiresAt :: !(Maybe UTCTime)+    , createdAt :: !UTCTime+    , updatedAt :: !UTCTime+    , completedAt :: !(Maybe UTCTime)+    }+    deriving stock (Generic, Eq, Show)++upsertInstanceTx :: Text -> Text -> Int32 -> WorkflowStatus -> Maybe Text -> Tx.Transaction ()+upsertInstanceTx wid name gen status mLastError =+    Tx.statement (wid, name, gen, statusToText status, mLastError) upsertInstanceStmt++markInstanceSuspended :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es ()+markInstanceSuspended name@(WorkflowName nameText) wid@(WorkflowId widText) = do+    gen <- currentGeneration name wid+    runTransaction $+        upsertInstanceTx widText nameText (fromIntegral gen) WfSuspended Nothing++lookupInstance :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es (Maybe WorkflowInstanceRow)+lookupInstance (WorkflowName name) (WorkflowId wid) =+    runTransaction (Tx.statement (wid, name) lookupInstanceStmt)++claimInstance :: (IOE :> es, Store :> es) => Text -> NominalDiffTime -> WorkflowName -> WorkflowId -> Eff es Bool+claimInstance owner ttl name@(WorkflowName nameText) wid@(WorkflowId widText) = do+    now <- liftIO getCurrentTime+    gen <- currentGeneration name wid+    runTransaction $ do+        Tx.statement (widText, nameText, fromIntegral gen :: Int32) ensureInstanceStmt+        fromMaybe False+            <$> Tx.statement+                (widText, nameText, owner, now, addUTCTime ttl now)+                claimInstanceStmt++releaseInstance :: (Store :> es) => Text -> Bool -> WorkflowName -> WorkflowId -> Eff es ()+releaseInstance owner progressed (WorkflowName name) (WorkflowId wid) =+    runTransaction $+        Tx.statement (wid, name, owner, progressed) releaseInstanceStmt++recordCrashTx :: Text -> Text -> Text -> Tx.Transaction Int32+recordCrashTx wid name err =+    Tx.statement (wid, name, err) recordCrashStmt++resetInstanceAttempts :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es ()+resetInstanceAttempts (WorkflowName name) (WorkflowId wid) =+    runTransaction (Tx.statement (wid, name) resetInstanceAttemptsStmt)++statusToText :: WorkflowStatus -> Text+statusToText = \case+    WfRunning -> "running"+    WfSuspended -> "suspended"+    WfCompleted -> "completed"+    WfCancelled -> "cancelled"+    WfFailed -> "failed"++statusFromText :: Text -> WorkflowStatus+statusFromText = \case+    "running" -> WfRunning+    "suspended" -> WfSuspended+    "completed" -> WfCompleted+    "cancelled" -> WfCancelled+    "failed" -> WfFailed+    _ -> WfFailed++upsertInstanceStmt :: Statement (Text, Text, Int32, Text, Maybe Text) ()+upsertInstanceStmt =+    preparable+        """+        INSERT INTO keiro.keiro_workflows+          (workflow_id, workflow_name, generation, status, last_error, completed_at)+        VALUES ($1, $2, $3, $4, $5,+                CASE WHEN $4 IN ('completed', 'cancelled', 'failed') THEN now() ELSE NULL END)+        ON CONFLICT (workflow_id, workflow_name) DO UPDATE+        SET generation = GREATEST(keiro_workflows.generation, EXCLUDED.generation),+            status = EXCLUDED.status,+            last_error = EXCLUDED.last_error,+            updated_at = now(),+            completed_at = CASE+              WHEN EXCLUDED.status IN ('completed', 'cancelled', 'failed')+                THEN COALESCE(keiro_workflows.completed_at, now())+              ELSE keiro_workflows.completed_at+            END+        WHERE keiro_workflows.status NOT IN ('completed', 'cancelled', 'failed')+        """+        ( contrazip5+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+            (E.param (E.nonNullable E.text))+            (E.param (E.nullable E.text))+        )+        D.noResult++lookupInstanceStmt :: Statement (Text, Text) (Maybe WorkflowInstanceRow)+lookupInstanceStmt =+    preparable+        """+        SELECT workflow_id, workflow_name, generation, status, attempts,+               last_error, next_attempt_at, leased_by, lease_expires_at,+               created_at, updated_at, completed_at+        FROM keiro.keiro_workflows+        WHERE workflow_id = $1 AND workflow_name = $2+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        (D.rowMaybe instanceRowDecoder)++ensureInstanceStmt :: Statement (Text, Text, Int32) ()+ensureInstanceStmt =+    preparable+        """+        INSERT INTO keiro.keiro_workflows+          (workflow_id, workflow_name, generation, status)+        VALUES ($1, $2, $3, 'running')+        ON CONFLICT (workflow_id, workflow_name) DO NOTHING+        """+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+        )+        D.noResult++claimInstanceStmt :: Statement (Text, Text, Text, UTCTime, UTCTime) (Maybe Bool)+claimInstanceStmt =+    preparable+        """+        UPDATE keiro.keiro_workflows+        SET leased_by = $3,+            lease_expires_at = $5,+            updated_at = $4+        WHERE workflow_id = $1+          AND workflow_name = $2+          AND status IN ('running', 'suspended')+          AND (lease_expires_at IS NULL OR lease_expires_at < $4)+          AND (next_attempt_at IS NULL OR next_attempt_at <= $4)+        RETURNING TRUE+        """+        ( contrazip5+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.timestamptz))+        )+        (D.rowMaybe (D.column (D.nonNullable D.bool)))++releaseInstanceStmt :: Statement (Text, Text, Text, Bool) ()+releaseInstanceStmt =+    preparable+        """+        UPDATE keiro.keiro_workflows+        SET leased_by = NULL,+            lease_expires_at = NULL,+            attempts = CASE WHEN $4 THEN 0 ELSE attempts END,+            last_error = CASE WHEN $4 THEN NULL ELSE last_error END,+            next_attempt_at = CASE WHEN $4 THEN NULL ELSE next_attempt_at END,+            updated_at = now()+        WHERE workflow_id = $1+          AND workflow_name = $2+          AND leased_by = $3+        """+        ( contrazip4+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.bool))+        )+        D.noResult++recordCrashStmt :: Statement (Text, Text, Text) Int32+recordCrashStmt =+    preparable+        """+        UPDATE keiro.keiro_workflows+        SET attempts = attempts + 1,+            last_error = $3,+            next_attempt_at = now() + (LEAST(power(2, attempts + 1), 64) * interval '1 second'),+            updated_at = now()+        WHERE workflow_id = $1+          AND workflow_name = $2+          AND status NOT IN ('completed', 'cancelled', 'failed')+        RETURNING attempts+        """+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        (D.singleRow (D.column (D.nonNullable D.int4)))++resetInstanceAttemptsStmt :: Statement (Text, Text) ()+resetInstanceAttemptsStmt =+    preparable+        """+        UPDATE keiro.keiro_workflows+        SET attempts = 0,+            last_error = NULL,+            next_attempt_at = NULL,+            updated_at = now()+        WHERE workflow_id = $1+          AND workflow_name = $2+          AND status NOT IN ('completed', 'cancelled', 'failed')+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++instanceRowDecoder :: D.Row WorkflowInstanceRow+instanceRowDecoder =+    WorkflowInstanceRow+        <$> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.text)+        <*> D.column (D.nonNullable D.int4)+        <*> (statusFromText <$> D.column (D.nonNullable D.text))+        <*> D.column (D.nonNullable D.int4)+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nullable D.timestamptz)+        <*> D.column (D.nullable D.text)+        <*> D.column (D.nullable D.timestamptz)+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nonNullable D.timestamptz)+        <*> D.column (D.nullable D.timestamptz)
+ src/Keiro/Workflow/Resume.hs view
@@ -0,0 +1,542 @@+{- | The workflow resume / crash-recovery worker.++EP-38 makes a workflow replay-on-re-invocation: call 'runWorkflow' (or+'runWorkflowWith') with the same id and each already-journaled step+short-circuits, so only the un-journaled tail runs. But nothing in the runtime+/notices/ that a workflow exists, has steps, and lacks a terminal+'WorkflowCompleted' — i.e. that it crashed mid-run, or is parked on a+@sleep@\/@awakeable@ whose wake source has since resolved. This module is what+notices: a background worker that, on each pass, asks the database "which+workflows have steps but no completion?" ('findUnfinishedWorkflowIds') and+re-invokes each so it proceeds.++== Why a registry++A workflow's body is application Haskell code — only its /journal/ (the+recorded step results) lives in the database. To re-invoke a workflow the+worker must turn its stored name into a function+@'WorkflowId' -> 'Eff' ('Workflow' : es) a@. There is no way to materialize a+closure from a string, so the application supplies a 'WorkflowRegistry' mapping+each 'WorkflowName' to its 'WorkflowDef'. This is the resume-worker analogue of+the caller-supplied @fire@ action 'Keiro.Timer.runTimerWorker' takes: the+worker owns the discovery loop and the database access; the application owns+the domain behaviour.++== Contract recap for downstream plans (the v2 MasterPlan)++* __'WorkflowRegistry' \/ 'WorkflowDef'__ — the application-supplied+  name → definition map. EP-43 (child workflows) relies on this worker to wake+  a /parent/ once a child finishes: the child's completion journals the+  parent's awaited @child:\<id\>@ 'StepRecorded', and the next resume pass+  re-invokes the parent (registered here) so it proceeds past its child-wait.+* __'ResumeSummary'__ ('discovered', 'resumed', 'completed', 'stillSuspended',+  'unknownName', 'failed', 'transientErrors', 'leaseSkipped') — the per-pass+  observability record. EP-44 reads it for the @keiro.workflow.resumed@+  instrument (and may thread a @Maybe KeiroMetrics@ into+  'WorkflowResumeOptions' \/ 'resumeWorkflowsOnce' following the+  no-op-under-@Nothing@ idiom the timer and outbox workers use).+* __'resumeWorkflowsOnce'__ is the single-pass, testable unit (like+  'Keiro.Outbox.publishClaimedOutbox'); __'runWorkflowResumeWorker'__ \/+  __'runWorkflowResumeWorkerWith'__ are the poll-loop drivers (like the+  @runTimerWorker@ pair). Re-invocation goes through EP-41's 'runWorkflowWith'+  carrying 'runOptions', so a resumed run honours the same snapshot/telemetry+  options as its first run.++Discovery is the 'findUnfinishedWorkflowIds' index query plus the child-row+seed query. Each candidate is claimed through an expiry-based row lease in+@keiro_workflows@ before it is advanced. A live foreign lease skips only that+instance and increments 'leaseSkipped'; a dead worker's lease becomes claimable+after 'leaseTtl'. The lease prevents duplicate steady-state work, while the+journal append path still serializes same-step writers so lease expiry races+converge on one recorded result. There is __no kiroku @wf:@ prefix+subscription__ and no session-level advisory lock.+-}+module Keiro.Workflow.Resume (+    -- * Registry+    WorkflowDef (..),+    WorkflowRegistry,++    -- * Options+    WorkflowResumeOptions (..),+    ResumeLogEvent (..),+    defaultWorkflowResumeOptions,++    -- * Per-pass summary+    ResumeSummary (..),+    emptyResumeSummary,++    -- * Running (fixed-poll baseline)+    resumeWorkflowsOnce,+    runWorkflowResumeWorker,+    runWorkflowResumeWorkerWith,++    -- * Running (push-aware, EP-50)+    runPollLoopWith,+    runWorkflowResumeWorkerPush,+)+where++import Control.Concurrent (threadDelay)+import Control.Exception qualified as Exception+import Control.Monad (foldM, forever)+import Data.Aeson qualified as Aeson+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Time (NominalDiffTime)+import Data.UUID qualified as UUID+import Data.UUID.V4 qualified as UUIDv4+import Effectful (Eff, IOE, (:>))+import Effectful.Error.Static (Error)+import Effectful.Error.Static qualified as Error+import Effectful.Exception (catchSync, finally, throwIO)+import Keiro.Prelude+import Keiro.Telemetry (+    recordWorkflowAwakeablesPending,+    recordWorkflowFailed,+    recordWorkflowLeaseSkipped,+    recordWorkflowResumeErrors,+    recordWorkflowResumed,+ )+import Keiro.Wake (WakeSignal (..), wakeSignalFromStore)+import Keiro.Workflow (+    JournalAppendOutcome (..),+    Workflow,+    WorkflowError (..),+    WorkflowId (..),+    WorkflowJournalEvent (..),+    WorkflowName (..),+    WorkflowOutcome (..),+    WorkflowRunOptions,+    appendJournalEntry,+    currentGeneration,+    defaultWorkflowRunOptions,+    findUnfinishedWorkflowIds,+    prepareJournalAppend,+    runWorkflowWith,+ )+import Keiro.Workflow.Awakeable.Schema (countPendingAwakeables)+import Keiro.Workflow.Child (runChildWorkflow)+import Keiro.Workflow.Child.Schema (ChildRow, findRunningChildIds, lookupChild, markChildFailedTx)+import Keiro.Workflow.Instance (claimInstance, recordCrashTx, releaseInstance)+import Kiroku.Store.Connection (KirokuStore)+import Kiroku.Store.Effect (Store, runStoreIO)+import Kiroku.Store.Error (StoreError)+import Kiroku.Store.Transaction (runTransaction)+import System.IO (hPutStrLn, stderr)+import "hasql-transaction" Hasql.Transaction qualified as Tx++-- ---------------------------------------------------------------------------+-- Registry+-- ---------------------------------------------------------------------------++{- | How to re-build a workflow's body from its id, for one workflow name.++The result type @a@ is existential: the worker discards it (it cares only+whether a re-invocation reached 'Completed' or 'Suspended'), so one registry+can hold workflows of different return types.+-}+data WorkflowDef es = forall a. (Aeson.ToJSON a) => WorkflowDef+    { runDef :: WorkflowId -> Eff (Workflow : es) a+    }++{- | The application-supplied map from workflow name to its definition. The+worker looks up each discovered workflow's name here; an absent name is+skipped and counted as 'unknownName' (a deploy that dropped a workflow while+instances were still in flight — surfaced, not silently lost).+-}+type WorkflowRegistry es = Map WorkflowName (WorkflowDef es)++-- ---------------------------------------------------------------------------+-- Options+-- ---------------------------------------------------------------------------++{- | Options for the resume worker. Mirrors the @TimerWorkerOptions@ shape:+'runOptions' threads EP-41's snapshot/telemetry options into 'runWorkflowWith',+and 'pollInterval' is the loop driver's gap between passes.+-}+data WorkflowResumeOptions = WorkflowResumeOptions+    { runOptions :: !WorkflowRunOptions+    {- ^ Threaded into 'runWorkflowWith' (or 'runChildWorkflow' for a child) so a+    resumed run honours the same snapshot (EP-41) and telemetry (EP-44)+    options as its first run.+    -}+    , pollInterval :: !Int+    -- ^ Microseconds the loop driver sleeps between passes.+    , maxAttempts :: !Int+    -- ^ Workflow-level synchronous exceptions before terminal failure.+    , leaseTtl :: !NominalDiffTime+    -- ^ How long a claimed workflow instance stays leased if the worker dies mid-advance.+    , logEvent :: !(ResumeLogEvent -> IO ())+    -- ^ Per-worker logging hook. Defaults to a compact stderr renderer.+    }+    deriving stock (Generic)++data ResumeLogEvent+    = ResumeUnknownName !Text !Text+    | ResumeTransientError !Text !Text !Text+    | ResumeWorkflowCrashed !Text !Text !Int !Int !Text+    | ResumeWorkflowMarkedFailed !Text !Text !Text+    | ResumePassFailed !Text+    deriving stock (Eq, Show)++-- | Defaults: EP-41's 'defaultWorkflowRunOptions', a 1-second poll, and a 60-second lease.+defaultWorkflowResumeOptions :: WorkflowResumeOptions+defaultWorkflowResumeOptions =+    WorkflowResumeOptions+        { runOptions = defaultWorkflowRunOptions+        , pollInterval = 1_000_000+        , maxAttempts = 5+        , leaseTtl = 60+        , logEvent = defaultResumeLogEvent+        }++defaultResumeLogEvent :: ResumeLogEvent -> IO ()+defaultResumeLogEvent event =+    hPutStrLn stderr $ case event of+        ResumeUnknownName name wid ->+            "keiro resume worker: no registry entry for workflow "+                <> Text.unpack name+                <> " (id "+                <> Text.unpack wid+                <> "); skipping"+        ResumeTransientError name wid err ->+            "keiro resume worker: transient store error while advancing "+                <> Text.unpack name+                <> " (id "+                <> Text.unpack wid+                <> "): "+                <> Text.unpack err+        ResumeWorkflowCrashed name wid attempt maxAttempt err ->+            "keiro resume worker: workflow "+                <> Text.unpack name+                <> " (id "+                <> Text.unpack wid+                <> ") crashed on attempt "+                <> show attempt+                <> "/"+                <> show maxAttempt+                <> ": "+                <> Text.unpack err+        ResumeWorkflowMarkedFailed name wid err ->+            "keiro resume worker: marked workflow "+                <> Text.unpack name+                <> " (id "+                <> Text.unpack wid+                <> ") failed: "+                <> Text.unpack err+        ResumePassFailed err ->+            "keiro resume worker: pass failed: " <> Text.unpack err++-- ---------------------------------------------------------------------------+-- Per-pass summary+-- ---------------------------------------------------------------------------++{- | What one 'resumeWorkflowsOnce' pass did. EP-44 instruments this for+@keiro.workflow.resumed@.+-}+data ResumeSummary = ResumeSummary+    { discovered :: !Int+    -- ^ Unfinished workflows 'findUnfinishedWorkflowIds' returned this pass.+    , resumed :: !Int+    -- ^ Workflows re-invoked (found in the registry and run).+    , completed :: !Int+    -- ^ Re-invocations that reached 'Completed' this pass.+    , stillSuspended :: !Int+    -- ^ Re-invocations that returned 'Suspended' (wake source not yet resolved).+    , unknownName :: !Int+    -- ^ Discovered workflows whose name was absent from the registry (skipped + logged).+    , failed :: !Int+    -- ^ Workflows marked terminally failed this pass.+    , transientErrors :: !Int+    -- ^ Store errors observed while advancing individual workflows.+    , leaseSkipped :: !Int+    -- ^ Candidates skipped because another worker holds a live lease.+    }+    deriving stock (Generic, Eq, Show)++-- | A zeroed 'ResumeSummary'.+emptyResumeSummary :: ResumeSummary+emptyResumeSummary = ResumeSummary 0 0 0 0 0 0 0 0++-- ---------------------------------------------------------------------------+-- Running+-- ---------------------------------------------------------------------------++{- | Run one discover-and-reinvoke pass.++Discovers every unfinished workflow via 'findUnfinishedWorkflowIds', and for+each looks its name up in @registry@:++* __present__ — re-invoke through 'runWorkflowWith' (the journal pre-load+  short-circuits already-journaled steps, so only the un-journaled tail runs);+  the outcome bumps 'completed' or 'stillSuspended'.+* __absent__ — log a warning and bump 'unknownName' (a workflow whose code was+  removed while instances were in flight must be visible, not silently lost).++Idempotent: a completed workflow has a @__workflow_completed__@ index row and+so drops out of discovery; re-invoking an unfinished one twice converges to the+same journal (EP-38 deterministic ids + step short-circuit).+-}+resumeWorkflowsOnce ::+    forall es.+    (IOE :> es, Store :> es, Error StoreError :> es) =>+    WorkflowResumeOptions ->+    WorkflowRegistry es ->+    Eff es ResumeSummary+resumeWorkflowsOnce opts registry = do+    -- EP-44: sample the @keiro.workflow.awakeables.pending@ gauge once per pass,+    -- on the same Store the discovery query uses. The metrics handle rides on the+    -- run options (EP-44 threads telemetry through 'WorkflowRunOptions'), so it is+    -- already forwarded into 'runWorkflowWith' for every re-invocation.+    pending <- countPendingAwakeables+    recordWorkflowAwakeablesPending mMetrics (fromIntegral pending)+    -- Discovery unions two sources: workflows with steps but no terminal marker+    -- ('findUnfinishedWorkflowIds') and freshly-spawned children that have no+    -- step rows yet ('findRunningChildIds', EP-43) — so a zero-step child is+    -- still driven. The dedup collapses a child that appears in both.+    now <- liftIO getCurrentTime+    unfinished <- findUnfinishedWorkflowIds now+    runningChildren <- findRunningChildIds+    let pairs = dedupeFirstSeen (unfinished <> runningChildren)+        seed = emptyResumeSummary{discovered = length pairs}+    owner <- UUID.toText <$> liftIO UUIDv4.nextRandom+    foldM (advance owner) seed pairs+  where+    mMetrics = runOptions opts ^. #metrics+    dedupeFirstSeen :: [(Text, Text)] -> [(Text, Text)]+    dedupeFirstSeen = go Set.empty+      where+        go !_ [] = []+        go !seen (pair : rest)+            | pair `Set.member` seen = go seen rest+            | otherwise = pair : go (Set.insert pair seen) rest++    advance :: Text -> ResumeSummary -> (Text, Text) -> Eff es ResumeSummary+    advance owner acc (widText, wnameText) =+        case Map.lookup (WorkflowName wnameText) registry of+            Nothing -> do+                liftIO $ logEvent opts (ResumeUnknownName wnameText widText)+                pure acc{unknownName = unknownName acc + 1}+            Just (WorkflowDef runDef) -> do+                let wid = WorkflowId widText+                    name = WorkflowName wnameText+                claimed <- claimInstance owner (leaseTtl opts) name wid+                if not claimed+                    then do+                        recordWorkflowLeaseSkipped mMetrics 1+                        pure acc{leaseSkipped = leaseSkipped acc + 1}+                    else do+                        progressedRef <- liftIO (newIORef False)+                        ( do+                                attempt <-+                                    Error.catchError+                                        @StoreError+                                        (AdvOk <$> driveInstance name wid runDef)+                                        (\_ e -> pure (AdvTransient e))+                                        `catchSync` (pure . AdvCrashed)+                                recordWorkflowResumed mMetrics 1+                                (acc', progressed) <- handleAttempt acc name wid attempt+                                liftIO (writeIORef progressedRef progressed)+                                pure acc'+                            )+                            `finally` do+                                progressed <- liftIO (readIORef progressedRef)+                                releaseInstance owner progressed name wid+    driveInstance :: (Aeson.ToJSON a) => WorkflowName -> WorkflowId -> (WorkflowId -> Eff (Workflow : es) a) -> Eff es (WorkflowOutcome a)+    driveInstance name@(WorkflowName wnameText) wid@(WorkflowId widText) runDef = do+        mChild <- lookupChild widText wnameText+        case mChild of+            Just _ -> runChildWorkflow (runOptions opts) name wid (runDef wid)+            Nothing -> runWorkflowWith (runOptions opts) name wid (runDef wid)+    handleAttempt :: ResumeSummary -> WorkflowName -> WorkflowId -> AdvanceResult a -> Eff es (ResumeSummary, Bool)+    handleAttempt acc name@(WorkflowName wnameText) wid@(WorkflowId widText) = \case+        AdvOk outcome -> do+            pure (bumpForOutcome outcome acc, True)+        AdvTransient err -> do+            let rendered = Text.pack (show err)+            liftIO $ logEvent opts (ResumeTransientError wnameText widText rendered)+            recordWorkflowResumeErrors mMetrics 1+            pure (acc{resumed = resumed acc + 1, transientErrors = transientErrors acc + 1}, False)+        AdvCrashed err -> do+            let rendered = Text.pack (show err)+            attempt <- runTransaction (recordCrashTx widText wnameText rendered)+            liftIO $ logEvent opts (ResumeWorkflowCrashed wnameText widText (fromIntegral attempt) (maxAttempts opts) rendered)+            if attempt >= fromIntegral (maxAttempts opts :: Int)+                then do+                    now <- liftIO getCurrentTime+                    mChild <- lookupChild widText wnameText+                    case mChild of+                        Nothing ->+                            appendJournalEntry name wid (WorkflowFailed rendered now)+                        Just childRow ->+                            appendFailedChildAndWakeParent name wid rendered now childRow+                    liftIO $ logEvent opts (ResumeWorkflowMarkedFailed wnameText widText rendered)+                    recordWorkflowFailed mMetrics 1+                    pure (acc{resumed = resumed acc + 1, failed = failed acc + 1}, False)+                else pure (acc{resumed = resumed acc + 1}, False)++data AdvanceResult a+    = AdvOk !(WorkflowOutcome a)+    | AdvTransient !StoreError+    | AdvCrashed !Exception.SomeException++appendFailedChildAndWakeParent ::+    (IOE :> es, Store :> es) =>+    WorkflowName ->+    WorkflowId ->+    Text ->+    UTCTime ->+    ChildRow ->+    Eff es ()+appendFailedChildAndWakeParent childNm childWid reason now childRow = do+    childGen <- currentGeneration childNm childWid+    let parentNm = WorkflowName (childRow ^. #parentName)+        parentWid = WorkflowId (childRow ^. #parentId)+    parentGen <- currentGeneration parentNm parentWid+    childFailTx <- prepareJournalAppend childNm childWid childGen (WorkflowFailed reason now)+    parentWakeTx <-+        prepareJournalAppend+            parentNm+            parentWid+            parentGen+            StepRecorded+                { stepName = childRow ^. #awaitStep+                , result = Aeson.object ["failed" Aeson..= reason]+                , recordedAt = now+                }+    (childOutcome, parentOutcome) <-+        runTransaction $ do+            childOutcome <- childFailTx+            _transitioned <- markChildFailedTx (unWorkflowId childWid) (unWorkflowName childNm)+            parentOutcome <- parentWakeTx+            condemnOnAppendConflict childOutcome+            condemnOnAppendConflict parentOutcome+            pure (childOutcome, parentOutcome)+    throwOnAppendConflict childOutcome+    throwOnAppendConflict parentOutcome++condemnOnAppendConflict :: JournalAppendOutcome -> Tx.Transaction ()+condemnOnAppendConflict = \case+    JournalAppendConflict{} -> Tx.condemn+    _ -> pure ()++throwOnAppendConflict :: JournalAppendOutcome -> Eff es ()+throwOnAppendConflict = \case+    JournalAppendConflict err -> throwIO (WorkflowJournalAppendError (Text.pack (show err)))+    _ -> pure ()++{- | Fold one re-invocation's outcome into the running summary. The existential+result @a@ is discarded here, so it never escapes the registry.+-}+bumpForOutcome :: WorkflowOutcome a -> ResumeSummary -> ResumeSummary+bumpForOutcome outcome acc = case outcome of+    Completed _ -> acc{resumed = resumed acc + 1, completed = completed acc + 1}+    Suspended -> acc{resumed = resumed acc + 1, stillSuspended = stillSuspended acc + 1}+    -- A workflow cancelled between discovery and re-invocation short-circuits to+    -- 'Cancelled' (EP-43); count it as re-invoked but neither completed nor+    -- suspended. (A cancelled workflow also drops out of discovery, so this is a+    -- rare race, not the steady state.)+    Cancelled -> acc{resumed = resumed acc + 1}+    Failed -> acc{resumed = resumed acc + 1}+    -- A workflow that rotated via continueAsNew (EP-48) returns 'ContinuedAsNew':+    -- it is re-invoked but neither completed nor suspended this pass. Its new+    -- generation has no terminal marker, so 'findUnfinishedWorkflowIds' still+    -- reports it and the next pass drives the rotated generation forward.+    ContinuedAsNew -> acc{resumed = resumed acc + 1}++{- | Poll-and-resume loop: run 'resumeWorkflowsOnce' on the configured+'pollInterval' forever. Mirrors how an application schedules+'Keiro.Outbox.publishClaimedOutbox' \/ @runTimerWorker@ per tick; the+single-pass 'resumeWorkflowsOnce' remains the testable unit.+-}+runWorkflowResumeWorkerWith ::+    (IOE :> es, Store :> es, Error StoreError :> es) =>+    WorkflowResumeOptions ->+    WorkflowRegistry es ->+    Eff es ()+runWorkflowResumeWorkerWith opts registry = forever $ do+    _summary <-+        (Just <$> resumeWorkflowsOnce opts registry)+            `Error.catchError` (\_ (e :: StoreError) -> logPass (Text.pack (show e)))+            `catchSync` (logPass . Text.pack . show)+    liftIO (threadDelay (pollInterval opts))+  where+    logPass msg = do+        liftIO $ logEvent opts (ResumePassFailed msg)+        pure Nothing++-- | 'runWorkflowResumeWorkerWith' with 'defaultWorkflowResumeOptions'.+runWorkflowResumeWorker ::+    (IOE :> es, Store :> es, Error StoreError :> es) =>+    WorkflowRegistry es ->+    Eff es ()+runWorkflowResumeWorker = runWorkflowResumeWorkerWith defaultWorkflowResumeOptions++-- ---------------------------------------------------------------------------+-- Push-aware loop (EP-50)+-- ---------------------------------------------------------------------------++{- | Generic push-aware poll loop: run one pass, then block on the 'WakeSignal'+with the given fallback timeout (microseconds), forever. The pass is the durable+unit; the wake only shortens the gap between passes. Both wake reasons (a+notification or the fallback elapsing) mean "run another pass", so the returned+'Keiro.Wake.WakeReason' is ignored for control flow. A missed @NOTIFY@ costs at+most one fallback interval of latency, never lost work — correctness rests on the+pass (e.g. 'resumeWorkflowsOnce'), which is idempotent, not on a notification+arriving. The same pattern applies mechanically to 'Keiro.Timer.runTimerWorker'+and 'Keiro.Outbox.publishClaimedOutbox' (documented, not implemented here; the+resume worker carries the acceptance via parent/child cascades).+-}+runPollLoopWith ::+    -- | the wake signal to block on between passes+    WakeSignal ->+    -- | fallback timeout in microseconds (the maximum gap when no notification arrives)+    Int ->+    -- | one pass, already wrapped to run in 'IO'+    IO () ->+    IO ()+runPollLoopWith wake fallbackMicros pass =+    forever (pass >> void (waitForWake wake fallbackMicros))++{- | The workflow resume worker, push-aware (EP-50). Runs 'resumeWorkflowsOnce'+on each pass; between passes it waits on the store's notifier (sub-second wake on+any append) and falls back to 'pollInterval' so a dropped notification still+drains the backlog.++This is the push-aware sibling of 'runWorkflowResumeWorker' /+'runWorkflowResumeWorkerWith', which remain unchanged as the durable fixed-poll+baseline. The 'pollInterval' field is __repurposed__ as the /fallback/ timeout:+its meaning shifts from "fixed gap between passes" to "maximum gap when no+notification arrives" — strictly better for latency, identical in the+no-notification worst case.++It opens __no__ new database connection (the 'WakeSignal' rides kiroku's existing+single per-store listener; see "Keiro.Wake"). It takes the 'KirokuStore' handle+directly to reach that notifier, and runs each pass through+'Kiroku.Store.Effect.runStoreIO', which pins the registry's effect row to the+concrete @'[Store, Error StoreError, IOE]@ that @runStoreIO@ eliminates. A caller+needing a richer effect row can use 'runPollLoopWith' directly with their own+@runStoreIO@-equivalent pass.+-}+runWorkflowResumeWorkerPush ::+    KirokuStore ->+    WorkflowResumeOptions ->+    WorkflowRegistry '[Store, Error StoreError, IOE] ->+    IO ()+runWorkflowResumeWorkerPush store opts registry = do+    wake <- wakeSignalFromStore store+    runPollLoopWith wake (pollInterval opts) onePass+  where+    onePass =+        handleSyncIO $+            runStoreIO store (resumeWorkflowsOnce opts registry) >>= \case+                Left err -> logEvent opts (ResumePassFailed (Text.pack (show err)))+                Right _ -> pure ()+    handleSyncIO action =+        action `Exception.catch` \err ->+            case Exception.fromException err of+                Just (async :: Exception.SomeAsyncException) -> Exception.throwIO async+                Nothing -> logEvent opts (ResumePassFailed (Text.pack (show (err :: Exception.SomeException))))
+ src/Keiro/Workflow/Schema.hs view
@@ -0,0 +1,255 @@+{- | The @keiro_workflow_steps@ table: the derived index of journaled+workflow steps.++The journal stream (@wf:\<name\>-\<id\>@) is the source of truth for replay;+this table is a fast-lookup view kept in sync inside the same transaction as+each journal append (see "Keiro.Workflow"). 'recordStepTx' upserts a row;+'loadStepIndex' reads an instance's recorded steps; 'stepExists' checks for+one step; 'findUnfinishedWorkflowIds' discovers resumable rows from+@keiro_workflows@ — the seam EP-42's resume worker builds on.++Callers normally use the re-exports from "Keiro.Workflow" rather than this+module directly.+-}+module Keiro.Workflow.Schema (+    -- * Rows+    WorkflowStepRow (..),++    -- * Storage+    recordStepTx,+    lookupStepResultTx,+    lockWorkflowStepTx,+    setWorkflowWakeAfterTx,++    -- * Read-only lookups+    loadStepIndex,+    stepExists,+    currentGeneration,+    findUnfinishedWorkflowIds,+)+where++import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip6)+import Data.Int (Int32)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Effectful (Eff, (:>))+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiro.Prelude+import Keiro.Workflow.Types (WorkflowId (..), WorkflowName (..))+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import "hasql-transaction" Hasql.Transaction qualified as Tx++{- | A row of the @keiro_workflow_steps@ index: the workflow instance and+name, the step name, the step's JSON result, and when it was recorded. The+terminal completion marker is stored as a row whose 'stepName' is+'Keiro.Workflow.Types.completedStepName' and whose 'result' is JSON @null@.+-}+data WorkflowStepRow = WorkflowStepRow+    { workflowId :: !Text+    , workflowName :: !Text+    , generation :: !Int+    {- ^ EP-48: the journal /generation/ this step belongs to. Generation 0 is+    the pre-rotation default; @continueAsNew@ rotates onto higher generations.+    -}+    , stepName :: !Text+    , result :: !Value+    , recordedAt :: !UTCTime+    }+    deriving stock (Generic, Eq, Show)++{- | Upsert a step row inside the caller's transaction — an+@INSERT ... ON CONFLICT (workflow_id, step_name) DO NOTHING@, so a replayed+or raced write is a no-op. Called in the same transaction as the journal+append so the index and the journal stay consistent.+-}+recordStepTx :: WorkflowStepRow -> Tx.Transaction ()+recordStepTx row =+    Tx.statement+        ( row ^. #workflowId+        , row ^. #workflowName+        , fromIntegral (row ^. #generation) :: Int32+        , row ^. #stepName+        , row ^. #result+        , row ^. #recordedAt+        )+        recordStepStmt++lookupStepResultTx :: Text -> Text -> Int -> Text -> Tx.Transaction (Maybe Value)+lookupStepResultTx wid name gen key =+    Tx.statement (wid, name, fromIntegral gen :: Int32, key) lookupStepResultStmt++lockWorkflowStepTx :: Text -> Tx.Transaction ()+lockWorkflowStepTx key =+    void (Tx.statement key lockWorkflowStepStmt)++setWorkflowWakeAfterTx :: WorkflowName -> WorkflowId -> UTCTime -> Tx.Transaction ()+setWorkflowWakeAfterTx (WorkflowName name) (WorkflowId wid) wakeAfter =+    Tx.statement (wid, name, wakeAfter) setWorkflowWakeAfterStmt++{- | Load every recorded step for a workflow instance as a @step name ->+result@ map (includes the terminal completion marker row if present). Exposed+for EP-42's resume worker; the replay handler in "Keiro.Workflow" pre-loads+from the journal stream instead.+-}+loadStepIndex :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Eff es (Map Text Value)+loadStepIndex (WorkflowName name) (WorkflowId wid) gen =+    Map.fromList <$> runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32) loadStepIndexStmt)++{- | Whether a workflow instance already has an index row for the given step+name. Used to make journal re-appends idempotent without relying on the event+store's duplicate-id rejection.+-}+stepExists :: (Store :> es) => WorkflowName -> WorkflowId -> Int -> Text -> Eff es Bool+stepExists (WorkflowName name) (WorkflowId wid) gen key =+    runTransaction (Tx.statement (wid, name, fromIntegral gen :: Int32, key) stepExistsStmt)++{- | The current (highest) generation recorded for a logical workflow, or 0 if+it has no step rows yet (EP-48). Index-supported by the+@(workflow_id, workflow_name, generation)@ lookup index. A workflow that never+rotates stays at generation 0 and behaves byte-for-byte as it did before EP-48.+A rotation commits the next generation's seed step under generation @g+1@ in+the same logical-id key space, so @MAX(generation)@ is unambiguously the+current generation.+-}+currentGeneration :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es Int+currentGeneration (WorkflowName name) (WorkflowId wid) =+    fromIntegral <$> runTransaction (Tx.statement (wid, name) currentGenerationStmt)++{- | Return the @(workflow_id, workflow_name)@ of every non-terminal workflow+instance. Terminal statuses are @completed@, @cancelled@, and @failed@, matching+'Keiro.Workflow.Instance.WorkflowStatus'. The explicit time parameter is+reserved for wake-time filtering; today it keeps the call shape stable for that+addition.+-}+findUnfinishedWorkflowIds :: (Store :> es) => UTCTime -> Eff es [(Text, Text)]+findUnfinishedWorkflowIds now =+    runTransaction (Tx.statement now findUnfinishedWorkflowIdsStmt)++recordStepStmt :: Statement (Text, Text, Int32, Text, Value, UTCTime) ()+recordStepStmt =+    preparable+        """+        INSERT INTO keiro.keiro_workflow_steps+          (workflow_id, workflow_name, generation, step_name, result, recorded_at)+        VALUES ($1, $2, $3, $4, $5, $6)+        ON CONFLICT (workflow_id, workflow_name, generation, step_name) DO NOTHING+        """+        ( contrazip6+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.jsonb))+            (E.param (E.nonNullable E.timestamptz))+        )+        D.noResult++lookupStepResultStmt :: Statement (Text, Text, Int32, Text) (Maybe Value)+lookupStepResultStmt =+    preparable+        """+        SELECT result+        FROM keiro.keiro_workflow_steps+        WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4+        """+        ( contrazip4+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+            (E.param (E.nonNullable E.text))+        )+        (D.rowMaybe (D.column (D.nonNullable D.jsonb)))++lockWorkflowStepStmt :: Statement Text Int32+lockWorkflowStepStmt =+    preparable+        """+        SELECT 1::int4 FROM pg_advisory_xact_lock(hashtextextended($1, 0))+        """+        (E.param (E.nonNullable E.text))+        (D.singleRow (D.column (D.nonNullable D.int4)))++loadStepIndexStmt :: Statement (Text, Text, Int32) [(Text, Value)]+loadStepIndexStmt =+    preparable+        """+        SELECT step_name, result+        FROM keiro.keiro_workflow_steps+        WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3+        """+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+        )+        (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb)))++stepExistsStmt :: Statement (Text, Text, Int32, Text) Bool+stepExistsStmt =+    preparable+        """+        SELECT EXISTS (+          SELECT 1 FROM keiro.keiro_workflow_steps+          WHERE workflow_id = $1 AND workflow_name = $2 AND generation = $3 AND step_name = $4+        )+        """+        ( contrazip4+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+            (E.param (E.nonNullable E.text))+        )+        (D.singleRow (D.column (D.nonNullable D.bool)))++-- The current generation is MAX(generation) for the logical id+name, or 0 when+-- the workflow has no rows. Index-supported by keiro_workflow_steps_workflow_idx.+currentGenerationStmt :: Statement (Text, Text) Int32+currentGenerationStmt =+    preparable+        """+        SELECT COALESCE(MAX(generation), 0)::int4+        FROM keiro.keiro_workflow_steps+        WHERE workflow_id = $1 AND workflow_name = $2+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        (D.singleRow (D.column (D.nonNullable D.int4)))++-- The terminal-status literals must match 'Keiro.Workflow.Instance.statusToText'+-- for completed, cancelled, and failed. The timestamp parameter makes+-- wake_after a self-expiring skip: future sleepers disappear from discovery+-- until their timer is due.+findUnfinishedWorkflowIdsStmt :: Statement UTCTime [(Text, Text)]+findUnfinishedWorkflowIdsStmt =+    preparable+        """+        SELECT workflow_id, workflow_name+        FROM keiro.keiro_workflows+        WHERE status NOT IN ('completed', 'cancelled', 'failed')+          AND (wake_after IS NULL OR wake_after <= $1)+        ORDER BY workflow_name, workflow_id+        """+        (E.param (E.nonNullable E.timestamptz))+        (D.rowList ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))++setWorkflowWakeAfterStmt :: Statement (Text, Text, UTCTime) ()+setWorkflowWakeAfterStmt =+    preparable+        """+        UPDATE keiro.keiro_workflows+        SET wake_after = $3,+            updated_at = now()+        WHERE workflow_id = $1 AND workflow_name = $2+        """+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.timestamptz))+        )+        D.noResult
+ src/Keiro/Workflow/Sleep.hs view
@@ -0,0 +1,317 @@+{- | Durable @sleep@ for workflows, backed by the existing @keiro_timers@ table.++== What this gives you++A workflow author can insert a durable pause between steps:++@+demo :: ('Workflow' ':>' es, 'Store' ':>' es, IOE ':>' es) => Eff es (Int, Int)+demo = do+  a <- 'step' (StepName \"a\") (liftIO incr)   -- side effect #1+  'sleepNamed' (StepName \"cool\") 300          -- durable wait, survives a restart+  b <- 'step' (StepName \"b\") (liftIO incr)   -- side effect #2+  pure (a, b)+@++On the __first__ run, @demo@ executes @a@, journals it, arms a Postgres timer+for the sleep, and __suspends__ — 'Keiro.Workflow.runWorkflow' returns+'Suspended' and the journal @wf:demo-\<id\>@ holds only the @StepRecorded \"a\"@+event. The @b@ side effect has not run. The process can now crash, be+redeployed, or sit idle for the full delay: the only durable state of the pause+is a single row in 'keiro_timers', so the wait survives a restart with __no+external scheduler and no in-memory timer thread__.++When the timer becomes due, the existing timer worker+('Keiro.Timer.runTimerWorker') fires it through 'workflowSleepFireAction',+which recognises the row as a workflow sleep (by the JSON payload+discriminator), reconstructs the journal stream, and appends a+@StepRecorded \"sleep:cool\"@ completion. A later run replays: @step \"a\"@+short-circuits to its recorded result, @sleepNamed \"cool\"@ sees its completion+already journaled and returns immediately, and only @step \"b\"@ runs for real.++== 'sleepNamed' vs. 'sleep'++* 'sleepNamed' is the __stable primitive__. Replay matches the sleep on its+  (prefixed) 'StepName', so the name must be deterministic across replays. A+  user-supplied name is unconditionally stable: the same source always produces+  the same name regardless of how surrounding code is reordered between deploys.++* 'sleep' is an ordinal convenience built on 'sleepNamed' via+  'Keiro.Workflow.freshOrdinal' (the @N@th sleep in a run gets @sleep:N@). Its+  determinism is __conditional__: reordering or inserting sleeps between deploys+  shifts the ordinals and can make a resumed in-flight workflow re-arm a+  /different/ timer. Prefer 'sleepNamed' for anything that must survive a code+  change mid-flight.++== Operational contract++* __Payload discriminator.__ A workflow-sleep timer row carries+  @{\"kind\":\"keiro.workflow.sleep\",\"step\":\"sleep:\<suffix\>\"}@ in its+  @payload@ (see 'sleepTimerPayload' / 'parseSleepPayload'). This is how a+  single timer worker distinguishes workflow sleeps from ordinary+  process-manager timers and routes each correctly.++* __Deterministic timer id.__ The timer id is a v5 UUID over+  @(\"keiro\":\"workflow-sleep\":name:id:generation:sleepStepName)@ for+  generation 1 and later, while generation 0 keeps the legacy+  @(\"keiro\":\"workflow-sleep\":name:id:sleepStepName)@ shape. The workflow+  sleep arm uses 'Keiro.Timer.scheduleTimerOnceTx', so the first arm's+  @fire_at@ wins and every resume that re-enters the not-yet-resolved sleep+  leaves the row untouched. The sleep duration is measured from the first arm,+  not from the latest resume pass.++* __No @keiro_timers@ schema change.__ Routing is entirely a function of the+  caller-supplied fire action and the JSON payload; this module owns no+  migration.++* __A worker must drain the timers.__ A sleep only ever fires if some timer+  worker runs 'workflowSleepFireAction' (via 'runWorkflowTimerWorker', or by+  passing 'workflowSleepFireAction' directly to 'Keiro.Timer.runTimerWorker').+  A sleep whose timer is never drained — or one whose timer an operator+  'Keiro.Timer.cancelTimer's — stays suspended forever until an operator+  intervenes. Workflow sleeps otherwise inherit the timer subsystem's recovery+  surface ('Keiro.Timer.findStuckTimers' / 'Keiro.Timer.requeueStuckTimer' /+  'Keiro.Timer.deadLetterTimer') for free.+-}+module Keiro.Workflow.Sleep (+    -- * Authoring surface+    sleepNamed,+    sleep,++    -- * Firing and worker wiring+    workflowSleepFireAction,+    runWorkflowTimerWorker,++    -- * Timer id, payload, and step-name helpers+    sleepTimerId,+    sleepStepName,+    sleepTimerPayload,+    parseSleepPayload,+    workflowSleepKind,+)+where++import Data.Aeson (Value (..), object)+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Text qualified as Text+import Data.Time (NominalDiffTime, addUTCTime)+import Data.UUID.V5 qualified as UUID.V5+import Effectful (Eff, IOE, (:>))+import Keiro.Prelude+import Keiro.Telemetry (KeiroMetrics)+import Keiro.Timer (+    TimerId (..),+    TimerRequest (..),+    TimerRow,+    runTimerWorker,+    scheduleTimerOnceTx,+ )+import Keiro.Workflow (+    StepName (..),+    Workflow,+    WorkflowId (..),+    WorkflowJournalEvent (..),+    WorkflowName (..),+    appendJournalEntryReturningId,+    awaitStep,+    currentRunGeneration,+    currentWorkflow,+    freshOrdinal,+    setWorkflowWakeAfterTx,+    sleepStepPrefix,+ )+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (EventId)++-- ---------------------------------------------------------------------------+-- Discriminator and payload+-- ---------------------------------------------------------------------------++{- | The payload @"kind"@ tag that marks a 'keiro_timers' row as a workflow+sleep, distinguishing it from an ordinary process-manager timer so a single+timer worker can route each correctly.+-}+workflowSleepKind :: Text+workflowSleepKind = "keiro.workflow.sleep"++{- | Build the JSON payload carried on a workflow-sleep timer row. The argument+is the full @"sleep:\<suffix\>"@ journal step name the firing will record.+-}+sleepTimerPayload :: Text -> Value+sleepTimerPayload fullStep =+    object ["kind" Aeson..= workflowSleepKind, "step" Aeson..= fullStep]++{- | Recognise and extract a workflow-sleep payload: @Just fullStep@ for a+payload this module wrote, 'Nothing' for any other timer (e.g. a process+manager's). The full step name returned is what the fire action journals.+-}+parseSleepPayload :: Value -> Maybe Text+parseSleepPayload = \case+    Object o+        | KeyMap.lookup "kind" o == Just (String workflowSleepKind) ->+            case KeyMap.lookup "step" o of+                Just (String s) -> Just s+                _ -> Nothing+    _ -> Nothing++-- ---------------------------------------------------------------------------+-- Deterministic ids and step names+-- ---------------------------------------------------------------------------++{- | The deterministic timer id for a sleep. Generation 0 keeps the legacy v5+UUID over @(\"keiro\":\"workflow-sleep\":name:id:fullStep)@ so in-flight+pre-change timers remain signalable. Generations 1 and later include the+generation component so a sleep after 'Keiro.Workflow.continueAsNew' never+collides with a prior generation's terminal timer row.+-}+sleepTimerId :: WorkflowName -> WorkflowId -> Int -> Text -> TimerId+sleepTimerId name wid gen fullStep =+    TimerId $+        UUID.V5.generateNamed UUID.V5.namespaceURL $+            fmap (fromIntegral . fromEnum) $+                Text.unpack $+                    Text.intercalate+                        ":"+                        components+  where+    components+        | gen <= 0 =+            [ "keiro"+            , "workflow-sleep"+            , unWorkflowName name+            , unWorkflowId wid+            , fullStep+            ]+        | otherwise =+            [ "keiro"+            , "workflow-sleep"+            , unWorkflowName name+            , unWorkflowId wid+            , Text.pack (show gen)+            , fullStep+            ]++{- | The durable journal step name for a sleep: the user's suffix prefixed with+'sleepStepPrefix'. @'sleepStepName' (StepName \"cool\") == \"sleep:cool\"@. The+prefix keeps the journal self-describing — an operator scanning it sees+@sleep:@ and knows the entry is a durable wait, not an ordinary step.+-}+sleepStepName :: StepName -> Text+sleepStepName (StepName suffix) = sleepStepPrefix <> suffix++-- ---------------------------------------------------------------------------+-- Authoring surface+-- ---------------------------------------------------------------------------++{- | 'awaitStep' specialised to a 'Value' result. The recorded sleep completion+carries JSON @null@; 'Value''s 'FromJSON' is the identity, so any recorded+result decodes, which decouples the sleep from a @FromJSON ()@ instance.+-}+awaitValue :: (Workflow :> es) => StepName -> Eff es () -> Eff es Value+awaitValue = awaitStep++{- | Durably pause the workflow for @delta@ under the stable name @userStep@.+On the first encounter this arms a deterministic 'keiro_timers' row and+suspends the run; the suspension resolves when a timer worker fires the row+(see 'workflowSleepFireAction') and journals the sleep's completion, after which+a later run replays past the sleep without re-arming.++The arming action is idempotent (a resumed workflow re-runs it until the sleep+resolves): it inserts with a deterministic 'sleepTimerId' only when the row is+absent, so the first @fire_at@ persists across every resume pass.+-}+sleepNamed ::+    (Workflow :> es, Store :> es, IOE :> es) =>+    StepName ->+    NominalDiffTime ->+    Eff es ()+sleepNamed userStep delta = do+    (name, wid) <- currentWorkflow+    gen <- currentRunGeneration+    let full = sleepStepName userStep+        armedStep = StepName full+    void . awaitValue armedStep $ do+        now <- liftIO getCurrentTime+        let request =+                TimerRequest+                    { timerId = sleepTimerId name wid gen full+                    , processManagerName = unWorkflowName name+                    , correlationId = unWorkflowId wid+                    , fireAt = addUTCTime delta now+                    , payload = sleepTimerPayload full+                    }+        -- Re-arms can only happen once discovery has found this instance again,+        -- which means any existing wake_after has already self-expired. A later+        -- overwrite is therefore bounded by the requested delay and suppresses+        -- only future not-yet-due resume passes.+        runTransaction (scheduleTimerOnceTx request >> setWorkflowWakeAfterTx name wid (request ^. #fireAt))++{- | Durably pause the workflow for @delta@ under an ordinal name (the @N@th+sleep in a run becomes @sleep:N@). Convenient but its determinism is+conditional — see the module header. Prefer 'sleepNamed' for anything that must+survive a code change mid-flight.+-}+sleep :: (Workflow :> es, Store :> es, IOE :> es) => NominalDiffTime -> Eff es ()+sleep delta = do+    n <- freshOrdinal "sleep"+    sleepNamed (StepName (Text.pack (show n))) delta++-- ---------------------------------------------------------------------------+-- Firing and worker wiring+-- ---------------------------------------------------------------------------++{- | The fire action for workflow-sleep timers. For a 'TimerRow' whose payload+is a workflow-sleep discriminator, reconstruct the workflow identity from the+row's @processManagerName@ (= workflow name) and @correlationId@ (= workflow+id), append a @StepRecorded@ completion (@result = null@) to the workflow's+journal via 'appendJournalEntryReturningId', and return the appended 'EventId'+so the worker marks the timer @Fired@. Returns 'Nothing' for a row whose+payload is __not__ a workflow sleep, so a mixed worker can delegate that row to+its process-manager fire action.++Idempotent: 'appendJournalEntryReturningId' pre-checks the step and returns the+same deterministic id on a re-fire, so at-least-once timer firing yields+exactly-once journaling.+-}+workflowSleepFireAction ::+    (Store :> es, IOE :> es) => TimerRow -> Eff es (Maybe EventId)+workflowSleepFireAction row =+    case parseSleepPayload (row ^. #payload) of+        Nothing -> pure Nothing+        Just full -> do+            now <- liftIO getCurrentTime+            let name = WorkflowName (row ^. #processManagerName)+                wid = WorkflowId (row ^. #correlationId)+            eid <-+                appendJournalEntryReturningId+                    name+                    wid+                    (StepRecorded{stepName = full, result = Null, recordedAt = now})+            pure (Just eid)++{- | A timer worker pass that handles __both__ workflow-sleep timers and+ordinary process-manager timers. For each claimed timer: if its payload is a+workflow sleep, wake the workflow; otherwise delegate to the supplied+process-manager fire action.++A deployment that runs only workflows can pass @\\_ -> pure Nothing@ as the+fallback (or use 'workflowSleepFireAction' directly with+'Keiro.Timer.runTimerWorker'). A deployment that mixes process-manager timers+and workflow sleeps passes its existing PM fire action so one worker drains+both kinds.+-}+runWorkflowTimerWorker ::+    (IOE :> es, Store :> es) =>+    Maybe KeiroMetrics ->+    UTCTime ->+    -- | Fallback fire action for non-sleep (process-manager) timers.+    (TimerRow -> Eff es (Maybe EventId)) ->+    Eff es (Maybe TimerRow)+runWorkflowTimerWorker metrics now pmFire =+    runTimerWorker metrics now $ \row -> do+        handled <- workflowSleepFireAction row+        case handled of+            Just eid -> pure (Just eid)+            Nothing -> pmFire row
+ src/Keiro/Workflow/Snapshot.hs view
@@ -0,0 +1,131 @@+{- | Workflow journal snapshots: the workflow-specific 'StateCodec' and the+read\/write helpers the runtime uses to skip a full version-0 replay.++A durable workflow folds its journal stream into a 'WorkflowState' — a+@'Map' 'Text' 'Value'@ of step-name to encoded result. For a long-lived+workflow, re-reading the whole journal on every run and resume is ruinous.+This module supplies the EP-4 snapshot machinery the runtime reuses to+persist that folded map and, on the next run, seed from it and replay only+the tail.++== Why a workflow-specific codec++EP-4's 'Keiro.Snapshot.Codec.defaultStateCodec' derives its 'shapeHash' from+a /statically-known/ keiki register-file slot list+('Keiki.Shape.regFileShapeHash'). A workflow's step names are dynamic runtime+strings, so there is no static slot list. The accumulated state is instead a+self-describing JSON object, so it round-trips through Aeson trivially and its+/shape/ never varies with which steps ran. Hence the fixed sentinel+'workflowStateShapeHash'; per-step result-type evolution is each step's own+'Aeson.ToJSON'\/'Aeson.FromJSON' concern, surfaced at the @step@ decode in+"Keiro.Workflow", not here.++== Advisory semantics++A snapshot is an optimization, never a source of truth. 'loadWorkflowSnapshot'+returns 'Nothing' — meaning "replay from version 0" — when the stream has no+id yet, no matching snapshot, or an undecodable snapshot. So a stale or corrupt+snapshot degrades performance at worst, never correctness.++Runtime snapshot writes are advisory too. After a workflow journal append has+committed, "Keiro.Workflow" swallows any snapshot-store failure and increments+@keiro.snapshot.write.failures@; the committed step, completion, or rotation+therefore still determines a successful run. This low-level module continues+to expose the store primitive, while the runtime owns that error handling.++Snapshot writes store the full accumulated step map each time the selected+policy fires. With an every-n policy that means rewriting the complete map at+each boundary; the intended way to bound that cost for forever-running+workflows is 'Keiro.Workflow.continueAsNew', which starts a fresh generation+with a small carried seed.+-}+module Keiro.Workflow.Snapshot (+    workflowStateCodec,+    workflowStateCodecVersion,+    workflowStateShapeHash,+    lookupWorkflowSnapshot,+    loadWorkflowSnapshot,+    writeWorkflowSnapshot,+)+where++import Data.Aeson (Result (..))+import Data.Text qualified as Text+import Effectful (Eff, (:>))+import Keiro.EventStream (StateCodec (..))+import Keiro.Prelude+import Keiro.Snapshot (SnapshotMissReason (..), writeSnapshot)+import Keiro.Snapshot.Schema (lookupSnapshot)+import Keiro.Workflow.Types (WorkflowState)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Read (lookupStreamId)+import Kiroku.Store.Types (StreamId, StreamName, StreamVersion)++{- | The codec version of the workflow snapshot envelope. Bumped only if the+map /envelope/ encoding itself changes (e.g. a switch from a bare JSON+object to a tagged container), never for a per-step result-type change.+-}+workflowStateCodecVersion :: Int+workflowStateCodecVersion = 1++{- | A FIXED sentinel shape hash. The accumulated state is always "a JSON+object of step-name strings to self-describing JSON values"; its /shape/+never varies with which steps ran, so the shape hash is constant. Per-step+result-type evolution is the step's own 'Aeson.ToJSON'\/'Aeson.FromJSON'+concern, surfaced at the step decode in "Keiro.Workflow", not here.+-}+workflowStateShapeHash :: Text+workflowStateShapeHash = "keiro.workflow.stepmap.v1"++{- | The workflow-specific 'StateCodec'. Encodes the accumulated+'WorkflowState' map straight to JSON and decodes it back, with a fixed+discriminant ('workflowStateCodecVersion', 'workflowStateShapeHash').+-}+workflowStateCodec :: StateCodec WorkflowState+workflowStateCodec =+    StateCodec+        { stateCodecVersion = workflowStateCodecVersion+        , shapeHash = workflowStateShapeHash+        , encode = toJSON+        , decode = \value -> case fromJSON value of+            Success m -> Right m+            Error msg -> Left (Text.pack msg)+        }++{- | Encode the accumulated map and upsert @keiro_snapshots@ for the journal+stream. Called from the @step@ miss-path (and the completion site) with the+'Kiroku.Store.Types.AppendResult'\'s @streamId@ and post-append @streamVersion@.+The underlying upsert keeps only the highest version per stream, so a re-fire+at an already-snapshotted version is a harmless no-op.+-}+writeWorkflowSnapshot :: (Store :> es) => StreamId -> StreamVersion -> WorkflowState -> Eff es ()+writeWorkflowSnapshot streamId version state =+    writeSnapshot streamId version workflowStateCodec state++{- | Resolve the journal stream id, look up the latest matching snapshot row,+and decode it to a @('WorkflowState', 'StreamVersion')@ seed. Returns+'Nothing' — meaning "replay from 0" — when the stream has no id yet, no+matching snapshot, or an undecodable snapshot (advisory semantics). Mirrors+'Keiro.Snapshot.hydrateWithSnapshot''s miss-is-benign contract.+-}+loadWorkflowSnapshot :: (Store :> es) => StreamName -> Eff es (Maybe (WorkflowState, StreamVersion))+loadWorkflowSnapshot journalName =+    lookupWorkflowSnapshot journalName <&> either (const Nothing) Just++{- | Resolve and decode a workflow snapshot while retaining the reason a+usable seed was unavailable. This is the observable counterpart to+'loadWorkflowSnapshot'.+-}+lookupWorkflowSnapshot :: (Store :> es) => StreamName -> Eff es (Either SnapshotMissReason (WorkflowState, StreamVersion))+lookupWorkflowSnapshot journalName = do+    mStreamId <- lookupStreamId journalName+    case mStreamId of+        Nothing -> pure (Left SnapshotNoStream)+        Just streamId -> do+            mRow <- lookupSnapshot streamId workflowStateCodecVersion workflowStateShapeHash+            pure $ case mRow of+                Nothing -> Left SnapshotNotFound+                Just row ->+                    case (workflowStateCodec ^. #decode) (row ^. #state) of+                        Left message -> Left (SnapshotDecodeFailed message)+                        Right state -> Right (state, row ^. #streamVersion)
+ src/Keiro/Workflow/Types.hs view
@@ -0,0 +1,407 @@+{-# OPTIONS_GHC -Wno-partial-fields #-}++{- | Core types and the journal codec for the durable workflow runtime.++A /durable workflow/ is an ordinary @effectful@ computation whose side+effects are recorded ("journaled") at named checkpoints so the computation+can be paused and resumed across crashes without re-running work that+already happened. The journal is a kiroku stream named+@wf:\<workflow-name\>-\<workflow-id\>@ ('workflowStreamName') holding one+'StepRecorded' event per executed step and a terminal 'WorkflowCompleted'+event.++This module owns the contracts every sibling plan of the v2 MasterPlan+builds on: the identity newtypes ('WorkflowName', 'WorkflowId',+'StepName'), the journal event sum ('WorkflowJournalEvent') and its+'Codec' ('workflowJournalCodec'), the accumulated-state alias+('WorkflowState'), the run outcome ('WorkflowOutcome'), and the+reserved step-name conventions ('completedStepName' plus the+@sleep:@\/@awk:@\/@child:@ prefixes).+-}+module Keiro.Workflow.Types (+    -- * Identity+    WorkflowName (..),+    WorkflowId (..),+    WorkflowIdentityError (..),+    mkWorkflowName,+    mkWorkflowId,+    StepName (..),+    PatchId (..),++    -- * Stream naming+    workflowStreamName,+    workflowGenerationStreamName,++    -- * Journal events and codec+    WorkflowJournalEvent (..),+    workflowJournalCodec,++    -- * Accumulated state and run outcome+    WorkflowState,+    WorkflowOutcome (..),++    -- * Reserved step names+    completedStepName,+    cancelledStepName,+    failedStepName,+    continuedAsNewStepName,+    continueSeedStepName,+    sleepStepPrefix,+    awakeableStepPrefix,+    awakeableAllocStepPrefix,+    childStepPrefix,+    patchStepPrefix,+    patchSetStepName,+    patchStepName,+)+where++import Data.Aeson qualified as Aeson+import Data.Aeson.Types (parseEither)+import Data.Bifunctor (first)+import Data.Map.Strict (Map)+import Data.Text qualified as Text+import Keiro.Codec (Codec (..))+import Keiro.Prelude+import Kiroku.Store.Types (EventType (..), StreamName (..))++{- | The stable name of a workflow /definition/ (for example+@"orderFulfillment"@). Part of the journal stream name and of every+deterministic journal-event id, so it must not change for a given definition+across deploys. Prefer 'mkWorkflowName' for new code; the raw constructor is+kept for compatibility and can create ambiguous journal stream names if the+text contains structural separators such as @-@, @:@, or @#@.+-}+newtype WorkflowName = WorkflowName {unWorkflowName :: Text}+    deriving stock (Eq, Ord, Show, Generic)++{- | The id of a single workflow /instance/ (a UUID-as-text or any stable+caller-supplied string). Combined with the 'WorkflowName' it identifies the+instance's journal stream. Prefer 'mkWorkflowId' for new code; the raw+constructor is kept for compatibility and can create ambiguous journal stream+names if the text contains structural separators such as @:@ or @#@.+-}+newtype WorkflowId = WorkflowId {unWorkflowId :: Text}+    deriving stock (Eq, Ord, Show, Generic)++data WorkflowIdentityError+    = WorkflowNameEmpty+    | WorkflowNameInvalidChar !Char !Text+    | WorkflowIdEmpty+    | WorkflowIdInvalidChar !Char !Text+    deriving stock (Eq, Show, Generic)++{- | Validated constructor for workflow names.++Rejects empty names and the structural separators @:@ (stream prefix), @-@+(name/id boundary), and @#@ (generation suffix). Prefer camelCase compound+names such as @"orderFulfillment"@; the raw 'WorkflowName' constructor remains+available for compatibility.+-}+mkWorkflowName :: Text -> Either WorkflowIdentityError WorkflowName+mkWorkflowName raw+    | Text.null raw = Left WorkflowNameEmpty+    | Just c <- Text.find (`elem` ([':', '-', '#'] :: [Char])) raw =+        Left (WorkflowNameInvalidChar c raw)+    | otherwise = Right (WorkflowName raw)++{- | Validated constructor for workflow ids.++Rejects empty ids and the structural separators @:@ and @#@. The @-@ character+is permitted so UUID-style ids remain valid; with a validated, hyphen-free+workflow name, the @wf:\<name\>-\<id\>@ boundary is the first @-@.+-}+mkWorkflowId :: Text -> Either WorkflowIdentityError WorkflowId+mkWorkflowId raw+    | Text.null raw = Left WorkflowIdEmpty+    | Just c <- Text.find (`elem` ([':', '#'] :: [Char])) raw =+        Left (WorkflowIdInvalidChar c raw)+    | otherwise = Right (WorkflowId raw)++{- | The label identifying a step within a workflow. Replay matches on this+label, not on source position, so reordering code between deploys does not+corrupt an in-flight workflow.+-}+newtype StepName = StepName {unStepName :: Text}+    deriving stock (Eq, Ord, Show, Generic)++{- | The stable identifier of a /patch/ (EP-49) — a guarded, cross-cutting change+to a running workflow's logic. The author chooses an opaque, never-reused string+(for example @"fraud-check-v2"@). A patch decision is journaled under the key+@patch:\<patchId\>@, so the id must not contain the structural @:@ in a way that+makes the prefix boundary ambiguous, mirroring the 'sleepStepPrefix' caveat.+-}+newtype PatchId = PatchId {unPatchId :: Text}+    deriving stock (Eq, Ord, Show, Generic)++{- | The journal stream name for a workflow instance:+@wf:\<name\>-\<id\>@.++The @:@ and @-@ characters are structural, and generation streams reserve @#@.+Use 'mkWorkflowName' and 'mkWorkflowId' for separator-safe identities. Raw+unvalidated names containing @-@ can make two distinct @(name, id)@ pairs share+one journal stream (the v1 process-manager @pm:\<name\>-\<correlationId\>@+convention carries the same caveat).+-}+workflowStreamName :: WorkflowName -> WorkflowId -> StreamName+workflowStreamName (WorkflowName name) (WorkflowId wid) =+    StreamName ("wf:" <> name <> "-" <> wid)++{- | The PHYSICAL journal stream for a given /generation/ of a logical+workflow (EP-48 continue-as-new).++Generation 0 keeps the legacy name @wf:\<name\>-\<id\>@ — so already-running,+never-rotated workflows are byte-for-byte unchanged and need zero data+migration — while generation @g > 0@ appends a @#\<g\>@ suffix. The @#@ is a+new structural separator, distinct from the @:@ and @-@ that+'workflowStreamName' already reserves, so it cannot collide with an existing+boundary. The /logical/ identity @('WorkflowName', 'WorkflowId')@ the author+and the resume registry see is stable across rotations; only the physical+stream the journal lives on rotates underneath it.+-}+workflowGenerationStreamName :: WorkflowName -> WorkflowId -> Int -> StreamName+workflowGenerationStreamName name wid gen+    | gen <= 0 = workflowStreamName name wid+    | otherwise =+        let StreamName base = workflowStreamName name wid+         in StreamName (base <> "#" <> Text.pack (show gen))++{- | The events written to a workflow journal.++* 'StepRecorded' — a step (identified by 'stepName') ran and produced+  'result' (the step's value encoded as JSON) at 'recordedAt'. The+  suspension primitives journal their completions as ordinary+  'StepRecorded' events whose 'stepName' carries a reserved prefix+  ('sleepStepPrefix', 'awakeableStepPrefix', 'childStepPrefix'); the+  replay loop stays uniform because there is no separate event type.+* 'WorkflowCompleted' — the terminal marker appended once the whole+  computation has returned.+* 'WorkflowCancelled' — a terminal marker (EP-43) written to a /child/+  workflow's journal by @cancelChild@; a run whose journal carries it+  short-circuits without executing further steps and reports+  'Keiro.Workflow.Types.Cancelled'.+* 'WorkflowFailed' — a terminal failure marker (carries a 'reason'),+  available for a worker to record a permanently-failed run.++These last two are purely additive within @schemaVersion = 1@ (a new wire+tag added to 'workflowJournalCodec''s 'eventTypes'; old journals never carry+it, so no upcaster is needed). The codec is deliberately the single place to+extend.+-}+data WorkflowJournalEvent+    = StepRecorded {stepName :: !Text, result :: !Aeson.Value, recordedAt :: !UTCTime}+    | WorkflowCompleted {recordedAt :: !UTCTime}+    | WorkflowCancelled {recordedAt :: !UTCTime}+    | WorkflowFailed {reason :: !Text, recordedAt :: !UTCTime}+    | {- | Terminal-for-this-generation rotation marker (EP-48). 'generation'+      is the NEXT generation this rotation opens. Additive within+      @schemaVersion = 1@: old journals never carry the+      @"WorkflowContinuedAsNew"@ tag, so no upcaster is needed.+      -}+      WorkflowContinuedAsNew {generation :: !Int, recordedAt :: !UTCTime}+    deriving stock (Eq, Show, Generic)++{- | The 'Codec' that serializes 'WorkflowJournalEvent' to and from the+JSON payloads stored on the journal stream. Schema version 1; no+upcasters. Each payload is self-describing (it carries a @"kind"@+discriminator) so 'decode' can reconstruct the constructor from the+payload alone.+-}+workflowJournalCodec :: Codec WorkflowJournalEvent+workflowJournalCodec =+    Codec+        { eventTypes = EventType "StepRecorded" :| [EventType "WorkflowCompleted", EventType "WorkflowCancelled", EventType "WorkflowFailed", EventType "WorkflowContinuedAsNew"]+        , eventType = \case+            StepRecorded{} -> EventType "StepRecorded"+            WorkflowCompleted{} -> EventType "WorkflowCompleted"+            WorkflowCancelled{} -> EventType "WorkflowCancelled"+            WorkflowFailed{} -> EventType "WorkflowFailed"+            WorkflowContinuedAsNew{} -> EventType "WorkflowContinuedAsNew"+        , schemaVersion = 1+        , encode = encodeJournalEvent+        , decode = decodeJournalEvent+        , upcasters = []+        }++encodeJournalEvent :: WorkflowJournalEvent -> Aeson.Value+encodeJournalEvent = \case+    StepRecorded name r t ->+        Aeson.object+            [ "kind" Aeson..= ("StepRecorded" :: Text)+            , "stepName" Aeson..= name+            , "result" Aeson..= r+            , "recordedAt" Aeson..= t+            ]+    WorkflowCompleted t ->+        Aeson.object+            [ "kind" Aeson..= ("WorkflowCompleted" :: Text)+            , "recordedAt" Aeson..= t+            ]+    WorkflowCancelled t ->+        Aeson.object+            [ "kind" Aeson..= ("WorkflowCancelled" :: Text)+            , "recordedAt" Aeson..= t+            ]+    WorkflowFailed r t ->+        Aeson.object+            [ "kind" Aeson..= ("WorkflowFailed" :: Text)+            , "reason" Aeson..= r+            , "recordedAt" Aeson..= t+            ]+    WorkflowContinuedAsNew g t ->+        Aeson.object+            [ "kind" Aeson..= ("WorkflowContinuedAsNew" :: Text)+            , "generation" Aeson..= g+            , "recordedAt" Aeson..= t+            ]++decodeJournalEvent :: EventType -> Aeson.Value -> Either Text WorkflowJournalEvent+decodeJournalEvent (EventType tag) value = first Text.pack (parseEither parser value)+  where+    parser = Aeson.withObject "WorkflowJournalEvent" $ \o -> do+        case tag of+            "StepRecorded" ->+                StepRecorded <$> o Aeson..: "stepName" <*> o Aeson..: "result" <*> o Aeson..: "recordedAt"+            "WorkflowCompleted" ->+                WorkflowCompleted <$> o Aeson..: "recordedAt"+            "WorkflowCancelled" ->+                WorkflowCancelled <$> o Aeson..: "recordedAt"+            "WorkflowFailed" ->+                WorkflowFailed <$> o Aeson..: "reason" <*> o Aeson..: "recordedAt"+            "WorkflowContinuedAsNew" ->+                WorkflowContinuedAsNew <$> o Aeson..: "generation" <*> o Aeson..: "recordedAt"+            other ->+                fail ("unknown workflow journal event type: " <> Text.unpack other)++{- | The accumulated step state a running workflow holds in memory: a map+from step name to that step's recorded JSON result. This is exactly the+value the journal carries, folded into a map.++This alias is the integration contract EP-41 (snapshots) consumes; it must+remain a @Map Text Value@ whose keys are dynamic step-name strings.+-}+type WorkflowState = Map Text Aeson.Value++{- | The result of running a workflow.++* 'Completed' — the computation ran to its end and a 'WorkflowCompleted'+  event was journaled.+* 'Suspended' — the computation paused at an unresolved @awaitStep@; a+  wake source was armed and the run will be resumed later (by EP-42's+  resume worker) once the awaited result is journaled.++* 'Cancelled' — the run's journal carried a 'WorkflowCancelled' marker (a+  child cancelled by its parent, EP-43), so the handler short-circuited and+  executed nothing further. Distinct from 'Suspended' (which will resume) and+  'Completed' (which finished its work).+* 'Failed' — the run's journal carried a 'WorkflowFailed' marker, so the+  handler short-circuited and executed nothing further.+-}+data WorkflowOutcome a+    = Completed a+    | Suspended+    | Cancelled+    | Failed+    | {- | EP-48: the run rotated onto a fresh journal generation via+      @continueAsNew@; a subsequent run/resume of the same logical id+      continues from the carried seed. Distinct from 'Suspended' (a wake+      source is pending) and 'Completed' (the workflow is done): a rotated+      workflow is still unfinished, so the resume worker re-invokes it and it+      proceeds on the new generation.+      -}+      ContinuedAsNew+    deriving stock (Eq, Show, Functor)++{- | The reserved step name written (as a 'WorkflowCompleted' journal event+and an index row) when a workflow finishes. The discovery query in+"Keiro.Workflow.Schema" ('Keiro.Workflow.Schema.findUnfinishedWorkflowIds')+treats a workflow lacking a row with this step name as unfinished, so the+literal here must match the literal in that SQL.+-}+completedStepName :: Text+completedStepName = "__workflow_completed__"++{- | The reserved step name written (as a 'WorkflowCancelled' journal event and+an index row) when a workflow is cancelled. The replay handler short-circuits a+run that has a row with this step name, and+'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' treats it (like+'completedStepName') as a terminal marker, so a cancelled workflow drops out of+resume discovery. The literal must match the literal in that SQL.+-}+cancelledStepName :: Text+cancelledStepName = "__workflow_cancelled__"++{- | The reserved step name written (as a 'WorkflowFailed' journal event and an+index row) when a workflow is recorded as permanently failed.+-}+failedStepName :: Text+failedStepName = "__workflow_failed__"++{- | The reserved step name written (as a 'WorkflowContinuedAsNew' journal event+and an index row) when a workflow's generation rotates via @continueAsNew@+(EP-48). Its presence on a generation's index row makes that generation terminal+/for itself/ (a rotated-away generation drops out of any per-generation+"unfinished" check); the /current/ generation is the one with no terminal marker+row. Distinct from 'completedStepName'/'cancelledStepName': a rotated workflow is+NOT finished — its work continues on the next generation —+so 'Keiro.Workflow.Schema.findUnfinishedWorkflowIds' deliberately scopes its+terminal-marker check to the current (MAX) generation and does not treat+'continuedAsNewStepName' as terminal for the logical workflow.+-}+continuedAsNewStepName :: Text+continuedAsNewStepName = "__workflow_continued_as_new__"++{- | The reserved step name under which @continueAsNew@ (EP-48) carries the+author's seed value into the next generation. On rotation the runtime appends a+single @StepRecorded continueSeedStepName seedJson@ to the next generation's+journal (and snapshots it); the next run's body reads it back via @restoreSeed@+— an ordinary journaled @step@ — so the carried state is restored without+re-running anything. The leading/trailing @__@ marks it reserved, like the+other @__workflow_*__@ names.+-}+continueSeedStepName :: Text+continueSeedStepName = "__workflow_seed__"++{- | Reserved step-name prefix EP-39 uses to journal a durable @sleep@'s+completion. Integration contract: EP-39 must use exactly this string.+-}+sleepStepPrefix :: Text+sleepStepPrefix = "sleep:"++{- | Reserved step-name prefix EP-40 uses to journal an awakeable's+completion. Integration contract: EP-40 must use exactly this string.+-}+awakeableStepPrefix :: Text+awakeableStepPrefix = "awk:"++{- | Reserved step-name prefix used to journal the random id allocated for an+awakeable. The id is random for new allocations but replay-stable because it is+recorded under @awkid:\<label\>@ before the workflow awaits @awk:\<uuid\>@.+-}+awakeableAllocStepPrefix :: Text+awakeableAllocStepPrefix = "awkid:"++{- | Reserved step-name prefix EP-43 uses to journal a child workflow's+completion. Integration contract: EP-43 must use exactly this string.+-}+childStepPrefix :: Text+childStepPrefix = "child:"++{- | Reserved step-name prefix EP-49 uses to journal a 'patch' decision. A patch+decision is journaled as an ordinary 'StepRecorded' event whose 'stepName' is+@'patchStepPrefix' <> 'unPatchId' pid@ and whose 'result' is the JSON 'Bool'+branch decision, so the replay loop and the step index stay uniform — no new+journal-event constructor is added.+-}+patchStepPrefix :: Text+patchStepPrefix = "patch:"++{- | Reserved step name under which a workflow generation records the patch ids+that were active when that generation first started.+-}+patchSetStepName :: Text+patchSetStepName = "__workflow_patches__"++-- | The journal key a patch decision is recorded under: @patch:\<patchId\>@.+patchStepName :: PatchId -> Text+patchStepName (PatchId pid) = patchStepPrefix <> pid
+ test/Main.hs view
@@ -0,0 +1,11054 @@+module Main (+    main,+)+where++import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5, contrazip6)+import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar, tryPutMVar)+import Control.Concurrent.STM (atomically, putTMVar)+import Control.Exception (Exception, SomeException, displayException, evaluate, finally, throwIO, try)+import Data.Aeson (object, withObject, (.:), (.:?))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (parseEither)+import Data.ByteString (ByteString)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int32)+import Data.List (isInfixOf)+import Data.Map.Strict qualified as Map+import Data.Monoid (mempty)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, secondsToDiffTime)+import Data.Time.Calendar (Day (ModifiedJulianDay))+import Data.UUID (UUID, fromString, fromWords64)+import Data.UUID qualified as UUID+import Data.Vector qualified as Vector+import Data.Word (Word64)+import Effectful (Eff, IOE, (:>))+import Effectful.Error.Static (Error, throwError)+import GHC.Conc (ThreadStatus (..), threadStatus)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Keiki.Core (+    Edge (..),+    HsPred (..),+    InCtor (..),+    IndexN,+    RegFile (..),+    SymTransducer (..),+    Update (..),+    WireCtor (..),+    inpCtor,+    matchInCtor,+    oNil,+    pack,+    proj,+    (*:),+    (.==),+ )+import Keiki.Core qualified as Keiki+import Keiki.Generics (emptyRegFile)+import Keiro+import Keiro qualified as KeiroRoot+import Keiro.Connection (ensureProjectionSchema, qualifyTable, withProjectionSchema)+import Keiro.DeadLetter (+    DispatchDeadLetter (..),+    DispatcherKind (..),+    listDispatchDeadLetters,+    recordDispatchDeadLetter,+ )+import Keiro.DeadLetter.Replay (+    ReplayOutcome (..),+    ReplayResult (..),+    listSubscriptionDeadLetters,+    replaySubscriptionDeadLetters,+ )+import Keiro.EventStream (Terminality (..))+import Keiro.EventStream.Validate (+    EventStreamWarning (..),+    ValidatedEventStream,+    mkEventStream,+    mkEventStreamOrThrow,+    mkEventStreamUnchecked,+    mkEventStreamWith,+    validateEventStream,+ )+import Keiro.Inbox (+    InboxDedupePolicy (..),+    InboxError (..),+    InboxPersistence (..),+    InboxResult (..),+    InboxStatus (..),+    KafkaDeliveryRef (..),+    garbageCollectCompleted,+    listInbox,+    lookupInbox,+    markFailedTx,+    runInboxTransaction,+    runInboxTransactionBatch,+    runInboxTransactionWith,+    runInboxTransactionWithRetries,+    runInboxTransactionWithRetriesWith,+    sampleInboxBacklog,+ )+import Keiro.Inbox.Kafka qualified as InboxKafka+import Keiro.Integration.Event (+    IntegrationContentType (..),+    IntegrationEvent (..),+    SchemaReference (..),+    TraceContext (..),+    decodeJsonIntegrationEvent,+    encodeJsonIntegrationEvent,+    headerContentType,+    headerMessageId,+    headerSchemaSubject,+    headerSchemaVersion,+    headerSourceEventId,+    headerSourceGlobalPosition,+    headerTraceParent,+    integrationHeaders,+    integrationPayload,+    parseContentType,+ )+import Keiro.Integration.Event qualified as IntegrationEvent+import Keiro.Outbox (+    BackoffSchedule (..),+    ExponentialBackoffOptions (..),+    IntegrationEventDraft (..),+    IntegrationProducer (..),+    IntegrationProducerConfigError (..),+    OrderingPolicy (..),+    OutboxId (..),+    OutboxPublishConfigError (..),+    OutboxRow (..),+    OutboxStatus (..),+    PublishOutcome (..),+    claimOutboxBatch,+    defaultMaintenanceOptions,+    defaultPublishOptions,+    draftToEvent,+    enqueueIntegrationEventTx,+    freshOutboxId,+    garbageCollectSent,+    lookupOutbox,+    markOutboxSent,+    mintIntegrationEvent,+    mkIntegrationProducer,+    mkOutboxPublishOptions,+    outboxMaintenancePass,+    publishClaimedOutbox,+    sampleOutboxBacklog,+ )+import Keiro.Outbox.Kafka qualified as OutboxKafka+import Keiro.Outbox.Schema (markOutboxFailedTx)+import Keiro.Prelude+import Keiro.ProcessManager+import Keiro.Projection+import Keiro.ReadModel+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Keiro.Snapshot.Policy (shouldSnapshot, shouldSnapshotSpan)+import Keiro.Stream qualified as Stream+import Keiro.Subscription.Shard (+    ShardCountMismatch (..),+    ShardLease (..),+    WorkerId (..),+    ensureShards,+    fairShareTarget,+ )+import Keiro.Subscription.Shard.Schema (+    claimShardsTx,+    ensureShardRows,+    listShardOwnership,+    releaseShardsTx,+    renewLeaseTx,+ )+import Keiro.Subscription.Shard.Worker (+    ShardAck (..),+    ShardWorkerError (..),+    ShardedWorkerConfigError (..),+    ShardedWorkerOptions (..),+    acquireOutcome,+    defaultShardedWorkerOptions,+    mkShardedWorkerOptions,+    reconcileShardsOnce,+    runShardedSubscriptionGroup,+    runShardedSubscriptionGroupAck,+ )+import Keiro.Telemetry qualified as Telemetry+import Keiro.Test.Postgres (+    StoreRunner (..),+    withFreshResourceStore,+    withFreshResourceStoreWith,+    withFreshStore,+    withFreshStoreWith,+    withFreshStores2,+    withMigratedSuite,+ )+import Keiro.Timer+import Keiro.Wake (+    WakeReason (..),+    WakeSignal (..),+    neverWake,+    wakeSignalFromStore,+ )+import Keiro.Workflow (+    PatchId (..),+    StepName (..),+    Workflow,+    WorkflowError (..),+    WorkflowId (..),+    WorkflowIdentityError (..),+    WorkflowJournalEvent (StepRecorded, WorkflowCancelled, WorkflowCompleted, WorkflowContinuedAsNew, WorkflowFailed),+    WorkflowName (..),+    WorkflowOutcome (..),+    appendJournalEntry,+    appendJournalEntryReturningId,+    awaitStep,+    awakeableAllocStepPrefix,+    continueAsNew,+    currentGeneration,+    defaultWorkflowRunOptions,+    findUnfinishedWorkflowIds,+    loadStepIndex,+    mkWorkflowId,+    mkWorkflowName,+    patch,+    patchSetStepName,+    patchStepName,+    restoreSeed,+    runWorkflow,+    runWorkflowWith,+    step,+    stepExists,+    workflowGenerationStreamName,+    workflowJournalCodec,+ )+import Keiro.Workflow.Awakeable (+    AwakeableId (..),+    WorkflowAwakeableCancelled (..),+    awakeableIdText,+    awakeableIdToUuid,+    awakeableNamed,+    cancelAwakeable,+    deterministicAwakeableId,+    signalAwakeable,+ )+import Keiro.Workflow.Awakeable.Schema qualified as Awk+import Keiro.Workflow.Child (+    ChildHandle (..),+    WorkflowChildCancelled (..),+    WorkflowChildFailed (..),+    awaitChild,+    cancelChild,+    childCompletionHook,+    childResultStepName,+    childSpawnStepName,+    runChildWorkflow,+    spawnChild,+ )+import Keiro.Workflow.Child.Schema qualified as Child+import Keiro.Workflow.Gc qualified as WorkflowGc+import Keiro.Workflow.Instance qualified as Instance+import Keiro.Workflow.Resume (+    ResumeLogEvent (..),+    ResumeSummary (..),+    WorkflowDef (..),+    defaultWorkflowResumeOptions,+    emptyResumeSummary,+    resumeWorkflowsOnce,+    runPollLoopWith,+    runWorkflowResumeWorkerPush,+    runWorkflowResumeWorkerWith,+ )+import Keiro.Workflow.Sleep (+    parseSleepPayload,+    runWorkflowTimerWorker,+    sleepNamed,+    sleepStepName,+    sleepTimerId,+    sleepTimerPayload,+    workflowSleepFireAction,+ )+import Keiro.Workflow.Snapshot (+    loadWorkflowSnapshot,+    workflowStateCodec,+ )+import Kiroku.Store qualified as Store+import Kiroku.Store.Effect (Store)+import Kiroku.Store.SQL qualified as KirokuSQL+import Kiroku.Store.Subscription.Stream (AckItem (..), subscriptionAckStream)+import Kiroku.Store.Subscription.Types (+    SubscriptionName (..),+    SubscriptionTarget (..),+ )+import Kiroku.Store.Subscription.Types qualified as KirokuSub+import Kiroku.Store.Types (+    CategoryName (..),+    EventData (..),+    EventId (..),+    EventType (..),+    ExpectedVersion (..),+    GlobalPosition (..),+    RecordedEvent (..),+    StreamId (..),+    StreamName (..),+    StreamVersion (..),+ )+import OpenTelemetry.Attributes (Attribute (..), Attributes, PrimitiveAttribute (..), lookupAttribute)+import OpenTelemetry.Attributes.Key (AttributeKey, unkey)+import OpenTelemetry.Exporter.InMemory.Metric (inMemoryMetricExporter)+import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter)+import OpenTelemetry.Exporter.Metric (+    GaugeDataPoint (..),+    HistogramDataPoint (..),+    MetricExport (..),+    NumberValue (..),+    ResourceMetricsExport (..),+    ScopeMetricsExport (..),+    SumDataPoint (..),+ )+import OpenTelemetry.MeterProvider (+    SdkMeterProviderOptions (..),+    createMeterProvider,+    defaultSdkMeterProviderOptions,+ )+import OpenTelemetry.Metric.Core (+    forceFlushMeterProvider,+    getMeter,+ )+import OpenTelemetry.Resource (emptyMaterializedResources)+import OpenTelemetry.Trace (+    SpanStatus (..),+    createTracerProvider,+    emptyTracerProviderOptions,+    makeTracer,+    shutdownTracerProvider,+    tracerOptions,+ )+import OpenTelemetry.Trace.Core (+    ImmutableSpan (..),+    Span,+    SpanContext (..),+    SpanHot (..),+    SpanKind,+    getSpanContext,+ )+import Shibuya.Adapter (Adapter (..))+import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..))+import Shibuya.Core.AckHandle (AckHandle (..))+import Shibuya.Core.Ingested (Ingested (..))+import Shibuya.Core.Types (Envelope (..))+import Streamly.Data.Stream qualified as Streamly+import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import System.Timeout (timeout)+import Test.Hspec+import "hasql-transaction" Hasql.Transaction qualified as Tx++main :: IO ()+main = withMigratedSuite $ \fixture -> hspec $ do+    describe "Keiro" $ do+        it "exposes the scaffold version" $+            KeiroRoot.version `shouldBe` ("0.1.0.0" :: Text)++    describe "Keiro.Telemetry metrics" $ do+        it "records instrument names and values through an SDK meter" $ do+            (exporter, ref) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            metrics <- Telemetry.newKeiroMetrics meter+            let h = Just metrics+            -- A counter (monotonic sum), a gauge (last value wins), a histogram.+            Telemetry.recordOutboxPublished h 3+            Telemetry.recordOutboxPublished h 2+            Telemetry.recordOutboxBacklog h 7+            Telemetry.recordInboxDuplicates h 1+            Telemetry.recordTimerFireLag h 12.5+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef ref+            let scalars = flattenScalarPoints exported+                hists = flattenHistogramPoints exported+            -- The counter accumulated 3 + 2 = 5.+            lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 5)+            -- The gauge holds its last recorded value.+            lookup "keiro.outbox.backlog" scalars `shouldBe` Just (IntNumber 7)+            -- The duplicate counter holds 1.+            lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1)+            -- The histogram saw one observation summing to 12.5.+            let lag = [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"]+            lag `shouldBe` [(1, 12.5)]+            -- Instruments we never recorded export no points.+            lookup "keiro.timer.stuck" scalars `shouldBe` Nothing++        it "records nothing through a Nothing handle" $ do+            (exporter, ref) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            -- A Nothing handle is the no-op path: helpers must short-circuit.+            let h = Nothing+            Telemetry.recordOutboxPublished h 99+            Telemetry.recordOutboxBacklog h 99+            Telemetry.recordTimerFireLag h 99.0+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef ref+            flattenScalarPoints exported `shouldBe` []+            flattenHistogramPoints exported `shouldBe` []++    describe "Kiroku retry exhaustion observability" $ do+        it "dead-letters after the configured delivery bound, emits the metric, and advances" $ do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            metrics <- Telemetry.newKeiroMetrics meter+            forwarded <- newIORef (0 :: Int)+            let observe _ = modifyIORef' forwarded (+ 1)+                installBridge settings =+                    settings+                        & #eventHandler+                        .~ Just (Telemetry.kirokuEventBridge (Just metrics) observe)+            withFreshStoreWith fixture installBridge $ \store -> do+                total <- seedOrders store 1 2+                total `shouldBe` 2+                let subName = SubscriptionName "orders-retry-exhaustion"+                    subConfig =+                        ( KirokuSub.defaultSubscriptionConfig+                            subName+                            (Category (CategoryName "orders"))+                            (\_ -> pure KirokuSub.Continue)+                        )+                            { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 2+                            }+                    pull label source = do+                        result <- timeout 5_000_000 (Streamly.uncons source)+                        case result of+                            Just (Just itemAndRest) -> pure itemAndRest+                            Just Nothing -> fail (label <> ": subscription ended early")+                            Nothing -> fail (label <> ": timed out waiting for delivery")+                    number item =+                        parseEither+                            (withObject "OrderPlaced" (.: "n"))+                            (ackEvent item ^. #payload)+                (stream0, cancelStream) <- subscriptionAckStream store subConfig 4+                ( do+                        (first, stream1) <- pull "initial poison delivery" stream0+                        ackAttempt first `shouldBe` 0+                        number first `shouldBe` Right (0 :: Int)+                        atomically $+                            putTMVar+                                (ackReply first)+                                (KirokuSub.Retry (KirokuSub.RetryDelay 0))++                        (retry, stream2) <- pull "poison redelivery" stream1+                        ackAttempt retry `shouldBe` 1+                        ackEvent retry ^. #eventId `shouldBe` ackEvent first ^. #eventId+                        atomically $+                            putTMVar+                                (ackReply retry)+                                (KirokuSub.Retry (KirokuSub.RetryDelay 0))++                        (next, stream3) <- pull "event after exhausted poison" stream2+                        ackAttempt next `shouldBe` 0+                        number next `shouldBe` Right (1 :: Int)+                        ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId+                        atomically (putTMVar (ackReply next) KirokuSub.Stop)+                        ended <- timeout 5_000_000 (Streamly.uncons stream3)+                        case ended of+                            Just Nothing -> pure ()+                            Just (Just _) -> expectationFailure "subscription delivered after Stop"+                            Nothing -> expectationFailure "subscription did not stop after the final acknowledgement"+                    )+                    `finally` cancelStream++                Right rows <-+                    Store.runStoreIO store $+                        Store.runTransaction $+                            Tx.statement+                                ("orders-retry-exhaustion", 0)+                                KirokuSQL.readDeadLettersStmt+                case Vector.toList rows of+                    [row] -> do+                        row ^. #deadLetterReason+                            `shouldBe` object+                                [ "kind" Aeson..= ("max_attempts_exceeded" :: Text)+                                , "attempts" Aeson..= (2 :: Int)+                                ]+                        row ^. #deadLetterReasonSummary `shouldBe` "max retry attempts exceeded (2)"+                        row ^. #deadLetterAttemptCount `shouldBe` 2+                    other -> expectationFailure ("expected one Kiroku dead letter, got " <> show (Vector.length rows) <> ": " <> show other)++                _ <- forceFlushMeterProvider provider Nothing+                exported <- readIORef metricsRef+                lookup "keiro.subscription.deadlettered" (flattenScalarPoints exported)+                    `shouldBe` Just (IntNumber 1)+                readIORef forwarded >>= (`shouldSatisfy` (> 1))++    describe "Keiro.Stream" $ do+        it "wraps and unwraps kiroku stream names" $ do+            let orderStream = stream "order-123" :: Stream OrderStream+            Stream.streamName orderStream `shouldBe` StreamName "order-123"+            Stream.streamName (mapStreamName (\(StreamName name) -> StreamName (name <> "-archived")) orderStream)+                `shouldBe` StreamName "order-123-archived"++        it "validates categories, rejecting the dash boundary and reserved names" $ do+            fmap Stream.categoryText (Stream.category "incident" :: Either Stream.CategoryError (Stream.StreamCategory ()))+                `shouldBe` Right "incident"+            -- compound categories are camelCase; ':' (reserved for the wf: family) is also accepted+            fmap Stream.categoryText (Stream.category "hospitalSurge" :: Either Stream.CategoryError (Stream.StreamCategory ()))+                `shouldBe` Right "hospitalSurge"+            fmap Stream.categoryText (Stream.category "wf:fulfillment" :: Either Stream.CategoryError (Stream.StreamCategory ()))+                `shouldBe` Right "wf:fulfillment"+            (Stream.category "" :: Either Stream.CategoryError (Stream.StreamCategory ()))+                `shouldBe` Left Stream.CategoryEmpty+            (Stream.category "hospital-surge" :: Either Stream.CategoryError (Stream.StreamCategory ()))+                `shouldBe` Left (Stream.CategoryContainsSeparator "hospital-surge")+            (Stream.category "$all" :: Either Stream.CategoryError (Stream.StreamCategory ()))+                `shouldBe` Left (Stream.CategoryReserved "$all")+            (Stream.category "ord ers" :: Either Stream.CategoryError (Stream.StreamCategory ()))+                `shouldBe` Left (Stream.CategoryContainsIllegalChar ' ' "ord ers")+            (Stream.category "ord\ners" :: Either Stream.CategoryError (Stream.StreamCategory ()))+                `shouldBe` Left (Stream.CategoryContainsIllegalChar '\n' "ord\ners")++        it "builds entity streams that round-trip through kiroku's category rule" $ do+            let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream+            Stream.streamName (Stream.entityStream cat "1") `shouldBe` StreamName "orders-1"+            Stream.categoryName cat `shouldBe` CategoryName "orders"+            -- The category keiro reports equals kiroku's own parse of the produced+            -- name, even when the id segment itself contains a dash.+            Store.categoryName (Stream.streamName (Stream.entityStream cat "a-b-c"))+                `shouldBe` Stream.categoryName cat++        it "entityStreamId renders ids via StreamIdSegment (Text and String)" $ do+            let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream+            Stream.streamName (Stream.entityStreamId cat ("o-1" :: Text)) `shouldBe` StreamName "orders-o-1"+            Stream.streamName (Stream.entityStreamId cat ("o-1" :: String)) `shouldBe` StreamName "orders-o-1"++        it "rejects blank entity stream id segments" $ do+            let cat = Stream.categoryUnsafe "orders" :: Stream.StreamCategory OrderStream+            evaluate (Stream.streamName (Stream.entityStream cat "")) `shouldThrow` anyErrorCall+            evaluate (Stream.streamName (Stream.entityStream cat "   ")) `shouldThrow` anyErrorCall++    describe "Keiro.DeadLetter" $ around (withFreshStore fixture) $ do+        it "records a dispatch dead letter idempotently" $ \storeHandle -> do+            let deadLetter =+                    DispatchDeadLetter+                        { dispatcherKind = DispatcherProcessManager+                        , dispatcherName = "orders-pm"+                        , correlationId = "order-42"+                        , sourceEventId = EventId sampleUuid+                        , sourceGlobalPosition = GlobalPosition 17+                        , emitIndex = 0+                        , targetStreamName = StreamName "orders-42"+                        , errorClass = "command_rejected"+                        , errorDetail = Text.replicate 1100 "x"+                        , attemptCount = 2+                        }+            Right rows <-+                Store.runStoreIO storeHandle $ do+                    recordDispatchDeadLetter deadLetter+                    recordDispatchDeadLetter deadLetter+                    listDispatchDeadLetters "orders-pm"+            case rows of+                [row] -> do+                    row ^. #dispatcherKind `shouldBe` DispatcherProcessManager+                    row ^. #dispatcherName `shouldBe` "orders-pm"+                    row ^. #correlationId `shouldBe` "order-42"+                    row ^. #sourceEventId `shouldBe` EventId sampleUuid+                    row ^. #sourceGlobalPosition `shouldBe` GlobalPosition 17+                    row ^. #emitIndex `shouldBe` 0+                    row ^. #targetStreamName `shouldBe` StreamName "orders-42"+                    row ^. #errorClass `shouldBe` "command_rejected"+                    Text.length (row ^. #errorDetail) `shouldBe` 1024+                    row ^. #attemptCount `shouldBe` 2+                other -> expectationFailure ("expected one idempotent dead-letter row, got " <> show other)++    describe "Keiro.Codec" $ do+        it "encodes current events with type tags and schema-version metadata" $ do+            encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5))+            encoded ^. #eventType `shouldBe` EventType "OrderPlaced"+            encoded ^. #payload `shouldBe` object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)]+            extractSchemaVersion (recordedFrom encoded) `shouldBe` Right 2++        it "round-trips current events" $ do+            encoded <- shouldBeRight (encodeForAppend orderCodec (OrderPlaced "order-123" 5))+            decodeRecorded orderCodec (recordedFrom encoded) `shouldBe` Right (OrderPlaced "order-123" 5)++        it "decodes by the stored tag, not by payload shape (H1)" $ do+            let recorded =+                    recordedFrom+                        EventData+                            { eventId = Nothing+                            , eventType = EventType "CounterAudited"+                            , payload = object ["amount" Aeson..= (5 :: Int)]+                            , metadata = Just (metadataForOrDie 1 Nothing)+                            , causationId = Nothing+                            , correlationId = Nothing+                            }+            decodeRecorded counterCodec recorded `shouldBe` Right (CounterAudited 5)++        it "runs upcasters in source-version order" $+            decodeRaw orderCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)])+                `shouldBe` Right (OrderPlaced "order-123" 5)++        it "rejects gaps in upcaster chains" $+            decodeRaw gappyCodec (EventType "OrderPlaced") 1 (object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)])+                `shouldBe` Left (GapInUpcasterChain 2 3)++        it "validates codec construction invariants" $ do+            fmap (const ()) (mkCodec (orderCodec{schemaVersion = 0})) `shouldBe` Left (CodecSchemaVersionInvalid 0)+            fmap (const ()) (mkCodec (orderCodec{eventTypes = EventType "OrderPlaced" :| [EventType "OrderPlaced"]}))+                `shouldBe` Left (CodecDuplicateEventTypes [EventType "OrderPlaced"])+            fmap (const ()) (mkCodec (orderCodec{schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1), (1, const upcastOrderPlacedV1)]}))+                `shouldBe` Left (CodecDuplicateUpcasterSources [1])+            fmap (const ()) (mkCodec (orderCodec{schemaVersion = 3, upcasters = [(1, const upcastOrderPlacedV1)]}))+                `shouldBe` Left (CodecUpcasterChainIncomplete [2] 3)+            case mkCodec orderCodec of+                Right _ -> pure ()+                Left err -> expectationFailure ("expected orderCodec to validate, got " <> show err)++        it "rejects future-version, malformed metadata, and incomplete upcaster chains" $ do+            let v1Payload = object ["orderId" Aeson..= ("order-123" :: Text), "qty" Aeson..= (5 :: Int)]+                earlyEndCodec =+                    orderCodec+                        { schemaVersion = 4+                        , upcasters = [(1, const upcastOrderPlacedV1), (2, const Right)]+                        }+            decodeRaw orderCodec (EventType "OrderPlaced") 3 v1Payload+                `shouldBe` Left (VersionAhead 3 2)+            decodeRaw earlyEndCodec (EventType "OrderPlaced") 1 v1Payload+                `shouldBe` Left (IncompleteUpcasterChain 3 4)++            let malformedStamp =+                    recordedFrom+                        EventData+                            { eventId = Nothing+                            , eventType = EventType "OrderPlaced"+                            , payload = object ["orderId" Aeson..= ("order-123" :: Text), "quantity" Aeson..= (5 :: Int)]+                            , metadata = Just (object ["schemaVersion" Aeson..= ("2" :: Text)])+                            , causationId = Nothing+                            , correlationId = Nothing+                            }+            extractSchemaVersion malformedStamp+                `shouldBe` Left (MalformedSchemaVersionStamp (Aeson.String "2"))+            fmap (const ()) (encodeForAppendWithMetadata orderCodec (Just (Aeson.String "x")) (OrderPlaced "order-123" 5))+                `shouldBe` Left (NonObjectCallerMetadata (Aeson.String "x"))++        it "rejects recorded events with unknown type tags" $ do+            let encoded =+                    recordedFrom+                        EventData+                            { eventId = Nothing+                            , eventType = EventType "OrderCancelled"+                            , payload = object ["orderId" Aeson..= ("order-123" :: Text)]+                            , metadata = Just (metadataForOrDie 2 Nothing)+                            , causationId = Nothing+                            , correlationId = Nothing+                            }+            decodeRecorded orderCodec encoded+                `shouldBe` Left (UnknownEventType (EventType "OrderCancelled") [EventType "OrderPlaced"])++    describe "Keiro.EventStream" $ do+        it "constructs an author-facing EventStream contract" $ do+            let contract =+                    EventStream+                        { transducer = emptyTransducer+                        , initialState = Idle+                        , initialRegisters = RNil+                        , eventCodec = orderCodec+                        , resolveStreamName = \s -> Stream.streamName s+                        , snapshotPolicy = Never+                        , stateCodec = Nothing+                        }+                typedStream = stream "order-123" :: Stream (EventStream () '[] OrderState OrderCommand OrderEvent)+            contract ^. #initialState `shouldBe` Idle+            (contract ^. #resolveStreamName) typedStream `shouldBe` StreamName "order-123"++        it "evaluates snapshot policies with explicit terminality" $ do+            shouldSnapshot (Every 2) NotTerminal () (StreamVersion 0) `shouldBe` False+            shouldSnapshot (Every 2) NotTerminal () (StreamVersion 2) `shouldBe` True+            shouldSnapshot OnTerminal Terminal () (StreamVersion 1) `shouldBe` True+            shouldSnapshot OnTerminal NotTerminal () (StreamVersion 1) `shouldBe` False+            shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) Terminal () (StreamVersion 1)+                `shouldBe` True+            shouldSnapshot (Custom (\terminality _ _ -> terminality == Terminal)) NotTerminal () (StreamVersion 1)+                `shouldBe` False+            shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 2) (StreamVersion 4)+                `shouldBe` True+            shouldSnapshotSpan (Every 3) NotTerminal () (StreamVersion 4) (StreamVersion 5)+                `shouldBe` False++        it "rejects snapshot policies without a state codec" $ do+            let contract :: CounterEventStream+                contract = counterEventStreamDef{snapshotPolicy = Every 10, stateCodec = Nothing}+            fmap (const ()) (mkEventStream "snapshotless" contract)+                `shouldBe` Left [EventStreamWarning "snapshotless" "snapshotPolicy is set but stateCodec is Nothing; snapshots would never be written"]++    describe "EventStream replay-safety (validateEventStream)" $ do+        it "every production-intent stream validates clean" $+            concat+                [ validateEventStream "counter" counterEventStreamDef+                , validateEventStream "counter-no-op" noOpCounterEventStreamDef+                , validateEventStream "counter-multi" multiCounterEventStreamDef+                , validateEventStream "counter-ambiguous" ambiguousCounterEventStreamDef+                , validateEventStream "snapshot-counter" snapshotCounterEventStreamDef+                , validateEventStream "snapshot-counter-multi" multiSnapshotCounterEventStreamDef+                , validateEventStream "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef+                , validateEventStream "pm-snapshot-counter" pmSnapshotCounterEventStreamDef+                , validateEventStream "rejecting-counter" rejectingEventStreamDef+                ]+                `shouldBe` []++    describe "mkEventStream" $ do+        it "rejects a hidden-input stream by label" $ do+            let warns = validateEventStream "broken" brokenHiddenInputEventStream+            warns `shouldNotBe` []+            map eswStreamLabel warns `shouldSatisfy` all (== "broken")+            map eswReason warns `shouldSatisfy` any (Text.isInfixOf "hidden-input")+            case mkEventStream "broken" brokenHiddenInputEventStream of+                Left ws -> do+                    map eswStreamLabel ws `shouldSatisfy` all (== "broken")+                    map eswReason ws `shouldSatisfy` any (Text.isInfixOf "hidden-input")+                Right _ -> expectationFailure "expected mkEventStream to reject the hidden-input stream"++        it "rejects a head-unrecoverable multi-event stream" $+            expectValidationWarning+                "head-unrecoverable"+                "head-unrecoverable"+                headUnrecoverableEventStreamDef++        it "rejects replay inversion ambiguity" $+            expectValidationWarning+                "inversion-ambiguity"+                "inversion-ambiguity"+                inversionAmbiguousEventStreamDef++        it "rejects an unguarded command-field read" $+            expectValidationWarning+                "unguarded-input-read"+                "unguarded-input-read"+                unguardedInputReadEventStreamDef++        it "rejects a silent edge that writes registers" $ do+            Keiki.validateTransducer Keiki.defaultValidationOptions stateChangingEpsilonTransducer+                `shouldSatisfy` any isStateChangingEpsilon+            expectValidationWarning+                "state-changing-epsilon"+                "state-changing-epsilon"+                stateChangingEpsilonEventStreamDef++        it "rejects a silent edge that changes vertex" $ do+            Keiki.validateTransducer Keiki.defaultValidationOptions silentMoveTransducer+                `shouldSatisfy` any isStateChangingEpsilon+            expectValidationWarning+                "silent-move"+                "state-changing-epsilon"+                silentMoveEventStreamDef++        it "keeps replay-contract checks enabled when caller options weaken them" $ do+            case mkEventStreamWith+                Keiki.defaultValidationOptions{Keiki.checkStateChangingEpsilon = False}+                "silent-move-weakened"+                silentMoveEventStreamDef of+                Left warnings ->+                    map eswReason warnings+                        `shouldSatisfy` any (Text.isInfixOf "state-changing-epsilon")+                Right _ -> expectationFailure "expected the durable boundary to restore the state-changing-epsilon check"+            case mkEventStreamWith+                Keiki.defaultValidationOptions{Keiki.checkHeadRecoverability = False}+                "head-unrecoverable-weakened"+                headUnrecoverableEventStreamDef of+                Left warnings ->+                    map eswReason warnings+                        `shouldSatisfy` any (Text.isInfixOf "head-unrecoverable")+                Right _ -> expectationFailure "expected the durable boundary to restore the head-recoverability check"++        it "provides a loudly named unchecked escape hatch" $ do+            _ <- evaluate (mkEventStreamUnchecked silentMoveEventStreamDef)+            pure ()++        it "accepts every production-intent stream" $ do+            let expectAccepted label eventStream =+                    case mkEventStream label eventStream of+                        Right _ -> pure ()+                        Left ws -> expectationFailure ("expected mkEventStream to accept " <> Text.unpack label <> ", got " <> show ws)+            expectAccepted "counter" counterEventStreamDef+            expectAccepted "counter-no-op" noOpCounterEventStreamDef+            expectAccepted "counter-multi" multiCounterEventStreamDef+            expectAccepted "counter-ambiguous" ambiguousCounterEventStreamDef+            expectAccepted "snapshot-counter" snapshotCounterEventStreamDef+            expectAccepted "snapshot-counter-multi" multiSnapshotCounterEventStreamDef+            expectAccepted "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef+            expectAccepted "pm-snapshot-counter" pmSnapshotCounterEventStreamDef+            expectAccepted "rejecting-counter" rejectingEventStreamDef++        it "rejects a snapshot codec whose initial register file contains an uninitialized slot" $ do+            case mkEventStream "uninitialized-snapshot" uninitializedSnapshotEventStreamDef of+                Left warns -> do+                    map eswStreamLabel warns `shouldSatisfy` all (== "uninitialized-snapshot")+                    map eswReason warns `shouldSatisfy` any (Text.isInfixOf "cannot encode the initial state/registers")+                    map eswReason warns `shouldSatisfy` any (Text.isInfixOf "uninit: neverWritten")+                Right _ -> expectationFailure "expected mkEventStream to reject an uninitialized snapshot register"++        it "accepts the same snapshot stream when every initial register is initialized" $ do+            case mkEventStream "initialized-snapshot" initializedSnapshotEventStreamDef of+                Right _ -> pure ()+                Left warns -> expectationFailure ("expected initialized snapshot registers to validate, got " <> show warns)++        it "rejects a bare EventStream at runCommand (compile-time)" $ do+            (exitCode, _stdout, stderr) <-+                readProcessWithExitCode+                    "cabal"+                    [ "exec"+                    , "ghc"+                    , "--"+                    , "-fno-code"+                    , "-package"+                    , "keiro"+                    , "test/ReplaySafetyTypeProbe.hs"+                    ]+                    ""+            exitCode `shouldSatisfy` (/= ExitSuccess)+            stderr `shouldSatisfy` ("ValidatedEventStream" `isInfixOf`)++    describe "Keiro.Command" $ around (withFreshStore fixture) $ do+        it "creates a stream and appends the first command event" $ \storeHandle -> do+            let target = stream "counter-command-create" :: Stream CounterEventStream+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 2)+            case result of+                Right (Right commandResult) -> do+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 1+                    commandResult ^. #eventsAppended `shouldBe` 1+                    commandResult ^. #globalPosition `shouldSatisfy` isJust+                other -> expectationFailure ("expected successful command, got " <> show other)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "counter-command-create") (StreamVersion 0) 10+            Vector.length recorded `shouldBe` 1+            traverse (decodeRecorded counterCodec) (Vector.toList recorded)+                `shouldBe` Right [CounterAdded 2]++        it "reports no global position for a no-op after prior events" $ \storeHandle -> do+            let target = stream "skip-command-no-op-position" :: Stream SkipEventStream+            Right (Right appended) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions skipEventStream target (SAdd 2)+            appended ^. #globalPosition `shouldSatisfy` isJust+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions skipEventStream target SSkip+            case result of+                Right (Right noOp) -> do+                    noOp ^. #streamVersion `shouldBe` StreamVersion 1+                    noOp ^. #eventsAppended `shouldBe` 0+                    noOp ^. #globalPosition `shouldBe` Nothing+                other -> expectationFailure ("expected successful no-op command, got " <> show other)++        it "surfaces runtime edge ambiguity without appending" $ \storeHandle -> do+            (processor, spansRef) <- inMemoryListExporter+            provider <- createTracerProvider [processor] emptyTracerProviderOptions+            let tracer = makeTracer provider "keiro-test" tracerOptions+                target = stream "counter-command-ambiguous" :: Stream CounterEventStream+                options = defaultRunCommandOptions & #tracer ?~ tracer+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options ambiguousCounterEventStream target (Add 1)+            _ <- shutdownTracerProvider provider Nothing+            result `shouldBe` Right (Left (CommandAmbiguous [0, 1]))+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "counter-command-ambiguous") (StreamVersion 0) 10+            recorded `shouldBe` Vector.empty+            spans <- traverse captureSpan =<< readIORef spansRef+            case spans of+                [sp] -> textAttr (csAttributes sp) "error.type" `shouldBe` Just "command_ambiguous"+                other -> expectationFailure ("expected one span, got " <> show (length other))++        it "rehydrates prior events before appending a second command event" $ \storeHandle -> do+            let target = stream "counter-command-update" :: Stream CounterEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 2)+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 3)+            case result of+                Right (Right commandResult) ->+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 2+                other -> expectationFailure ("expected successful second command, got " <> show other)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "counter-command-update") (StreamVersion 0) 10+            traverse (decodeRecorded counterCodec) (Vector.toList recorded)+                `shouldBe` Right [CounterAdded 2, CounterAdded 3]++        it "rejects hydration after truncation without a covering snapshot" $ \storeHandle -> do+            let target = stream "counter-truncated-uncovered" :: Stream CounterEventStream+                targetName = StreamName "counter-truncated-uncovered"+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 1)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 2)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 3)+            Right (Just _) <-+                Store.runStoreIO storeHandle $+                    Store.setStreamTruncateBefore targetName (StreamVersion 3)+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 4)+            case result of+                Right (Left (HydrationGapDetected expected observed)) -> do+                    expected `shouldBe` StreamVersion 1+                    observed `shouldBe` StreamVersion 3+                other -> expectationFailure ("expected HydrationGapDetected, got " <> show other)++        it "rejects hydration when truncation lands inside a command batch" $ \storeHandle -> do+            let target = stream "counter-truncated-mid-batch" :: Stream CounterEventStream+                targetName = StreamName "counter-truncated-mid-batch"+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1)+            Right (Just _) <-+                Store.runStoreIO storeHandle $+                    Store.setStreamTruncateBefore targetName (StreamVersion 2)+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2)+            case result of+                Right (Left (HydrationGapDetected expected observed)) -> do+                    expected `shouldBe` StreamVersion 1+                    observed `shouldBe` StreamVersion 2+                other -> expectationFailure ("expected HydrationGapDetected, got " <> show other)++        it "hydrates normally after truncation covered by a snapshot" $ \storeHandle -> do+            let target = stream "counter-truncated-covered" :: Stream SnapshotCounterEventStream+                targetName = StreamName "counter-truncated-covered"+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2)+            Right (Just _) <-+                Store.runStoreIO storeHandle $+                    Store.setStreamTruncateBefore targetName (StreamVersion 2)+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3)+            case result of+                Right (Right commandResult) ->+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 3+                other -> expectationFailure ("expected snapshot-covered command success, got " <> show other)++        it "uses caller-supplied event ids for idempotent command batches" $ \storeHandle -> do+            let target = stream "counter-command-event-id" :: Stream CounterEventStream+                supplied = EventId sampleUuid2+                options = defaultRunCommandOptions & #eventIds .~ [supplied]+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options counterEventStream target (Add 7)+            case result of+                Right (Right commandResult) ->+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 1+                other -> expectationFailure ("expected successful command, got " <> show other)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "counter-command-event-id") (StreamVersion 0) 10+            fmap (^. #eventId) (Vector.toList recorded) `shouldBe` [supplied]++        it "retries an optimistic conflict after rehydrating the winning event" $ \storeHandle -> do+            conflictInserted <- newIORef False+            let target = stream "counter-command-conflict" :: Stream CounterEventStream+                conflictStreamName = StreamName "counter-command-conflict"+                insertConflict = do+                    shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted ->+                        if alreadyInserted+                            then (True, False)+                            else (True, True)+                    when shouldInsert $ do+                        encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10))+                        outcome <-+                            Store.runStoreIO storeHandle $+                                Store.appendToStream conflictStreamName NoStream [encoded]+                        case outcome of+                            Right _ -> pure ()+                            Left err -> expectationFailure ("failed to insert conflict event: " <> show err)+                options = defaultRunCommandOptions & #beforeAppend .~ insertConflict+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options counterEventStream target (Add 2)+            case result of+                Right (Right commandResult) -> do+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 2+                    commandResult ^. #eventsAppended `shouldBe` 1+                other -> expectationFailure ("expected retry to succeed, got " <> show other)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward conflictStreamName (StreamVersion 0) 10+            traverse (decodeRecorded counterCodec) (Vector.toList recorded)+                `shouldBe` Right [CounterAdded 10, CounterAdded 2]++        it "reports true retry attempts and command conflict metrics when the retry budget is exhausted" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let target = stream "counter-command-exhausted-conflict" :: Stream CounterEventStream+                conflictStreamName = StreamName "counter-command-exhausted-conflict"+                insertConflict = do+                    encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10))+                    outcome <-+                        Store.runStoreIO storeHandle $+                            Store.appendToStream conflictStreamName AnyVersion [encoded]+                    case outcome of+                        Right _ -> pure ()+                        Left err -> expectationFailure ("failed to insert conflict event: " <> show err)+                options =+                    defaultRunCommandOptions+                        & #beforeAppend+                        .~ insertConflict+                        & #retryLimit+                        .~ 2+                        & #retryBackoffMicros+                        .~ 0+                        & #metrics+                        ?~ keiroMetrics+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options counterEventStream target (Add 2)+            case result of+                Right (Left (RetryExhausted attempts _)) ->+                    attempts `shouldBe` 3+                other -> expectationFailure ("expected exhausted retry budget, got " <> show other)+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+            lookup "keiro.command.conflicts" scalars `shouldBe` Just (IntNumber 3)+            lookup "keiro.command.retries" scalars `shouldBe` Just (IntNumber 2)++        it "records the successful retry attempt on the command span" $ \storeHandle -> do+            (processor, spansRef) <- inMemoryListExporter+            provider <- createTracerProvider [processor] emptyTracerProviderOptions+            conflictInserted <- newIORef False+            let tracer = makeTracer provider "keiro-test" tracerOptions+                target = stream "counter-command-retry-span" :: Stream CounterEventStream+                conflictStreamName = StreamName "counter-command-retry-span"+                insertConflict = do+                    shouldInsert <- atomicModifyIORef' conflictInserted $ \alreadyInserted ->+                        if alreadyInserted+                            then (True, False)+                            else (True, True)+                    when shouldInsert $ do+                        encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 10))+                        outcome <-+                            Store.runStoreIO storeHandle $+                                Store.appendToStream conflictStreamName NoStream [encoded]+                        case outcome of+                            Right _ -> pure ()+                            Left err -> expectationFailure ("failed to insert conflict event: " <> show err)+                options =+                    defaultRunCommandOptions+                        & #beforeAppend+                        .~ insertConflict+                        & #retryBackoffMicros+                        .~ 0+                        & #tracer+                        ?~ tracer+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options counterEventStream target (Add 2)+            _ <- shutdownTracerProvider provider Nothing+            spans <- traverse captureSpan =<< readIORef spansRef+            case spans of+                [sp] ->+                    case lookupAttribute (csAttributes sp) "keiro.retry.attempt" of+                        Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 2+                        other -> expectationFailure ("expected retry attempt attribute 2, got " <> show other)+                other -> expectationFailure ("expected one span, got " <> show (length other))++        it "counts duplicate deterministic command events" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let supplied = EventId sampleUuid3+                first = stream "counter-command-duplicate-a" :: Stream CounterEventStream+                second = stream "counter-command-duplicate-b" :: Stream CounterEventStream+                options =+                    defaultRunCommandOptions+                        & #eventIds+                        .~ [supplied]+                        & #metrics+                        ?~ keiroMetrics+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options counterEventStream first (Add 1)+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options counterEventStream second (Add 2)+            case result of+                Right (Left (StoreFailed Store.DuplicateEvent{})) -> pure ()+                other -> expectationFailure ("expected duplicate event failure, got " <> show other)+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            lookup "keiro.command.duplicates" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++        it "fails fast when a soft-deleted stream causes a conflict fixpoint" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let target = stream "counter-command-soft-deleted" :: Stream CounterEventStream+                options =+                    defaultRunCommandOptions+                        & #retryBackoffMicros+                        .~ 0+                        & #metrics+                        ?~ keiroMetrics+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options counterEventStream target (Add 1)+            Right (Just _) <-+                Store.runStoreIO storeHandle $+                    Store.softDeleteStream (StreamName "counter-command-soft-deleted")+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options counterEventStream target (Add 2)+            case result of+                Right (Left (ConflictFixpoint (StreamVersion 0) Store.StreamAlreadyExists{})) -> pure ()+                other -> expectationFailure ("expected conflict fixpoint, got " <> show other)+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            lookup "keiro.command.conflicts" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++        it "surfaces decode failure during hydration" $ \storeHandle -> do+            Right _ <-+                Store.runStoreIO storeHandle $+                    Store.appendToStream+                        (StreamName "counter-command-decode-failure")+                        NoStream+                        [ EventData+                            { eventId = Nothing+                            , eventType = EventType "OtherEvent"+                            , payload = object []+                            , metadata = Just (metadataForOrDie 1 Nothing)+                            , causationId = Nothing+                            , correlationId = Nothing+                            }+                        ]+            let target = stream "counter-command-decode-failure" :: Stream CounterEventStream+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 1)+            result+                `shouldBe` Right+                    (Left (HydrationDecodeFailed (UnknownEventType (EventType "OtherEvent") [EventType "CounterAdded", EventType "CounterAudited"])))++        it "surfaces a typed no-inverting-edge hydration failure" $ \storeHandle -> do+            let targetStreamName = StreamName "counter-command-no-inverting-edge"+                target = stream "counter-command-no-inverting-edge" :: Stream CounterEventStream+            appendCounterEvents storeHandle targetStreamName [CounterAudited 7]+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 1)+            result+                `shouldBe` Right+                    (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge))++        it "surfaces a typed queue-mismatch hydration failure with the failing version" $ \storeHandle -> do+            let targetStreamName = StreamName "counter-command-queue-mismatch"+                target = stream "counter-command-queue-mismatch" :: Stream CounterEventStream+            appendCounterEvents storeHandle targetStreamName [CounterAdded 5, CounterAudited 6]+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1)+            result+                `shouldBe` Right+                    (Left (HydrationReplayFailed (StreamVersion 2) HydrationQueueMismatch))++        it "surfaces a truncated multi-event chain as HydrationTruncatedChain" $ \storeHandle -> do+            let targetStreamName = StreamName "counter-command-truncated-chain"+                target = stream "counter-command-truncated-chain" :: Stream CounterEventStream+            appendCounterEvents storeHandle targetStreamName [CounterAdded 5]+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions multiCounterEventStream target (Add 1)+            result+                `shouldBe` Right+                    (Left (HydrationReplayFailed (StreamVersion 1) HydrationTruncatedChain))++        it "surfaces ambiguous inversion during hydration" $ \storeHandle -> do+            let targetStreamName = StreamName "counter-command-ambiguous-inversion"+                target = stream "counter-command-ambiguous-inversion" :: Stream CounterEventStream+            appendCounterEvents storeHandle targetStreamName [CounterAdded 3]+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions inversionAmbiguousEventStream target (Add 1)+            result+                `shouldBe` Right+                    (Left (HydrationReplayFailed (StreamVersion 1) HydrationAmbiguousInversion))++        it "truncates command span error status descriptions" $ \storeHandle -> do+            (processor, spansRef) <- inMemoryListExporter+            provider <- createTracerProvider [processor] emptyTracerProviderOptions+            let tracer = makeTracer provider "keiro-test" tracerOptions+                longTag = Text.replicate 400 "x"+            Right _ <-+                Store.runStoreIO storeHandle $+                    Store.appendToStream+                        (StreamName "counter-command-long-decode-failure")+                        NoStream+                        [ EventData+                            { eventId = Nothing+                            , eventType = EventType longTag+                            , payload = object []+                            , metadata = Just (metadataForOrDie 1 Nothing)+                            , causationId = Nothing+                            , correlationId = Nothing+                            }+                        ]+            let target = stream "counter-command-long-decode-failure" :: Stream CounterEventStream+                options = defaultRunCommandOptions & #tracer ?~ tracer+            _ <-+                Store.runStoreIO storeHandle $+                    runCommand options counterEventStream target (Add 1)+            _ <- shutdownTracerProvider provider Nothing+            spans <- traverse captureSpan =<< readIORef spansRef+            case spans of+                [sp] ->+                    case csStatus sp of+                        Error description -> Text.length description `shouldSatisfy` (<= 256)+                        other -> expectationFailure ("expected error span status, got " <> show other)+                other -> expectationFailure ("expected one span, got " <> show (length other))++        it "rolls back the append when inline SQL condemns the transaction" $ \_ ->+            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+                let target = stream "counter-command-rollback" :: Stream CounterEventStream+                result <-+                    runner $+                        runCommandWithSql+                            defaultRunCommandOptions+                            counterEventStream+                            target+                            (Add 1)+                            (\_ -> Tx.condemn >> pure ("rolled-back" :: Text))+                case result of+                    Right (Right (_, Just "rolled-back")) -> pure ()+                    other -> expectationFailure ("expected condemned transaction result, got " <> show other)+                Right recorded <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "counter-command-rollback") (StreamVersion 0) 10+                recorded `shouldBe` Vector.empty++        it "appends all events emitted by one accepted command" $ \storeHandle -> do+            let target = stream "counter-command-multi-create" :: Stream CounterEventStream+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions multiCounterEventStream target (Add 5)+            case result of+                Right (Right commandResult) -> do+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 2+                    commandResult ^. #eventsAppended `shouldBe` 2+                    commandResult ^. #globalPosition `shouldSatisfy` isJust+                other -> expectationFailure ("expected successful multi-event command, got " <> show other)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "counter-command-multi-create") (StreamVersion 0) 10+            traverse (decodeRecorded counterCodec) (Vector.toList recorded)+                `shouldBe` Right [CounterAdded 5, CounterAudited 5]++        it "counts and traces a just-appended batch that cannot replay" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (metricProvider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter metricProvider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            (processor, spansRef) <- inMemoryListExporter+            tracerProvider <- createTracerProvider [processor] emptyTracerProviderOptions+            let tracer = makeTracer tracerProvider "keiro-test" tracerOptions+                target = stream "counter-command-replay-divergence" :: Stream CounterEventStream+                options =+                    defaultRunCommandOptions+                        & #metrics+                        ?~ keiroMetrics+                        & #tracer+                        ?~ tracer+            Right (Right commandResult) <-+                Store.runStoreIO storeHandle $+                    runCommand options headUnrecoverableEventStream target (Add 2)+            commandResult ^. #streamVersion `shouldBe` StreamVersion 2+            commandResult ^. #eventsAppended `shouldBe` 2+            _ <- forceFlushMeterProvider metricProvider Nothing+            exported <- readIORef metricsRef+            lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported)+                `shouldBe` Just (IntNumber 1)+            next <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions headUnrecoverableEventStream target (Add 3)+            case next of+                Right (Left HydrationReplayFailed{}) -> pure ()+                other -> expectationFailure ("expected the witnessed divergence to poison hydration, got " <> show other)+            _ <- shutdownTracerProvider tracerProvider Nothing+            spans <- traverse captureSpan =<< readIORef spansRef+            case spans of+                [sp] ->+                    textAttr (csAttributes sp) "keiro.replay.divergence"+                        `shouldBe` Just "event_index=0;reason=no_inverting_edge"+                other -> expectationFailure ("expected one divergence span, got " <> show (length other))++        it "skips replay verification for a snapshot-less stream when disabled" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let target = stream "counter-command-replay-divergence-disabled" :: Stream CounterEventStream+                options =+                    defaultRunCommandOptions+                        & #metrics+                        ?~ keiroMetrics+                        & #verifyReplayOnAppend+                        .~ False+            Right (Right commandResult) <-+                Store.runStoreIO storeHandle $+                    runCommand options headUnrecoverableEventStream target (Add 2)+            commandResult ^. #eventsAppended `shouldBe` 2+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported)+                `shouldBe` Nothing++        it "witnesses replay divergence on the transactional SQL append path" $ \_ ->+            withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+                (exporter, metricsRef) <- inMemoryMetricExporter+                (provider, _env) <-+                    createMeterProvider+                        emptyMaterializedResources+                        defaultSdkMeterProviderOptions{metricExporter = Just exporter}+                meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+                keiroMetrics <- Telemetry.newKeiroMetrics meter+                let target = stream "counter-command-replay-divergence-sql" :: Stream CounterEventStream+                    options = defaultRunCommandOptions & #metrics ?~ keiroMetrics+                Right (Right (commandResult, Just ())) <-+                    runner $+                        runCommandWithSqlEvents+                            options+                            headUnrecoverableEventStream+                            target+                            (Add 2)+                            (\_ _ -> pure ())+                commandResult ^. #eventsAppended `shouldBe` 2+                _ <- forceFlushMeterProvider provider Nothing+                exported <- readIORef metricsRef+                lookup "keiro.snapshot.apply.divergence" (flattenScalarPoints exported)+                    `shouldBe` Just (IntNumber 1)++        it "replays a prior multi-event command before appending the next batch" $ \storeHandle -> do+            let target = stream "counter-command-multi-replay" :: Stream CounterEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions multiCounterEventStream target (Add 2)+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions multiCounterEventStream target (Add 3)+            case result of+                Right (Right commandResult) -> do+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 4+                    commandResult ^. #eventsAppended `shouldBe` 2+                other -> expectationFailure ("expected successful second multi-event command, got " <> show other)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "counter-command-multi-replay") (StreamVersion 0) 10+            traverse (decodeRecorded counterCodec) (Vector.toList recorded)+                `shouldBe` Right [CounterAdded 2, CounterAudited 2, CounterAdded 3, CounterAudited 3]++        it "passes the complete multi-event batch to inline SQL in append order" $ \_ ->+            withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+                let target = stream "counter-command-multi-sql-events" :: Stream CounterEventStream+                result <-+                    runner $+                        runCommandWithSqlEvents+                            defaultRunCommandOptions+                            multiCounterEventStream+                            target+                            (Add 8)+                            (\pairs _ -> pure (Prelude.map Prelude.fst pairs))+                case result of+                    Right (Right (commandResult, Just observed)) -> do+                        commandResult ^. #streamVersion `shouldBe` StreamVersion 2+                        commandResult ^. #eventsAppended `shouldBe` 2+                        observed `shouldBe` [CounterAdded 8, CounterAudited 8]+                    other -> expectationFailure ("expected successful SQL multi-event command, got " <> show other)++        it "command metadata is merged into stored event metadata" $ \storeHandle -> do+            let target = stream "counter-command-metadata" :: Stream CounterEventStream+                opts =+                    defaultRunCommandOptions+                        & #metadata+                        ?~ object ["actor" Aeson..= ("agent-7" :: Text)]+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand opts counterEventStream target (Add 4)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "counter-command-metadata") (StreamVersion 0) 10+            case Vector.toList recorded of+                [event] ->+                    event ^. #metadata+                        `shouldBe` Just (object ["actor" Aeson..= ("agent-7" :: Text), "schemaVersion" Aeson..= (1 :: Int)])+                other -> expectationFailure ("expected a single recorded event, got " <> show other)++        it "reconstructed RecordedEvents match the stored batch" $ \_ ->+            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+                let target = stream "counter-reconstruct-fidelity" :: Stream CounterEventStream+                    opts =+                        defaultRunCommandOptions+                            & #metadata+                            ?~ object ["actor" Aeson..= ("agent-7" :: Text)]+                Right (Right (_, Just pairs)) <-+                    runner $+                        runCommandWithSqlEvents opts multiCounterEventStream target (Add 8) (\ps _ -> pure ps)+                let reconstructed = Prelude.map Prelude.snd pairs+                -- Read the stored events back from their source stream.+                Right storedVec <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "counter-reconstruct-fidelity") (StreamVersion 0) 10+                let stored = Vector.toList storedVec+                -- readStreamForward reports globalPosition 0 for stream reads, so take+                -- the true global positions from a category read (the DB is fresh per+                -- test, so category "counter" holds exactly this batch).+                Right catVec <-+                    Store.runStoreIO storeHandle $+                        Store.readCategory (CategoryName "counter") (GlobalPosition 0) 10+                let catList = Vector.toList catVec+                Prelude.length reconstructed `shouldBe` 2+                Prelude.length stored `shouldBe` 2+                fmap (^. #eventId) reconstructed `shouldBe` fmap (^. #eventId) stored+                fmap (^. #eventType) reconstructed `shouldBe` fmap (^. #eventType) stored+                fmap (^. #streamVersion) reconstructed `shouldBe` fmap (^. #streamVersion) stored+                fmap (^. #originalVersion) reconstructed `shouldBe` fmap (^. #originalVersion) stored+                fmap (^. #originalStreamId) reconstructed `shouldBe` fmap (^. #originalStreamId) stored+                fmap (^. #payload) reconstructed `shouldBe` fmap (^. #payload) stored+                fmap (^. #metadata) reconstructed `shouldBe` fmap (^. #metadata) stored+                fmap (^. #globalPosition) reconstructed `shouldBe` fmap (^. #globalPosition) catList++        it "runCommand emits a Command span with the stream name, db.system.name, and keiro.events.appended" $ \storeHandle -> do+            (processor, spansRef) <- inMemoryListExporter+            provider <- createTracerProvider [processor] emptyTracerProviderOptions+            let tracer = makeTracer provider "keiro-test" tracerOptions+                target = stream "counter-command-otel" :: Stream CounterEventStream+                options = defaultRunCommandOptions & #tracer ?~ tracer+            Right (Right commandResult) <-+                Store.runStoreIO storeHandle $+                    runCommand options counterEventStream target (Add 9)+            commandResult ^. #streamVersion `shouldBe` StreamVersion 1+            _ <- shutdownTracerProvider provider Nothing+            spans <- traverse captureSpan =<< readIORef spansRef+            length spans `shouldBe` 1+            let sp = case spans of+                    (s : _) -> s+                    [] -> error "no command span captured"+            csName sp `shouldBe` "counter-command-otel"+            show (csKind sp) `shouldBe` "Internal"+            textAttr (csAttributes sp) "keiro.stream.name" `shouldBe` Just "counter-command-otel"+            textAttr (csAttributes sp) "db.system.name" `shouldBe` Just "postgresql"+            -- keiro.events.appended is an Int64 attribute, not Text.+            case lookupAttribute (csAttributes sp) "keiro.events.appended" of+                Just (AttributeValue (IntAttribute n)) -> n `shouldBe` 1+                other -> expectationFailure ("expected IntAttribute 1, got " <> show other)+            case csStatus sp of+                Unset -> pure ()+                Ok -> pure ()+                other -> expectationFailure ("expected Unset/Ok, got " <> show other)++    describe "Keiro.Command enrichment parity" $ do+        let addMarker eventData = pure (eventData & #metadata %~ injectMarker)+            injectMarker = \case+                Just (Aeson.Object fields) ->+                    Just (Aeson.Object (KeyMap.insert "enriched" (Aeson.Bool True) fields))+                _ -> Just (object ["enriched" Aeson..= True])+            installHook = #storeSettings . #enrichEvent ?~ addMarker+            hasMarker = \case+                Just (Aeson.Object fields) ->+                    KeyMap.lookup "enriched" fields == Just (Aeson.Bool True)+                _ -> False+        around (withFreshResourceStoreWith fixture installHook) $+            it "applies the store enrichment hook to both command append paths" $ \(_storeHandle, StoreRunner runner) -> do+                let plainTarget = stream "enrich-plain" :: Stream CounterEventStream+                    transactionalTarget = stream "enrich-transactional" :: Stream CounterEventStream+                Right (Right _) <-+                    runner $+                        runCommand defaultRunCommandOptions counterEventStream plainTarget (Add 1)+                Right (Right (_, Just callbackRecordeds)) <-+                    runner $+                        runCommandWithSqlEvents+                            defaultRunCommandOptions+                            counterEventStream+                            transactionalTarget+                            (Add 1)+                            (\pairs _ -> pure (fmap snd pairs))+                Right plainEvents <-+                    runner $+                        Store.readStreamForward (StreamName "enrich-plain") (StreamVersion 0) 10+                Right transactionalEvents <-+                    runner $+                        Store.readStreamForward (StreamName "enrich-transactional") (StreamVersion 0) 10+                for_ (Vector.toList plainEvents <> Vector.toList transactionalEvents) $ \recorded ->+                    recorded ^. #metadata `shouldSatisfy` hasMarker+                for_ callbackRecordeds $ \recorded ->+                    recorded ^. #metadata `shouldSatisfy` hasMarker++    describe "Keiro.Snapshot" $ around (withFreshStore fixture) $ do+        it "reports an ErrorCall when strict encoding reaches an empty register slot" $ \_storeHandle -> do+            result <-+                encodeSnapshotStrict+                    (defaultStateCodec @SnapshotCounterRegs @CounterState 1)+                    (Counting, emptyRegFile @SnapshotCounterRegs)+            case result of+                Left err -> displayException err `shouldSatisfy` isInfixOf "uninit: lastAmount"+                Right _ -> expectationFailure "expected strict snapshot encoding to fail on an empty register slot"++        it "writes a snapshot after policy threshold" $ \storeHandle -> do+            let target = stream "snapshot-write-threshold" :: Stream SnapshotCounterEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3)+            Right snapshotVersion <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "snapshot-write-threshold" snapshotVersionForStreamStmt+            snapshotVersion `shouldBe` Just (StreamVersion 2)++        it "does not fail a committed command when the post-commit snapshot write fails" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let target = stream "snapshot-write-failure-swallowed" :: Stream SnapshotCounterEventStream+                options = defaultRunCommandOptions & #metrics ?~ keiroMetrics+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 2)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID"+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 3)+            case result of+                Right (Right commandResult) -> do+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 2+                    commandResult ^. #eventsAppended `shouldBe` 1+                other -> expectationFailure ("expected committed command despite snapshot failure, got " <> show other)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "snapshot-write-failure-swallowed") (StreamVersion 0) 10+            traverse (decodeRecorded counterCodec) (Vector.toList recorded)+                `shouldBe` Right [CounterAdded 2, CounterAdded 3]+            Right snapshotVersionDuringFailure <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt+            snapshotVersionDuringFailure `shouldBe` Nothing+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes"+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 4)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 5)+            Right snapshotVersionAfterRecovery <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "snapshot-write-failure-swallowed" snapshotVersionForStreamStmt+            snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 4)++        it "does not fail a committed command when strict snapshot encoding fails" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let target = stream "snapshot-encode-failure-swallowed" :: Stream PartialSnapshotEventStream+                options = defaultRunCommandOptions & #metrics ?~ keiroMetrics+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options partialSnapshotEventStream target (Add 7)+            case result of+                Right (Right commandResult) -> do+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 1+                    commandResult ^. #eventsAppended `shouldBe` 1+                other -> expectationFailure ("expected committed command despite snapshot encode failure, got " <> show other)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "snapshot-encode-failure-swallowed") (StreamVersion 0) 10+            traverse (decodeRecorded counterCodec) (Vector.toList recorded)+                `shouldBe` Right [CounterAdded 7]+            Right snapshotVersion <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "snapshot-encode-failure-swallowed" snapshotVersionForStreamStmt+            snapshotVersion `shouldBe` Nothing+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+            lookup "keiro.snapshot.encode.failures" scalars `shouldBe` Just (IntNumber 1)+            lookup "keiro.snapshot.write.failures" scalars `shouldBe` Nothing++        it "hydrates from snapshot and replays only the tail" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let target = stream "snapshot-tail-hydration" :: Stream SnapshotCounterEventStream+                options = defaultRunCommandOptions & #metrics ?~ keiroMetrics+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 2)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 3)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement+                            ( "snapshot-tail-hydration"+                            , (defaultStateCodec @SnapshotCounterRegs @CounterState 1 ^. #encode)+                                (Counting, RCons (Proxy @"lastAmount") 4 RNil)+                            )+                            corruptSnapshotStateStmt+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options guardedSnapshotCounterEventStream target (Add 4)+            case result of+                Right (Right commandResult) ->+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 3+                other -> expectationFailure ("expected snapshot-assisted command, got " <> show other)+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            lookup "keiro.snapshot.read.hits" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++        it "falls back when snapshot JSON is corrupt" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let target = stream "snapshot-corrupt-json" :: Stream SnapshotCounterEventStream+                options = defaultRunCommandOptions & #metrics ?~ keiroMetrics+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 2)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 3)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement ("snapshot-corrupt-json", Aeson.String "bad") corruptSnapshotStateStmt+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 4)+            case result of+                Right (Right commandResult) ->+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 3+                other -> expectationFailure ("expected corrupt snapshot fallback, got " <> show other)+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+            lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1)+            lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3)++        it "falls back when shape hash mismatches" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let target = stream "snapshot-shape-mismatch" :: Stream SnapshotCounterEventStream+                options = defaultRunCommandOptions & #metrics ?~ keiroMetrics+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 2)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 3)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement ("snapshot-shape-mismatch", "stale-shape") corruptSnapshotShapeStmt+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 4)+            case result of+                Right (Right commandResult) ->+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 3+                other -> expectationFailure ("expected stale shape fallback, got " <> show other)+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+            lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3)+            lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing++        it "falls back after operator truncation" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let target = stream "snapshot-operator-truncate" :: Stream SnapshotCounterEventStream+                options = defaultRunCommandOptions & #metrics ?~ keiroMetrics+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 2)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 3)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.sql "TRUNCATE keiro.keiro_snapshots"+            result <-+                Store.runStoreIO storeHandle $+                    runCommand options snapshotCounterEventStream target (Add 4)+            case result of+                Right (Right commandResult) ->+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 3+                other -> expectationFailure ("expected truncation fallback, got " <> show other)+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+            lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 3)+            lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Nothing++        it "writes snapshots after applying a complete multi-event command batch" $ \storeHandle -> do+            let target = stream "snapshot-multi-event-batch" :: Stream SnapshotCounterEventStream+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions multiSnapshotCounterEventStream target (Add 9)+            case result of+                Right (Right commandResult) -> do+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 2+                    commandResult ^. #eventsAppended `shouldBe` 2+                other -> expectationFailure ("expected multi-event snapshot command, got " <> show other)+            Right snapshotVersion <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "snapshot-multi-event-batch" snapshotVersionForStreamStmt+            snapshotVersion `shouldBe` Just (StreamVersion 2)++        it "writes a snapshot when a multi-event append crosses an Every boundary" $ \storeHandle -> do+            let target = stream "snapshot-multi-event-crosses-boundary" :: Stream SnapshotCounterEventStream+                boundaryEventStream :: SnapshotCounterEventStream+                boundaryEventStream =+                    snapshotCounterEventStreamDef+                        & #transducer+                        .~ multiSnapshotCounterTransducer+                        & #snapshotPolicy+                        .~ Every 3+                validatedBoundaryEventStream = mkEventStreamOrThrow "snapshot-multi-event-crosses-boundary" boundaryEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 2)+            Right firstSnapshotVersion <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt+            firstSnapshotVersion `shouldBe` Nothing+            result <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions validatedBoundaryEventStream target (Add 3)+            case result of+                Right (Right commandResult) ->+                    commandResult ^. #streamVersion `shouldBe` StreamVersion 4+                other -> expectationFailure ("expected successful boundary-crossing command, got " <> show other)+            Right snapshotVersion <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "snapshot-multi-event-crosses-boundary" snapshotVersionForStreamStmt+            snapshotVersion `shouldBe` Just (StreamVersion 4)++        it "allows an incompatible snapshot codec to replace a higher-version row" $ \storeHandle -> do+            let target = stream "snapshot-codec-rollback-overwrite" :: Stream SnapshotCounterEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 1)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 4)+            Right snapshotVersionBefore <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt+            snapshotVersionBefore `shouldBe` Just (StreamVersion 4)+            let rollbackCodec = defaultStateCodec @SnapshotCounterRegs @CounterState 2+            streamId <-+                Store.runStoreIO storeHandle (Store.lookupStreamId (StreamName "snapshot-codec-rollback-overwrite")) >>= \case+                    Right (Just sid) -> pure sid+                    other -> expectationFailure ("expected stream id, got " <> show other) *> error "unreachable"+            Right () <-+                Store.runStoreIO storeHandle $+                    writeSnapshotRow+                        SnapshotWrite+                            { streamId = streamId+                            , streamVersion = StreamVersion 2+                            , state = (rollbackCodec ^. #encode) (Counting, RCons (Proxy @"lastAmount") 2 RNil)+                            , stateCodecVersion = rollbackCodec ^. #stateCodecVersion+                            , regfileShapeHash = rollbackCodec ^. #shapeHash+                            }+            Right snapshotVersionAfter <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt+            snapshotVersionAfter `shouldBe` Just (StreamVersion 2)++    describe "Keiro.Connection projection schema" $+        around (withFreshResourceStoreWith fixture (withProjectionSchema "app_reads")) $ do+            it "places a read-model table in a configured schema, separate from keiro metadata" $ \(storeHandle, StoreRunner runner) -> do+                -- qualifiedTableName builds the app's fully-qualified data table ref.+                qualifiedTableName placedReadModel `shouldBe` "\"app_reads\".\"placed_counter\""++                -- Create the app schema (opt-in) and the qualified read-model table.+                Right () <-+                    Store.runStoreIO storeHandle $ do+                        ensureProjectionSchema "app_reads"+                        initializeRegisteredReadModel placedReadModel initializePlacedTable++                -- Drive a command with the inline projection that writes the app table.+                let target = stream "placed-in-app-reads" :: Stream CounterEventStream+                result <-+                    runner $+                        runCommandWithProjections+                            defaultRunCommandOptions+                            counterEventStream+                            target+                            (Add 7)+                            [placedInlineProjection]+                case result of+                    Right (Right _) -> pure ()+                    other -> expectationFailure ("expected placed inline projection command, got " <> show other)++                -- Read it back through the configured-schema read model.+                queryResult <-+                    Store.runStoreIO storeHandle $+                        runQuery Nothing placedReadModel "placed"+                queryResult `shouldBe` Right (Right 7)++                -- Prove placement: the app table is in app_reads, NOT in kiroku, and+                -- Keiro's own metadata (keiro_read_models) is in the keiro schema.+                Right (inApp, inKiroku, keiroMeta) <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            (,,)+                                <$> Tx.statement ("app_reads", "placed_counter") pgTableCountStmt+                                <*> Tx.statement ("kiroku", "placed_counter") pgTableCountStmt+                                <*> Tx.statement ("keiro", "keiro_read_models") pgTableCountStmt+                inApp `shouldBe` (1 :: Int)+                inKiroku `shouldBe` (0 :: Int)+                keiroMeta `shouldBe` (1 :: Int)++    describe "Keiro.ReadModel" $ around (withFreshStore fixture) $ do+        it "queries inline projection with Eventual consistency" $ \_ ->+            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+                Right () <-+                    Store.runStoreIO storeHandle $+                        initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+                let target = stream "read-model-inline" :: Stream CounterEventStream+                result <-+                    runner $+                        runCommandWithProjections+                            defaultRunCommandOptions+                            counterEventStream+                            target+                            (Add 5)+                            [counterInlineProjection]+                case result of+                    Right (Right commandResult) ->+                        commandResult ^. #globalPosition `shouldSatisfy` isJust+                    other -> expectationFailure ("expected inline projection command, got " <> show other)+                queryResult <-+                    Store.runStoreIO storeHandle $+                        runQuery Nothing counterReadModel "inline"+                queryResult `shouldBe` Right (Right 5)++        it "reads the minimum checkpoint across consumer-group subscription members" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $ do+                        Tx.statement ("counter-read-model-sub", 1, 7) upsertSubscriptionCursorMemberStmt+                        Tx.statement ("counter-read-model-sub", 2, 3) upsertSubscriptionCursorMemberStmt+            position <-+                Store.runStoreIO storeHandle $+                    readSubscriptionPosition "counter-read-model-sub"+            position `shouldBe` Right (Just (GlobalPosition 3))++        it "Strong returns immediately on an empty log" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            queryResult <-+                Store.runStoreIO storeHandle $+                    runQueryWith Nothing Strong counterReadModel "empty"+            queryResult `shouldBe` Right (Right 0)++        it "Strong returns immediately when the subscription is already at the store head" $ \_ ->+            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+                Right () <-+                    Store.runStoreIO storeHandle $+                        initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+                let target = stream "read-model-strong-at-head" :: Stream CounterEventStream+                Right (Right commandResult) <-+                    runner $+                        runCommandWithProjections+                            defaultRunCommandOptions+                            counterEventStream+                            target+                            (Add 5)+                            [counterInlineProjection]+                globalPosition <- case commandResult ^. #globalPosition of+                    Just position -> pure position+                    Nothing -> expectationFailure "expected command global position" *> error "unreachable"+                Right () <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt+                queryResult <-+                    Store.runStoreIO storeHandle $+                        runQueryWith Nothing Strong counterReadModel "inline"+                queryResult `shouldBe` Right (Right 5)++        it "Strong blocks until the subscription reaches the store head captured at query start" $ \_ ->+            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+                Right () <-+                    Store.runStoreIO storeHandle $+                        initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+                let target = stream "read-model-strong-blocking" :: Stream CounterEventStream+                Right (Right commandResult) <-+                    runner $+                        runCommandWithProjections+                            defaultRunCommandOptions+                            counterEventStream+                            target+                            (Add 6)+                            [counterInlineProjection]+                globalPosition <- case commandResult ^. #globalPosition of+                    Just position -> pure position+                    Nothing -> expectationFailure "expected command global position" *> error "unreachable"+                _ <- forkIO $ do+                    threadDelay 20000+                    advanced <-+                        Store.runStoreIO storeHandle $+                            Store.runTransaction $+                                Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt+                    case advanced of+                        Right () -> pure ()+                        Left err -> expectationFailure ("failed to advance subscription cursor: " <> show err)+                queryResult <-+                    Store.runStoreIO storeHandle $+                        runQueryWith Nothing Strong counterReadModel "inline"+                queryResult `shouldBe` Right (Right 6)++        it "Strong returns when its category is caught up despite another active category" $ \_ ->+            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+                Right () <-+                    Store.runStoreIO storeHandle $+                        initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+                let counterTarget = stream "counter-strong-scope" :: Stream CounterEventStream+                    otherTarget = stream "otherload-1" :: Stream CounterEventStream+                Right (Right counterResult) <-+                    runner $+                        runCommandWithProjections+                            defaultRunCommandOptions+                            counterEventStream+                            counterTarget+                            (Add 8)+                            [counterInlineProjection]+                counterPosition <- case counterResult ^. #globalPosition of+                    Just position -> pure position+                    Nothing -> expectationFailure "expected counter global position" *> error "unreachable"+                Right () <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Tx.statement+                                ("counter-read-model-sub", globalPositionToInt counterPosition)+                                upsertSubscriptionCursorStmt+                Right (Right _) <-+                    Store.runStoreIO storeHandle $+                        runCommand defaultRunCommandOptions counterEventStream otherTarget (Add 1)+                queryResult <-+                    Store.runStoreIO storeHandle $+                        runQueryWith Nothing Strong counterCategoryReadModel "inline"+                queryResult `shouldBe` Right (Right 8)++        it "inline projection populates actor and source_event_id from command metadata" $ \_ ->+            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+                Right () <-+                    Store.runStoreIO storeHandle $+                        initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+                let target = stream "read-model-inline-metadata" :: Stream CounterEventStream+                    opts =+                        defaultRunCommandOptions+                            & #metadata+                            ?~ object ["actor" Aeson..= ("agent-7" :: Text)]+                Right (Right _) <-+                    runner $+                        runCommandWithProjections opts counterEventStream target (Add 5) [counterInlineProjection]+                Right row <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction (Tx.statement "inline" selectCounterMetaStmt)+                -- selectCounterMetaStmt returns (amount, actor, source_event_id).+                row `shouldSatisfy` \(amount, actor, srcId) ->+                    amount == 5 && actor == Just "agent-7" && isJust srcId++        it "waits for async projection cursor with PositionWait" $ \_ ->+            withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+                Right () <-+                    Store.runStoreIO storeHandle $+                        initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+                let target = stream "read-model-position-wait" :: Stream CounterEventStream+                Right (Right commandResult) <-+                    runner $+                        runCommandWithProjections+                            defaultRunCommandOptions+                            counterEventStream+                            target+                            (Add 3)+                            [counterInlineProjection]+                globalPosition <- case commandResult ^. #globalPosition of+                    Just position -> pure position+                    Nothing -> expectationFailure "expected command global position" *> error "unreachable"+                Right () <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Tx.statement ("counter-read-model-sub", globalPositionToInt globalPosition) upsertSubscriptionCursorStmt+                queryResult <-+                    Store.runStoreIO storeHandle $+                        runQueryWith+                            Nothing+                            (PositionWait (fastWaitOptions & #target .~ Just globalPosition))+                            counterReadModel+                            "inline"+                queryResult `shouldBe` Right (Right 3)++        it "times out when PositionWait target is not reached" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt+            queryResult <-+                Store.runStoreIO storeHandle $+                    runQueryWith+                        Nothing+                        (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5)))+                        counterReadModel+                        "timeout"+            queryResult+                `shouldBe` Right+                    (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1)))++        it "does not write the registry row on repeated read-model queries" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            Right (Right 0) <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "no-churn"+            Right xminBefore <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "counter-read-model" readModelXminStmt+            Right (Right 0) <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "no-churn"+            Right xminAfter <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "counter-read-model" readModelXminStmt+            xminAfter `shouldBe` xminBefore++        it "rejects an unregistered model without creating a registry row" $ \storeHandle -> do+            let unregistered :: ReadModel Text Int+                unregistered = counterReadModel & #name .~ ("never-registered" :: Text)+            queryResult <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing unregistered "missing"+            queryResult `shouldBe` Right (Left (ReadModelUnregistered "never-registered"))+            found <-+                Store.runStoreIO storeHandle $+                    lookupReadModel "never-registered"+            found `shouldBe` Right Nothing++        it "handles concurrent explicit read-model registration" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction initializeCounterReadModelTable+            resultA <- newEmptyMVar+            resultB <- newEmptyMVar+            _ <-+                forkIO $+                    Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel)+                        >>= putMVar resultA+            _ <-+                forkIO $+                    Store.runStoreIO storeHandle (registerReadModelDefinition counterReadModel)+                        >>= putMVar resultB+            first <- takeMVar resultA+            second <- takeMVar resultB+            first `shouldBe` Right ()+            second `shouldBe` Right ()+            queryResult <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "concurrent"+            queryResult `shouldBe` Right (Right 0)++        it "rejects stale read-model schema" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            Right (Right 0) <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "stale"+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement ("counter-read-model", 99) updateReadModelVersionStmt+            queryResult <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "stale"+            queryResult+                `shouldBe` Right+                    (Left (ReadModelStaleSchema "counter-read-model" 1 99 "counter-read-model-v1" "counter-read-model-v1"))++        it "surfaces unknown read-model statuses with the raw status text" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            Right (Right 0) <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "unknown-status"+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement ("counter-read-model", "wedged") updateReadModelStatusStmt+            queryResult <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "unknown-status"+            queryResult+                `shouldBe` Right+                    (Left (ReadModelNotLive "counter-read-model" (UnknownStatus "wedged")))++        it "ignores duplicate async event by source_event_id" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            let target = stream "read-model-async-idempotent" :: Stream CounterEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "read-model-async-idempotent") (StreamVersion 0) 10+            event <- case Vector.toList recorded of+                [onlyEvent] -> pure onlyEvent+                other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"+            Right outcomes <- Store.runStoreIO storeHandle $+                Store.runTransaction $ do+                    first <- applyAsyncProjection counterAsyncProjection event+                    second <- applyAsyncProjection counterAsyncProjection event+                    pure (first, second)+            outcomes `shouldBe` (AsyncApplied, AsyncDuplicate)+            queryResult <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "async-idempotent"+            queryResult `shouldBe` Right (Right 7)++        it "deduplicates async projection application across transactions and reopens after pruning" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction initializeProjectionDedupCounterTable+            Right _ <-+                Store.runStoreIO storeHandle $+                    registerReadModel "projection-dedup-counter-model" 1 "projection-dedup-counter-v1"+            let target = stream "read-model-async-dedup-window" :: Stream CounterEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "read-model-async-dedup-window") (StreamVersion 0) 10+            event <- case Vector.toList recorded of+                [onlyEvent] -> pure onlyEvent+                other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"+            let incrementingProjection =+                    AsyncProjection+                        { name = "incrementing-async-projection"+                        , readModelName = "projection-dedup-counter-model"+                        , subscriptionName = "incrementing-async-projection-sub"+                        , applyRecorded = \_ -> Tx.statement () incrementProjectionDedupCounterStmt+                        , idempotencyKey = \recordedEvent -> recordedEvent ^. #eventId+                        }+            Right AsyncApplied <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        applyAsyncProjection incrementingProjection event+            Right AsyncDuplicate <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        applyAsyncProjection incrementingProjection event+            Right countAfterDuplicate <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement () selectProjectionDedupCounterStmt+            countAfterDuplicate `shouldBe` 1+            cutoff <- addUTCTime 1 <$> getCurrentTime+            pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff+            pruned `shouldBe` Right 1+            Right AsyncApplied <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        applyAsyncProjection incrementingProjection event+            Right countAfterPrune <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement () selectProjectionDedupCounterStmt+            countAfterPrune `shouldBe` 2++        it "rebuild repopulates the projection table through the supported workflow" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            let target = stream "read-model-rebuild-runbook" :: Stream CounterEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "read-model-rebuild-runbook") (StreamVersion 0) 10+            event <- case Vector.toList recorded of+                [onlyEvent] -> pure onlyEvent+                other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"+            Right AsyncApplied <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        applyAsyncProjection counterAsyncProjection event+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement+                            ( "counter-read-model-sub"+                            , globalPositionToInt (event ^. #globalPosition)+                            )+                            upsertSubscriptionCursorStmt+            beforeRebuild <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "async-idempotent"+            beforeRebuild `shouldBe` Right (Right 7)++            Right rebuilding <-+                Store.runStoreIO storeHandle $+                    Rebuild.startRebuild+                        counterReadModel+                        [counterAsyncProjection ^. #name]+                        (GlobalPosition 0)+            rebuilding ^. #status `shouldBe` Rebuilding+            checkpointAfterReset <-+                Store.runStoreIO storeHandle $+                    readSubscriptionPosition "counter-read-model-sub"+            checkpointAfterReset `shouldBe` Right (Just (GlobalPosition 0))+            Right AsyncApplied <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        applyAsyncProjectionUnfenced counterAsyncProjection event+            Right (Right live) <-+                Store.runStoreIO storeHandle $+                    Rebuild.finishRebuild+                        counterReadModel+                        [counterAsyncProjection ^. #name]+                        (GlobalPosition 0)+            live ^. #status `shouldBe` Live++            afterRebuild <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "async-idempotent"+            afterRebuild `shouldBe` Right (Right 7)++        it "keeps a non-empty-log rebuild offline when replay applies nothing" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            let target = stream "read-model-rebuild-empty-replay" :: Stream CounterEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)+            Right _ <-+                Store.runStoreIO storeHandle $+                    Rebuild.startRebuild+                        counterReadModel+                        [counterAsyncProjection ^. #name]+                        (GlobalPosition 0)+            finishResult <-+                Store.runStoreIO storeHandle $+                    Rebuild.finishRebuild+                        counterReadModel+                        [counterAsyncProjection ^. #name]+                        (GlobalPosition 0)+            case finishResult of+                Right (Left (Rebuild.RebuildProducedNoApplies modelName headPosition)) -> do+                    modelName `shouldBe` "counter-read-model"+                    headPosition `shouldSatisfy` (> GlobalPosition 0)+                other -> expectationFailure ("expected zero-apply guard, got " <> show other)+            queryResult <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "async-idempotent"+            queryResult+                `shouldBe` Right+                    (Left (ReadModelNotLive "counter-read-model" Rebuilding))++        it "fences live async application while a model is rebuilding" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            let target = stream "read-model-fenced-apply" :: Stream CounterEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "read-model-fenced-apply") (StreamVersion 0) 10+            event <- case Vector.toList recorded of+                [onlyEvent] -> pure onlyEvent+                other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"+            Right _ <-+                Store.runStoreIO storeHandle $+                    Rebuild.startRebuild+                        counterReadModel+                        [counterAsyncProjection ^. #name]+                        (GlobalPosition 0)+            outcome <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        applyAsyncProjection counterAsyncProjection event+            outcome `shouldBe` Right AsyncFenced+            Right dedupCount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement (counterAsyncProjection ^. #name) projectionDedupCountStmt+            dedupCount `shouldBe` 0+            Right amount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "async-idempotent" selectCounterReadModelStmt+            amount `shouldBe` 0++        it "keeps a live applier out of the rebuild window and reopens it after promotion" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            let target = stream "read-model-fence-race" :: Stream CounterEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 7)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "read-model-fence-race") (StreamVersion 0) 10+            event <- case Vector.toList recorded of+                [onlyEvent] -> pure onlyEvent+                other -> expectationFailure ("expected one event, got " <> show other) *> error "unreachable"+            enterRebuildWindow <- newEmptyMVar+            liveApplyResult <- newEmptyMVar+            _ <-+                forkIO $ do+                    takeMVar enterRebuildWindow+                    Store.runStoreIO+                        storeHandle+                        (Store.runTransaction (applyAsyncProjection counterAsyncProjection event))+                        >>= putMVar liveApplyResult+            Right _ <-+                Store.runStoreIO storeHandle $+                    Rebuild.startRebuild+                        counterReadModel+                        [counterAsyncProjection ^. #name]+                        (GlobalPosition 0)+            putMVar enterRebuildWindow ()+            takeMVar liveApplyResult `shouldReturn` Right AsyncFenced++            Right AsyncApplied <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        applyAsyncProjectionUnfenced counterAsyncProjection event+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    Rebuild.finishRebuild+                        counterReadModel+                        [counterAsyncProjection ^. #name]+                        (GlobalPosition 0)+            cutoff <- addUTCTime 1 <$> getCurrentTime+            pruned <- Store.runStoreIO storeHandle $ pruneAsyncProjectionDedupBefore cutoff+            pruned `shouldBe` Right 1+            reapplied <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        applyAsyncProjection counterAsyncProjection event+            reapplied `shouldBe` Right AsyncApplied+            queryResult <-+                Store.runStoreIO storeHandle $+                    runQuery Nothing counterReadModel "async-idempotent"+            queryResult `shouldBe` Right (Right 7)++        it "tracks rebuild state transitions" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    registerReadModelDefinition counterReadModel+            Right rebuilding <-+                Store.runStoreIO storeHandle $+                    Rebuild.rebuild counterReadModel+            rebuilding ^. #status `shouldBe` Rebuilding+            Right live <-+                Store.runStoreIO storeHandle $+                    Rebuild.promote counterReadModel+            live ^. #status `shouldBe` Live+            Right abandoned <-+                Store.runStoreIO storeHandle $+                    Rebuild.abandonRebuild counterReadModel+            abandoned ^. #status `shouldBe` Abandoned++        it "records projection lag behind the log head" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            let target = stream "read-model-lag" :: Stream CounterEventStream+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 1)+            Right (Right _) <-+                Store.runStoreIO storeHandle $+                    runCommand defaultRunCommandOptions counterEventStream target (Add 1)+            -- The subscription cursor is never advanced, so the read model is behind+            -- the head by every appended event: the lag gauge records that gap.+            Right () <-+                Store.runStoreIO storeHandle $+                    recordProjectionLag (Just keiroMetrics) counterAsyncProjection+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+            case lookup "keiro.projection.lag" scalars of+                Just (IntNumber n) -> n `shouldSatisfy` (>= 1)+                other -> expectationFailure ("expected an integer projection lag, got " <> show other)++        it "counts a position-wait timeout in the timeout counter" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            Right () <-+                Store.runStoreIO storeHandle $+                    initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement ("counter-read-model-sub", 1) upsertSubscriptionCursorStmt+            queryResult <-+                Store.runStoreIO storeHandle $+                    runQueryWith+                        (Just keiroMetrics)+                        (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5)))+                        counterReadModel+                        "timeout"+            queryResult+                `shouldBe` Right+                    (Left (ReadModelWaitTimeout "counter-read-model" (GlobalPosition 5) (GlobalPosition 1)))+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+            -- The single give-up bumped the counter exactly once.+            lookup "keiro.projection.wait.timeouts" scalars `shouldBe` Just (IntNumber 1)++    describe "Keiro.ProcessManager" $ around (withFreshResourceStore fixture) $ do+        it "advances manager state, emits a deterministic target command once, and schedules a timer" $ \(_storeHandle, StoreRunner _runner) -> do+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+            result <-+                _runner $+                    runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 9)+            case result of+                Right (Right pmResult) -> do+                    case pmResult ^. #managerResult of+                        PMStateAppended managerResult ->+                            managerResult ^. #streamVersion `shouldBe` StreamVersion 1+                        other -> expectationFailure ("expected appended manager state, got " <> show other)+                    case pmResult ^. #commandResults of+                        [PMCommandAppended commandResult] ->+                            commandResult ^. #eventsAppended `shouldBe` 1+                        other -> expectationFailure ("expected one emitted command, got " <> show other)+                    pmResult ^. #timersScheduled `shouldBe` 1+                other -> expectationFailure ("expected process-manager success, got " <> show other)+            Right managerEvents <-+                _runner $+                    Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+            Right targetEvents <-+                _runner $+                    Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10+            Vector.length managerEvents `shouldBe` 1+            Vector.length targetEvents `shouldBe` 1+            timer <-+                _runner $+                    claimDueTimer dueTimerTime+            case timer of+                Right (Just row) -> do+                    row ^. #processManagerName `shouldBe` "counter-pm"+                    row ^. #correlationId `shouldBe` "order-1"+                other -> expectationFailure ("expected scheduled timer row, got " <> show other)++        it "schedules timers when the manager command emits no events" $ \(_storeHandle, StoreRunner _runner) -> do+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+            result <-+                _runner $+                    runProcessManagerOnce defaultRunCommandOptions timerOnlyProcessManager sourceEvent (CounterAdded 9)+            case result of+                Right (Right pmResult) -> do+                    case pmResult ^. #managerResult of+                        PMStateAppended managerResult -> do+                            managerResult ^. #streamVersion `shouldBe` StreamVersion 0+                            managerResult ^. #eventsAppended `shouldBe` 0+                        other -> expectationFailure ("expected no-op manager state, got " <> show other)+                    pmResult ^. #commandResults `shouldBe` []+                    pmResult ^. #timersScheduled `shouldBe` 1+                other -> expectationFailure ("expected process-manager success, got " <> show other)+            dueCount <-+                _runner $+                    countDueTimers dueTimerTime+            dueCount `shouldBe` Right 1+            timer <-+                _runner $+                    claimDueTimer dueTimerTime+            case timer of+                Right (Just row) -> do+                    row ^. #processManagerName `shouldBe` "timer-only-pm"+                    row ^. #correlationId `shouldBe` "order-1"+                other -> expectationFailure ("expected scheduled timer row, got " <> show other)++        it "treats duplicate input delivery as idempotent state and command dispatch" $ \(_storeHandle, StoreRunner _runner) -> do+            let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 4)+            Right (Right _) <-+                _runner $+                    runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4)+            duplicate <-+                _runner $+                    runProcessManagerOnce defaultRunCommandOptions counterProcessManager sourceEvent (CounterAdded 4)+            case duplicate of+                Right (Right pmResult) -> do+                    pmResult ^. #managerResult `shouldSatisfy` \case+                        PMStateDuplicate{} -> True+                        _ -> False+                    pmResult ^. #commandResults `shouldSatisfy` \case+                        [PMCommandDuplicate{}] -> True+                        _ -> False+                other -> expectationFailure ("expected idempotent duplicate handling, got " <> show other)+            Right managerEvents <-+                _runner $+                    Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+            Right targetEvents <-+                _runner $+                    Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10+            Vector.length managerEvents `shouldBe` 1+            Vector.length targetEvents `shouldBe` 1++        it "replays a Kiroku dead letter freshly and deduplicates a second replay" $ \(_storeHandle, StoreRunner _runner) -> do+            let subName = SubscriptionName "counter-pm-replay-fresh"+                replayHandler recorded =+                    case decodeRecorded counterCodec recorded of+                        Left err -> pure (Left (Text.pack (show err)))+                        Right input -> do+                            outcome <-+                                runProcessManagerOnce+                                    defaultRunCommandOptions+                                    counterProcessManager+                                    recorded+                                    input+                            pure $+                                case outcome of+                                    Left err -> Left (Text.pack (show err))+                                    Right result -> Right (classifyProcessManagerReplay result)+            source <- deadLetterCounterSource _storeHandle subName (CounterAdded 7)+            Right listed <- _runner (listSubscriptionDeadLetters subName 0)+            Vector.length listed `shouldBe` 1++            Right firstPass <-+                _runner $+                    replaySubscriptionDeadLetters subName 0 replayHandler+            firstPass+                `shouldBe` [ ReplayOutcome+                                { replayGlobalPosition = source ^. #globalPosition+                                , replayEventId = source ^. #eventId+                                , replayResult = ReplayedFresh+                                }+                           ]+            processManagerReplayCounts _storeHandle `shouldReturn` (1, 1)++            Right secondPass <-+                _runner $+                    replaySubscriptionDeadLetters subName 0 replayHandler+            secondPass+                `shouldBe` [ ReplayOutcome+                                { replayGlobalPosition = source ^. #globalPosition+                                , replayEventId = source ^. #eventId+                                , replayResult = ReplayedDuplicate+                                }+                           ]+            processManagerReplayCounts _storeHandle `shouldReturn` (1, 1)+            Right retained <- _runner (listSubscriptionDeadLetters subName 0)+            Vector.length retained `shouldBe` 1++        it "reports an already-processed Kiroku dead letter without appending" $ \(_storeHandle, StoreRunner _runner) -> do+            let subName = SubscriptionName "counter-pm-replay-duplicate"+                replayHandler recorded =+                    case decodeRecorded counterCodec recorded of+                        Left err -> pure (Left (Text.pack (show err)))+                        Right input -> do+                            outcome <-+                                runProcessManagerOnce+                                    defaultRunCommandOptions+                                    counterProcessManager+                                    recorded+                                    input+                            pure $+                                case outcome of+                                    Left err -> Left (Text.pack (show err))+                                    Right result -> Right (classifyProcessManagerReplay result)+            source <- deadLetterCounterSource _storeHandle subName (CounterAdded 8)+            Right (Right _) <-+                _runner $+                    runProcessManagerOnce+                        defaultRunCommandOptions+                        counterProcessManager+                        source+                        (CounterAdded 8)+            countsBefore <- processManagerReplayCounts _storeHandle++            Right outcomes <-+                _runner $+                    replaySubscriptionDeadLetters subName 0 replayHandler+            outcomes+                `shouldBe` [ ReplayOutcome+                                { replayGlobalPosition = source ^. #globalPosition+                                , replayEventId = source ^. #eventId+                                , replayResult = ReplayedDuplicate+                                }+                           ]+            processManagerReplayCounts _storeHandle `shouldReturn` countsBefore++        it "keeps multiple workflow process managers isolated by configured streams and categories" $ \(_storeHandle, StoreRunner _runner) -> do+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 6)+                fulfillmentManager =+                    workflowProcessManager+                        "fulfillment-pm"+                        "pm:fulfillment"+                        "fulfillment-target-order-1"+                billingManager =+                    workflowProcessManager+                        "billing-pm"+                        "pm:billing"+                        "billing-target-order-1"+            fulfillmentResult <-+                _runner $+                    runProcessManagerOnce defaultRunCommandOptions fulfillmentManager sourceEvent (CounterAdded 6)+            billingResult <-+                _runner $+                    runProcessManagerOnce defaultRunCommandOptions billingManager sourceEvent (CounterAdded 6)+            assertWorkflowProcessManagerAppended fulfillmentResult+            assertWorkflowProcessManagerAppended billingResult++            Right fulfillmentManagerEvents <-+                _runner $+                    Store.readStreamForward (StreamName "pm:fulfillment-order-1") (StreamVersion 0) 10+            Right billingManagerEvents <-+                _runner $+                    Store.readStreamForward (StreamName "pm:billing-order-1") (StreamVersion 0) 10+            Right fulfillmentTargetEvents <-+                _runner $+                    Store.readStreamForward (StreamName "fulfillment-target-order-1") (StreamVersion 0) 10+            Right billingTargetEvents <-+                _runner $+                    Store.readStreamForward (StreamName "billing-target-order-1") (StreamVersion 0) 10+            Vector.length fulfillmentManagerEvents `shouldBe` 1+            Vector.length billingManagerEvents `shouldBe` 1+            Vector.length fulfillmentTargetEvents `shouldBe` 1+            Vector.length billingTargetEvents `shouldBe` 1++            Right fulfillmentCategoryEvents <-+                _runner $+                    Store.readCategory (CategoryName "pm:fulfillment") (GlobalPosition 0) 10+            Right billingCategoryEvents <-+                _runner $+                    Store.readCategory (CategoryName "pm:billing") (GlobalPosition 0) 10+            Right sharedPmCategoryEvents <-+                _runner $+                    Store.readCategory (CategoryName "pm") (GlobalPosition 0) 10+            Right sharedPmNamespaceEvents <-+                _runner $+                    Store.readCategory (CategoryName "pm:") (GlobalPosition 0) 10+            Vector.length fulfillmentCategoryEvents `shouldBe` 1+            Vector.length billingCategoryEvents `shouldBe` 1+            sharedPmCategoryEvents `shouldBe` Vector.empty+            sharedPmNamespaceEvents `shouldBe` Vector.empty++        it "worker finalizes AckOk through the ack handle on success" $ \(_storeHandle, StoreRunner _runner) -> do+            decisionsRef <- newIORef []+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+                messages = [(sourceEvent, CounterAdded 9)]+                adapter = inMemoryAdapter decisionsRef messages+            Right () <-+                _runner $+                    runProcessManagerWorker defaultRunCommandOptions counterProcessManager adapter Just+            decisions <- readIORef decisionsRef+            decisions `shouldBe` [AckOk]++        it "worker halts instead of acking when a target dispatch is rejected" $ \(_storeHandle, StoreRunner _runner) -> do+            decisionsRef <- newIORef []+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+                messages = [(sourceEvent, CounterAdded 9)]+                adapter = inMemoryAdapter decisionsRef messages+                rejectingPm =+                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+                        { targetEventStream = rejectingEventStream+                        }+            Right () <-+                _runner $+                    runProcessManagerWorker defaultRunCommandOptions rejectingPm adapter Just+            decisions <- readIORef decisionsRef+            decisions `shouldSatisfy` \case+                [AckHalt (HaltFatal _)] -> True+                _ -> False+            Right targetEvents <-+                _runner $+                    Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10+            Right managerEvents <-+                _runner $+                    Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+            Vector.length targetEvents `shouldBe` 0+            Vector.length managerEvents `shouldBe` 1++        it "dead-letters a rejected dispatch and continues to the next event" $ \(_storeHandle, StoreRunner _runner) -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            decisionsRef <- newIORef []+            let first = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+                second = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)+                messages = [(first, CounterAdded 9), (second, CounterAdded 1)]+                adapter = inMemoryAdapter decisionsRef messages+                policyPm =+                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+                        { targetEventStream = rejectNineEventStream+                        }+                workerOptions =+                    defaultWorkerOptions+                        & #rejectedCommandPolicy+                        .~ RejectedDeadLetter+                        & #metrics+                        ?~ keiroMetrics+            Right () <-+                _runner $+                    runProcessManagerWorkerWith workerOptions defaultRunCommandOptions policyPm adapter Just+            readIORef decisionsRef `shouldReturn` [AckOk, AckOk]+            Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")+            case deadLetters of+                [row] -> do+                    row ^. #dispatcherKind `shouldBe` DispatcherProcessManager+                    row ^. #correlationId `shouldBe` "order-1"+                    row ^. #sourceEventId `shouldBe` EventId sampleUuid+                    row ^. #emitIndex `shouldBe` 0+                    row ^. #targetStreamName `shouldBe` StreamName "counter-target-order-1"+                    row ^. #errorClass `shouldBe` "command_rejected"+                    row ^. #attemptCount `shouldBe` 1+                other -> expectationFailure ("expected one rejected dispatch dead letter, got " <> show other)+            Right targetEvents <-+                _runner $+                    Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10+            Right managerEvents <-+                _runner $+                    Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+            Vector.length targetEvents `shouldBe` 1+            Vector.length managerEvents `shouldBe` 2+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++        it "skips a rejected dispatch without writing a dead-letter row" $ \(_storeHandle, StoreRunner _runner) -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            decisionsRef <- newIORef []+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+                adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)]+                rejectingPm =+                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+                        { targetEventStream = rejectingEventStream+                        }+                workerOptions =+                    defaultWorkerOptions+                        & #rejectedCommandPolicy+                        .~ RejectedSkip+                        & #metrics+                        ?~ keiroMetrics+            Right () <-+                _runner $+                    runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just+            readIORef decisionsRef `shouldReturn` [AckOk]+            Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")+            deadLetters `shouldBe` []+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            lookup "keiro.dispatch.deadlettered" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++        it "dead-letters a manager-state rejection at emit index minus one" $ \(_storeHandle, StoreRunner _runner) -> do+            decisionsRef <- newIORef []+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+                adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9)]+                rejectingManager =+                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+                        { eventStream = rejectingEventStream+                        }+                workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter+            Right () <-+                _runner $+                    runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingManager adapter Just+            readIORef decisionsRef `shouldReturn` [AckOk]+            Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")+            case deadLetters of+                [row] -> do+                    row ^. #emitIndex `shouldBe` (-1)+                    row ^. #targetStreamName `shouldBe` StreamName "pm:counter-order-1"+                    row ^. #errorClass `shouldBe` "command_rejected"+                other -> expectationFailure ("expected one manager-state dead letter, got " <> show other)+            Right managerEvents <-+                _runner $+                    Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+            managerEvents `shouldBe` Vector.empty++        it "keeps rejected-dispatch dead letters idempotent on source redelivery" $ \(_storeHandle, StoreRunner _runner) -> do+            decisionsRef <- newIORef []+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+                adapter = inMemoryAdapter decisionsRef [(sourceEvent, CounterAdded 9), (sourceEvent, CounterAdded 9)]+                rejectingPm =+                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+                        { targetEventStream = rejectingEventStream+                        }+                workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter+            Right () <-+                _runner $+                    runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just+            readIORef decisionsRef `shouldReturn` [AckOk, AckOk]+            Right deadLetters <- _runner (listDispatchDeadLetters "counter-pm")+            Prelude.length deadLetters `shouldBe` 1++        it "records dispatch failures through worker metrics" $ \(_storeHandle, StoreRunner _runner) -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            decisionsRef <- newIORef []+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+                messages = [(sourceEvent, CounterAdded 9)]+                adapter = inMemoryAdapter decisionsRef messages+                rejectingPm =+                    (counterProcessManager :: ProcessManager CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent)+                        { targetEventStream = rejectingEventStream+                        }+                workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics+            Right () <-+                _runner $+                    runProcessManagerWorkerWith workerOptions defaultRunCommandOptions rejectingPm adapter Just+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++        it "classifies transient store failures as retry and deterministic command failures as halt" $ \(_storeHandle, StoreRunner _runner) -> do+            isRejectionClass CommandRejected `shouldBe` True+            isRejectionClass (CommandAmbiguous [0, 1]) `shouldBe` True+            isRejectionClass (EncodeFailed (NonObjectCallerMetadata Aeson.Null)) `shouldBe` False+            ackForCommandError (RetryDelay 5) (StoreFailed (Store.ConnectionLost "boom"))+                `shouldBe` AckRetry (RetryDelay 5)+            ackForCommandError (RetryDelay 5) CommandRejected `shouldSatisfy` \case+                AckHalt (HaltFatal _) -> True+                _ -> False+            ackForCommandError (RetryDelay 5) (CommandAmbiguous [0, 1]) `shouldSatisfy` \case+                AckHalt (HaltFatal _) -> True+                _ -> False++        it "worker applies poison-message policy on decode failure" $ \(_storeHandle, StoreRunner _runner) -> do+            let badMessages = ["not-decodable" :: Text]+            defaultDecisions <- newIORef []+            Right () <-+                _runner $+                    runProcessManagerWorker+                        defaultRunCommandOptions+                        counterProcessManager+                        (inMemoryAdapter defaultDecisions badMessages)+                        (const Nothing)+            defaultObserved <- readIORef defaultDecisions+            defaultObserved `shouldSatisfy` \case+                [AckHalt (HaltFatal _)] -> True+                _ -> False++            skippedRef <- newIORef []+            skipDecisions <- newIORef []+            let skipOptions =+                    defaultWorkerOptions+                        & #poisonPolicy+                        .~ PoisonSkip (\env -> liftIO (modifyIORef' skippedRef (<> [env ^. #payload])))+            Right () <-+                _runner $+                    runProcessManagerWorkerWith+                        skipOptions+                        defaultRunCommandOptions+                        counterProcessManager+                        (inMemoryAdapter skipDecisions badMessages)+                        (const Nothing)+            readIORef skipDecisions `shouldReturn` [AckOk]+            readIORef skippedRef `shouldReturn` badMessages++            deadLetterDecisions <- newIORef []+            deadLetterRef <- newIORef []+            let deadLetterOptions =+                    defaultWorkerOptions+                        & #poisonPolicy+                        .~ PoisonDeadLetter (\env -> liftIO (modifyIORef' deadLetterRef (<> [env ^. #payload])))+            Right () <-+                _runner $+                    runProcessManagerWorkerWith+                        deadLetterOptions+                        defaultRunCommandOptions+                        counterProcessManager+                        (inMemoryAdapter deadLetterDecisions badMessages)+                        (const Nothing)+            deadLetterObserved <- readIORef deadLetterDecisions+            deadLetterObserved `shouldSatisfy` \case+                [AckDeadLetter (InvalidPayload _)] -> True+                _ -> False+            readIORef deadLetterRef `shouldReturn` badMessages++        it "folds a concurrent duplicate target dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do+            insertCount <- newIORef (0 :: Int)+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+                commandId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) 0+                targetStreamName = StreamName "counter-target-order-1"+                insertConcurrentTarget = do+                    callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n))+                    when (callNo == 1) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 9)+                options =+                    defaultRunCommandOptions+                        & #beforeAppend+                        .~ insertConcurrentTarget+                        & #retryBackoffMicros+                        .~ 0+            result <-+                _runner $+                    runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9)+            case result of+                Right (Right pmResult) ->+                    pmResult ^. #commandResults `shouldSatisfy` \case+                        [PMCommandDuplicate duplicateId] -> duplicateId == commandId+                        _ -> False+                other -> expectationFailure ("expected duplicate target dispatch fold, got " <> show other)+            Right targetEvents <-+                _runner $+                    Store.readStreamForward targetStreamName (StreamVersion 0) 10+            Vector.length targetEvents `shouldBe` 1++        it "folds a concurrent duplicate manager-state append to PMStateDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do+            insertCount <- newIORef (0 :: Int)+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+                managerId = deterministicCommandId "counter-pm" "order-1" (sourceEvent ^. #eventId) (-1)+                managerStreamName = StreamName "pm:counter-order-1"+                insertConcurrentManager = do+                    callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n))+                    when (callNo == 0) $ appendCounterEventWithId _storeHandle managerStreamName managerId (CounterAdded 9)+                options =+                    defaultRunCommandOptions+                        & #beforeAppend+                        .~ insertConcurrentManager+                        & #retryBackoffMicros+                        .~ 0+            result <-+                _runner $+                    runProcessManagerOnce options counterProcessManager sourceEvent (CounterAdded 9)+            case result of+                Right (Right pmResult) -> do+                    pmResult ^. #managerResult `shouldSatisfy` \case+                        PMStateDuplicate duplicateId -> duplicateId == managerId+                        _ -> False+                    pmResult ^. #commandResults `shouldSatisfy` \case+                        [PMCommandAppended{}] -> True+                        _ -> False+                other -> expectationFailure ("expected duplicate manager-state fold, got " <> show other)++    describe "Keiro.ProcessManager duplicate confirmation" $ around (withFreshResourceStore fixture) $ do+        it "rejects a duplicate report carrying a different id" $ \(_storeHandle, StoreRunner _runner) -> do+            let targetStreamName = StreamName "duplicate-confirmation-mismatch"+                ourId = EventId sampleUuid+                otherId = EventId sampleUuid2+            appendCounterEventWithId _storeHandle targetStreamName otherId (CounterAdded 1)+            outcome <-+                _runner $+                    confirmBenignDuplicate+                        targetStreamName+                        ourId+                        (StoreFailed (Store.DuplicateEvent (Just otherId)))+            outcome `shouldBe` Right False++        it "rejects a matching id that exists only in another stream" $ \(_storeHandle, StoreRunner _runner) -> do+            let targetStreamName = StreamName "duplicate-confirmation-target"+                otherStreamName = StreamName "duplicate-confirmation-other"+                ourId = EventId sampleUuid+                targetEventId = EventId sampleUuid2+            appendCounterEventWithId _storeHandle targetStreamName targetEventId (CounterAdded 1)+            appendCounterEventWithId _storeHandle otherStreamName ourId (CounterAdded 1)+            outcome <-+                _runner $+                    confirmBenignDuplicate+                        targetStreamName+                        ourId+                        (StoreFailed (Store.DuplicateEvent (Just ourId)))+            outcome `shouldBe` Right False++        it "confirms matching and id-less duplicate reports when the id is in the target stream" $ \(_storeHandle, StoreRunner _runner) -> do+            let targetStreamName = StreamName "duplicate-confirmation-present"+                ourId = EventId sampleUuid+            appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1)+            matchingOutcome <-+                _runner $+                    confirmBenignDuplicate+                        targetStreamName+                        ourId+                        (StoreFailed (Store.DuplicateEvent (Just ourId)))+            missingDetailOutcome <-+                _runner $+                    confirmBenignDuplicate+                        targetStreamName+                        ourId+                        (StoreFailed (Store.DuplicateEvent Nothing))+            matchingOutcome `shouldBe` Right True+            missingDetailOutcome `shouldBe` Right True++        it "rejects non-duplicate command failures" $ \(_storeHandle, StoreRunner _runner) -> do+            let targetStreamName = StreamName "duplicate-confirmation-non-duplicate"+                ourId = EventId sampleUuid+            appendCounterEventWithId _storeHandle targetStreamName ourId (CounterAdded 1)+            outcome <-+                _runner $+                    confirmBenignDuplicate+                        targetStreamName+                        ourId+                        (StoreFailed (Store.ConnectionLost "boom"))+            outcome `shouldBe` Right False++    describe "Keiro.ProcessManager snapshots" $ around (withFreshResourceStore fixture) $ do+        it "writes a snapshot of the manager state stream after the policy threshold" $ \(_storeHandle, StoreRunner _runner) -> do+            -- Two distinct source events, both correlating to "order-1", drive the one+            -- manager instance to manager-stream version 2, which Every 2 snapshots.+            let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2)+                sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3)+            Right (Right _) <-+                _runner $+                    runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2)+            Right (Right _) <-+                _runner $+                    runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3)+            Right managerEvents <-+                _runner $+                    Store.readStreamForward (StreamName "pm:counter-snap-order-1") (StreamVersion 0) 10+            Vector.length managerEvents `shouldBe` 2+            Right snapshotVersion <-+                _runner $+                    Store.runTransaction $+                        Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt+            snapshotVersion `shouldBe` Just (StreamVersion 2)++        it "hydrates the manager from its snapshot and replays only the tail" $ \(_storeHandle, StoreRunner _runner) -> do+            -- After the threshold snapshot exists, a third reaction should land on top of+            -- the snapshot at version 3 rather than replaying from version 0.+            let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 2)+                sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 3)+                sourceC = recordedFromEventId (EventId sampleUuid3) (CounterAdded 4)+            Right (Right _) <-+                _runner $+                    runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceA (CounterAdded 2)+            Right (Right _) <-+                _runner $+                    runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceB (CounterAdded 3)+            -- Confirm the snapshot is present before the tail-replay reaction.+            Right snapshotVersion <-+                _runner $+                    Store.runTransaction $+                        Tx.statement "pm:counter-snap-order-1" snapshotVersionForStreamStmt+            snapshotVersion `shouldBe` Just (StreamVersion 2)+            result <-+                _runner $+                    runProcessManagerOnce defaultRunCommandOptions pmSnapshotProcessManager sourceC (CounterAdded 4)+            case result of+                Right (Right pmResult) ->+                    case pmResult ^. #managerResult of+                        PMStateAppended managerResult ->+                            managerResult ^. #streamVersion `shouldBe` StreamVersion 3+                        other -> expectationFailure ("expected appended manager state, got " <> show other)+                other -> expectationFailure ("expected snapshot-assisted PM reaction, got " <> show other)++    describe "Keiro.Router" $ around (withFreshResourceStore fixture) $ do+        it "encodes colon-bearing and non-ASCII id components without collisions" $ \(_storeHandle, StoreRunner _runner) -> do+            let sourceEventId = EventId sampleUuid+                colonLeft =+                    deterministicRouterCommandId+                        "router:a"+                        "key"+                        sourceEventId+                        (StreamName "target")+                        0+                colonRight =+                    deterministicRouterCommandId+                        "router"+                        "a:key"+                        sourceEventId+                        (StreamName "target")+                        0+                unicodeLeft =+                    deterministicRouterCommandId+                        "router"+                        "key"+                        sourceEventId+                        (StreamName ("target-" <> Text.singleton '\x101'))+                        0+                unicodeRight =+                    deterministicRouterCommandId+                        "router"+                        "key"+                        sourceEventId+                        (StreamName ("target-" <> Text.singleton '\x201'))+                        0+            colonLeft `shouldNotBe` colonRight+            unicodeLeft `shouldNotBe` unicodeRight++        it "resolves targets effectfully and fans out one command per target" $ \(_storeHandle, StoreRunner _runner) -> do+            Right () <-+                _runner $+                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+            Right () <- _runner $+                Store.runTransaction $ do+                    Tx.statement ("g1", "router-target-a") insertRouterTargetStmt+                    Tx.statement ("g1", "router-target-b") insertRouterTargetStmt+                    Tx.statement ("g1", "router-target-c") insertRouterTargetStmt+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+            Right (RouterResult rs1) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")+            length rs1 `shouldBe` 3+            rs1 `shouldSatisfy` all isAppended+            -- Data-dependence is load-bearing: an unseeded group resolves to no+            -- targets, so the count tracks the read model, not a fixed list.+            Right (RouterResult rsEmpty) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "no-such-group")+            length rsEmpty `shouldBe` 0+            -- Each resolved target stream received exactly one command.+            Right targetA <-+                _runner $+                    Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10+            Right targetB <-+                _runner $+                    Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10+            Right targetC <-+                _runner $+                    Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10+            Vector.length targetA `shouldBe` 1+            Vector.length targetB `shouldBe` 1+            Vector.length targetC `shouldBe` 1++        it "reports every dispatch as a duplicate on replay, writing no new events" $ \(_storeHandle, StoreRunner _runner) -> do+            Right () <-+                _runner $+                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+            Right () <- _runner $+                Store.runTransaction $ do+                    Tx.statement ("g1", "router-target-a") insertRouterTargetStmt+                    Tx.statement ("g1", "router-target-b") insertRouterTargetStmt+                    Tx.statement ("g1", "router-target-c") insertRouterTargetStmt+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+            Right (RouterResult rs1) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")+            rs1 `shouldSatisfy` all isAppended+            Right (RouterResult rs2) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")+            length rs2 `shouldBe` 3+            rs2 `shouldSatisfy` all isDuplicate+            -- Replay added nothing: each target stream still holds exactly one event.+            Right targetA <-+                _runner $+                    Store.readStreamForward (StreamName "router-target-a") (StreamVersion 0) 10+            Right targetB <-+                _runner $+                    Store.readStreamForward (StreamName "router-target-b") (StreamVersion 0) 10+            Right targetC <-+                _runner $+                    Store.readStreamForward (StreamName "router-target-c") (StreamVersion 0) 10+            Vector.length targetA `shouldBe` 1+            Vector.length targetB `shouldBe` 1+            Vector.length targetC `shouldBe` 1++        it "dedups by target identity when a redelivered resolve reorders targets after a partial dispatch" $ \(_storeHandle, StoreRunner _runner) -> do+            attemptsRef <- newIORef (0 :: Int)+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                router = unstableRouter attemptsRef $ \case+                    0 -> ["swap-a"]+                    _ -> ["swap-b", "swap-a"]+            Right (RouterResult firstAttempt) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+            firstAttempt `shouldSatisfy` all isAppended+            Right (RouterResult secondAttempt) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+            secondAttempt `shouldSatisfy` \case+                [swapB, swapA] -> isAppended swapB && isDuplicate swapA+                _ -> False+            Right swapAEvents <-+                _runner $+                    Store.readStreamForward (StreamName "swap-a") (StreamVersion 0) 10+            Right swapBEvents <-+                _runner $+                    Store.readStreamForward (StreamName "swap-b") (StreamVersion 0) 10+            Vector.length swapAEvents `shouldBe` 1+            Vector.length swapBEvents `shouldBe` 1++        it "dispatches a target added by resolve drift instead of misreading it as a duplicate" $ \(_storeHandle, StoreRunner _runner) -> do+            attemptsRef <- newIORef (0 :: Int)+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                router = unstableRouter attemptsRef $ \case+                    0 -> ["growth-a", "growth-b"]+                    _ -> ["growth-a", "growth-c"]+            Right (RouterResult firstAttempt) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+            firstAttempt `shouldSatisfy` all isAppended+            Right (RouterResult secondAttempt) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+            secondAttempt `shouldSatisfy` \case+                [growthA, growthC] -> isDuplicate growthA && isAppended growthC+                _ -> False+            Right growthAEvents <-+                _runner $+                    Store.readStreamForward (StreamName "growth-a") (StreamVersion 0) 10+            Right growthBEvents <-+                _runner $+                    Store.readStreamForward (StreamName "growth-b") (StreamVersion 0) 10+            Right growthCEvents <-+                _runner $+                    Store.readStreamForward (StreamName "growth-c") (StreamVersion 0) 10+            Vector.length growthAEvents `shouldBe` 1+            Vector.length growthBEvents `shouldBe` 1+            Vector.length growthCEvents `shouldBe` 1++        it "keeps full-completion order swaps idempotent" $ \(_storeHandle, StoreRunner _runner) -> do+            attemptsRef <- newIORef (0 :: Int)+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                router = unstableRouter attemptsRef $ \case+                    0 -> ["order-a", "order-b"]+                    _ -> ["order-b", "order-a"]+            Right (RouterResult firstAttempt) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+            firstAttempt `shouldSatisfy` all isAppended+            Right (RouterResult secondAttempt) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+            secondAttempt `shouldSatisfy` all isDuplicate+            Right orderAEvents <-+                _runner $+                    Store.readStreamForward (StreamName "order-a") (StreamVersion 0) 10+            Right orderBEvents <-+                _runner $+                    Store.readStreamForward (StreamName "order-b") (StreamVersion 0) 10+            Vector.length orderAEvents `shouldBe` 1+            Vector.length orderBEvents `shouldBe` 1++        it "keeps dispatches to targets dropped by a later resolve attempt" $ \(_storeHandle, StoreRunner _runner) -> do+            attemptsRef <- newIORef (0 :: Int)+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                router = unstableRouter attemptsRef $ \case+                    0 -> ["drop-a", "drop-b"]+                    _ -> ["drop-b"]+            Right (RouterResult firstAttempt) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+            firstAttempt `shouldSatisfy` all isAppended+            Right (RouterResult secondAttempt) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+            secondAttempt `shouldSatisfy` \case+                [dropB] -> isDuplicate dropB+                _ -> False+            -- Resolve is authoritative per attempt. Across redeliveries, the+            -- dispatched set is the union of each attempt's resolved targets.+            Right dropAEvents <-+                _runner $+                    Store.readStreamForward (StreamName "drop-a") (StreamVersion 0) 10+            Right dropBEvents <-+                _runner $+                    Store.readStreamForward (StreamName "drop-b") (StreamVersion 0) 10+            Vector.length dropAEvents `shouldBe` 1+            Vector.length dropBEvents `shouldBe` 1++        it "keeps repeated commands to one target distinct within a resolve batch" $ \(_storeHandle, StoreRunner _runner) -> do+            attemptsRef <- newIORef (0 :: Int)+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                router = unstableRouter attemptsRef (const ["twin", "twin"])+            Right (RouterResult firstAttempt) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+            firstAttempt `shouldSatisfy` all isAppended+            Right twinEventsAfterFirstAttempt <-+                _runner $+                    Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10+            Vector.length twinEventsAfterFirstAttempt `shouldBe` 2+            Right (RouterResult secondAttempt) <-+                _runner $+                    runRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1")+            secondAttempt `shouldSatisfy` all isDuplicate+            Right twinEventsAfterSecondAttempt <-+                _runner $+                    Store.readStreamForward (StreamName "twin") (StreamVersion 0) 10+            Vector.length twinEventsAfterSecondAttempt `shouldBe` 2++        it "drains an adapter, dispatching one command per resolved target for every message" $ \(_storeHandle, StoreRunner _runner) -> do+            Right () <-+                _runner $+                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+            Right () <- _runner $+                Store.runTransaction $ do+                    Tx.statement ("g1", "worker-a") insertRouterTargetStmt+                    Tx.statement ("g1", "worker-b") insertRouterTargetStmt+                    Tx.statement ("g2", "worker-c") insertRouterTargetStmt+            decisionsRef <- newIORef []+            let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)+                messages =+                    [ (sourceEvent1, RouteGroup "g1")+                    , (sourceEvent2, RouteGroup "g2")+                    ]+                adapter = inMemoryAdapter decisionsRef messages+            Right () <-+                _runner $+                    runRouterWorker defaultRunCommandOptions demoRouter adapter Just+            decisions <- readIORef decisionsRef+            decisions `shouldBe` [AckOk, AckOk]+            Right wa <-+                _runner $+                    Store.readStreamForward (StreamName "worker-a") (StreamVersion 0) 10+            Right wb <-+                _runner $+                    Store.readStreamForward (StreamName "worker-b") (StreamVersion 0) 10+            Right wc <-+                _runner $+                    Store.readStreamForward (StreamName "worker-c") (StreamVersion 0) 10+            Vector.length wa `shouldBe` 1+            Vector.length wb `shouldBe` 1+            Vector.length wc `shouldBe` 1++        it "finalizes AckHalt rather than AckOk when a dispatched command fails" $ \(_storeHandle, StoreRunner _runner) -> do+            decisionsRef <- newIORef []+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                messages = [(sourceEvent, RouteGroup "g1")]+                adapter = inMemoryAdapter decisionsRef messages+            Right () <-+                _runner $+                    runRouterWorker defaultRunCommandOptions failingRouter adapter Just+            decisions <- readIORef decisionsRef+            decisions `shouldSatisfy` \case+                [AckHalt (HaltFatal _)] -> True+                _ -> False++        it "dead-letters a rejected router dispatch and acknowledges the source event" $ \(_storeHandle, StoreRunner _runner) -> do+            decisionsRef <- newIORef []+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                adapter = inMemoryAdapter decisionsRef [(sourceEvent, RouteGroup "g1")]+                workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter+            Right () <-+                _runner $+                    runRouterWorkerWith workerOptions defaultRunCommandOptions failingRouter adapter Just+            readIORef decisionsRef `shouldReturn` [AckOk]+            Right deadLetters <- _runner (listDispatchDeadLetters "failing-router")+            case deadLetters of+                [row] -> do+                    row ^. #dispatcherKind `shouldBe` DispatcherRouter+                    row ^. #correlationId `shouldBe` "g1"+                    row ^. #targetStreamName `shouldBe` StreamName "failing-target"+                    row ^. #errorClass `shouldBe` "command_rejected"+                other -> expectationFailure ("expected one router dead letter, got " <> show other)++        it "finalizes AckRetry for a transient thrown resolver error and continues" $ \(_storeHandle, StoreRunner _runner) -> do+            Right () <-+                _runner $+                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+            Right () <-+                _runner $+                    Store.runTransaction (Tx.statement ("g2", "worker-after-retry") insertRouterTargetStmt)+            decisionsRef <- newIORef []+            attemptsRef <- newIORef (0 :: Int)+            let sourceEvent1 = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                sourceEvent2 = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)+                messages = [(sourceEvent1, RouteGroup "g1"), (sourceEvent2, RouteGroup "g2")]+                adapter = inMemoryAdapter decisionsRef messages+                flakyRouter ::+                    (IOE :> es, Store :> es, Error Store.StoreError :> es) =>+                    Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es+                flakyRouter =+                    Router+                        { name = "flaky-router"+                        , key = \(RouteGroup g) -> g+                        , resolve = \(RouteGroup g) -> do+                            attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n)))+                            if attempt == 0+                                then throwError (Store.ConnectionLost "injected")+                                else do+                                    result <- runQuery Nothing routerTargetsReadModel g+                                    pure $ case result of+                                        Right targetIds ->+                                            [ PMCommand{target = stream targetId, command = Add 1}+                                            | targetId <- targetIds+                                            ]+                                        Left _ -> []+                        , targetEventStream = counterEventStream+                        , targetProjections = const []+                        }+            Right () <-+                _runner $+                    runRouterWorker defaultRunCommandOptions flakyRouter adapter Just+            decisions <- readIORef decisionsRef+            decisions `shouldSatisfy` \case+                [AckRetry{}, AckOk] -> True+                _ -> False++        it "finalizes AckHalt for a deterministic thrown resolver error" $ \(_storeHandle, StoreRunner _runner) -> do+            decisionsRef <- newIORef []+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                messages = [(sourceEvent, RouteGroup "g1")]+                adapter = inMemoryAdapter decisionsRef messages+                failingResolveRouter ::+                    (Error Store.StoreError :> es) =>+                    Router RouteGroup (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent es+                failingResolveRouter =+                    Router+                        { name = "failing-resolve-router"+                        , key = \(RouteGroup g) -> g+                        , resolve = \_ -> throwError (Store.UnexpectedServerError "XX000" "boom")+                        , targetEventStream = counterEventStream+                        , targetProjections = const []+                        }+            Right () <-+                _runner $+                    runRouterWorker defaultRunCommandOptions failingResolveRouter adapter Just+            decisions <- readIORef decisionsRef+            decisions `shouldSatisfy` \case+                [AckHalt (HaltFatal _)] -> True+                _ -> False++        it "folds a concurrent duplicate router dispatch to PMCommandDuplicate" $ \(_storeHandle, StoreRunner _runner) -> do+            Right () <-+                _runner $+                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+            Right () <-+                _runner $+                    Store.runTransaction (Tx.statement ("g1", "router-duplicate-target") insertRouterTargetStmt)+            insertCount <- newIORef (0 :: Int)+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                targetStreamName = StreamName "router-duplicate-target"+                commandId =+                    deterministicRouterCommandId+                        "demo-router"+                        "g1"+                        (sourceEvent ^. #eventId)+                        targetStreamName+                        0+                insertConcurrentTarget = do+                    callNo <- atomicModifyIORef' insertCount (\n -> (n + 1, n))+                    when (callNo == 0) $ appendCounterEventWithId _storeHandle targetStreamName commandId (CounterAdded 1)+                options =+                    defaultRunCommandOptions+                        & #beforeAppend+                        .~ insertConcurrentTarget+                        & #retryBackoffMicros+                        .~ 0+            result <-+                _runner $+                    runRouterOnce options demoRouter sourceEvent (RouteGroup "g1")+            case result of+                Right (RouterResult [PMCommandDuplicate duplicateId]) ->+                    duplicateId `shouldBe` commandId+                other -> expectationFailure ("expected duplicate router dispatch fold, got " <> show other)+            Right targetEvents <-+                _runner $+                    Store.readStreamForward targetStreamName (StreamVersion 0) 10+            Vector.length targetEvents `shouldBe` 1++        it "dedups a pre-upgrade positional router dispatch during the transition" $ \(_storeHandle, StoreRunner _runner) -> do+            Right () <-+                _runner $+                    initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+            Right () <-+                _runner $+                    Store.runTransaction (Tx.statement ("g1", "transition-target") insertRouterTargetStmt)+            let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+                legacyId = deterministicCommandId "demo-router" "g1" (sourceEvent ^. #eventId) 0+                targetStreamName = StreamName "transition-target"+            appendCounterEventWithId _storeHandle targetStreamName legacyId (CounterAdded 1)+            result <-+                _runner $+                    runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup "g1")+            case result of+                Right (RouterResult [PMCommandDuplicate duplicateId]) ->+                    duplicateId `shouldBe` legacyId+                other -> expectationFailure ("expected transition duplicate, got " <> show other)+            Right targetEvents <-+                _runner $+                    Store.readStreamForward targetStreamName (StreamVersion 0) 10+            Vector.length targetEvents `shouldBe` 1++    describe "Keiro.Timer" $ around (withFreshStore fixture) $ do+        it "validates worker options before startup" $ \_storeHandle -> do+            shouldBeRight_ (mkTimerWorkerOptions defaultTimerWorkerOptions)+            mkTimerWorkerOptions (defaultTimerWorkerOptions & #maxAttempts ?~ (-1))+                `shouldBeLeft` InvalidTimerMaxAttempts (-1)+            mkTimerWorkerOptions (defaultTimerWorkerOptions & #requeueStuckAfter ?~ 0)+                `shouldBeLeft` InvalidTimerRequeueStuckAfter 0++        it "claims a due timer, fires a command, and marks it complete once" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        scheduleTimerTx counterTimerRequest+            let firedEventId = EventId sampleUuid2+            workerResult <- Store.runStoreIO storeHandle $+                runTimerWorker Nothing dueTimerTime $ \_ -> do+                    fired <-+                        runCommand+                            (defaultRunCommandOptions & #eventIds .~ [firedEventId])+                            counterEventStream+                            (stream "timer-target")+                            (Add 11)+                    case fired of+                        Right _ -> pure (Just firedEventId)+                        Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing+            case workerResult of+                Right (Just timer) ->+                    timer ^. #status `shouldBe` Firing+                other -> expectationFailure ("expected fired timer, got " <> show other)+            secondWorkerResult <-+                Store.runStoreIO storeHandle $+                    runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId))+            secondWorkerResult `shouldBe` Right Nothing+            Right targetEvents <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10+            fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId]++        it "records timer backlog, fire lag, attempts, and stuck count" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        scheduleTimerTx counterTimerRequest+            let firedEventId = EventId sampleUuid2+            workerResult <-+                Store.runStoreIO storeHandle $+                    runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure (Just firedEventId))+            case workerResult of+                Right (Just _) -> pure ()+                other -> expectationFailure ("expected a fired timer, got " <> show other)+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+                hists = flattenHistogramPoints exported+            -- One scheduled+due row at the start of the pass: backlog gauge holds 1.+            lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 1)+            -- Nothing was stranded in 'firing' before this pass: stuck gauge holds 0.+            lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 0)+            -- The claimed timer was due exactly at 'now' and is on its first attempt:+            -- one fire.lag observation of 0 ms and one attempts observation of 1.+            [(c, s) | (n, c, s) <- hists, n == "keiro.timer.fire.lag"] `shouldBe` [(1, 0.0)]+            [(c, s) | (n, c, s) <- hists, n == "keiro.timer.attempts"] `shouldBe` [(1, 1.0)]++        it "finds a firing timer with findStuckTimers and requeues it for re-firing" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        scheduleTimerTx counterTimerRequest+            -- Strand it in Firing by claiming without firing.+            claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+            case claimed of+                Right (Just timer) -> timer ^. #status `shouldBe` Firing+                other -> expectationFailure ("expected a claimed timer, got " <> show other)+            -- It surfaces as stuck under the permissive filter.+            Right stuck <-+                Store.runStoreIO storeHandle $+                    findStuckTimers dueTimerTime anyStuckTimer+            fmap (^. #timerId) stuck `shouldBe` [counterTimerRequest ^. #timerId]+            -- A bound it does not meet (only one attempt) excludes it.+            Right unmatched <-+                Store.runStoreIO storeHandle $+                    findStuckTimers dueTimerTime (StuckTimerFilter Nothing (Just 5))+            unmatched `shouldBe` []+            -- Requeue is idempotent: True the first time, False once it is scheduled.+            requeued <-+                Store.runStoreIO storeHandle $+                    requeueStuckTimer (counterTimerRequest ^. #timerId)+            requeued `shouldBe` Right True+            requeuedAgain <-+                Store.runStoreIO storeHandle $+                    requeueStuckTimer (counterTimerRequest ^. #timerId)+            requeuedAgain `shouldBe` Right False+            -- The ordinary loop re-claims and fires it exactly once.+            let firedEventId = EventId sampleUuid2+            workerResult <- Store.runStoreIO storeHandle $+                runTimerWorker Nothing dueTimerTime $ \_ -> do+                    fired <-+                        runCommand+                            (defaultRunCommandOptions & #eventIds .~ [firedEventId])+                            counterEventStream+                            (stream "timer-target")+                            (Add 7)+                    case fired of+                        Right _ -> pure (Just firedEventId)+                        Left err -> liftIO (expectationFailure ("expected timer command to fire, got " <> show err)) *> pure Nothing+            case workerResult of+                Right (Just timer) ->+                    timer ^. #status `shouldBe` Firing+                other -> expectationFailure ("expected re-fired timer, got " <> show other)+            secondWorkerResult <-+                Store.runStoreIO storeHandle $+                    runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId))+            secondWorkerResult `shouldBe` Right Nothing+            Right targetEvents <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "timer-target") (StreamVersion 0) 10+            fmap (^. #eventId) (Vector.toList targetEvents) `shouldBe` [firedEventId]++        it "re-fires a timer stranded by a crashed worker" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        scheduleTimerTx counterTimerRequest+            Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+            claimed ^. #status `shouldBe` Firing+            realNow <- getCurrentTime+            firedRef <- newIORef []+            let futureNow = addUTCTime 400 realNow+                firedEventId = EventId sampleUuid2+            workerResult <-+                Store.runStoreIO storeHandle $+                    runTimerWorker Nothing futureNow $ \timer -> do+                        liftIO (modifyIORef' firedRef (<> [timer ^. #timerId]))+                        pure (Just firedEventId)+            case workerResult of+                Right (Just timer) -> timer ^. #timerId `shouldBe` counterTimerRequest ^. #timerId+                other -> expectationFailure ("expected stale timer to be requeued and claimed, got " <> show other)+            firedTimers <- readIORef firedRef+            firedTimers `shouldBe` [counterTimerRequest ^. #timerId]+            Right statusRow <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement sampleUuid timerStatusAndErrorStmt+            statusRow `shouldBe` Just ("fired", Nothing)+            secondWorkerResult <-+                Store.runStoreIO storeHandle $+                    runTimerWorker Nothing futureNow (\_ -> pure (Just firedEventId))+            secondWorkerResult `shouldBe` Right Nothing++        it "does not requeue a fresh firing row" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        scheduleTimerTx counterTimerRequest+            Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+            realNow <- getCurrentTime+            firedRef <- newIORef False+            workerResult <-+                Store.runStoreIO storeHandle $+                    runTimerWorker Nothing realNow $ \_ -> do+                        liftIO (writeIORef firedRef True)+                        pure (Just (EventId sampleUuid2))+            workerResult `shouldBe` Right Nothing+            didFire <- readIORef firedRef+            didFire `shouldBe` False+            Right statusRow <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement sampleUuid timerStatusAndErrorStmt+            statusRow `shouldBe` Just ("firing", Nothing)++        it "requeueStuckAfter = Nothing preserves a stranded firing row" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        scheduleTimerTx counterTimerRequest+            Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+            realNow <- getCurrentTime+            firedRef <- newIORef False+            let opts = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing+            workerResult <-+                Store.runStoreIO storeHandle $+                    runTimerWorkerWith Nothing opts (addUTCTime 400 realNow) $ \_ -> do+                        liftIO (writeIORef firedRef True)+                        pure (Just (EventId sampleUuid2))+            workerResult `shouldBe` Right Nothing+            didFire <- readIORef firedRef+            didFire `shouldBe` False+            Right statusRow <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement sampleUuid timerStatusAndErrorStmt+            statusRow `shouldBe` Just ("firing", Nothing)++        it "does not claim a cancelled timer" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        scheduleTimerTx counterTimerRequest+            cancelled <-+                Store.runStoreIO storeHandle $+                    cancelTimer (counterTimerRequest ^. #timerId)+            cancelled `shouldBe` Right True+            claimed <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+            claimed `shouldBe` Right Nothing+            cancelledAgain <-+                Store.runStoreIO storeHandle $+                    cancelTimer (counterTimerRequest ^. #timerId)+            cancelledAgain `shouldBe` Right False++        it "dead-letters a timer that exceeds the attempt ceiling and never reclaims it" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        scheduleTimerTx counterTimerRequest+            firedRef <- newIORef False+            let firedEventId = EventId sampleUuid2+            -- maxAttempts = Just 0: the first claim sets attempts = 1 > 0, so the+            -- worker dead-letters instead of firing.+            result <- Store.runStoreIO storeHandle $+                runTimerWorkerWith Nothing (defaultTimerWorkerOptions & #maxAttempts .~ Just 0) dueTimerTime $ \_ -> do+                    liftIO (writeIORef firedRef True)+                    pure (Just firedEventId)+            case result of+                Right (Just timer) ->+                    timer ^. #status `shouldBe` Firing+                other -> expectationFailure ("expected a claimed timer, got " <> show other)+            -- The fire action never ran.+            didFire <- readIORef firedRef+            didFire `shouldBe` False+            -- The row landed in 'dead' with the expected reason in last_error.+            Right statusRow <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement sampleUuid timerStatusAndErrorStmt+            statusRow `shouldBe` Just ("dead", Just "timer exceeded attempt ceiling of 0")+            -- A dead row is never re-claimed.+            secondWorkerResult <-+                Store.runStoreIO storeHandle $+                    runTimerWorker Nothing dueTimerTime (\_ -> pure (Just firedEventId))+            secondWorkerResult `shouldBe` Right Nothing++        it "markTimerFired does not resurrect a dead timer" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        scheduleTimerTx counterTimerRequest+            Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+            deadened <-+                Store.runStoreIO storeHandle $+                    deadLetterTimer (counterTimerRequest ^. #timerId) "operator dead-letter"+            deadened `shouldBe` Right True+            marked <-+                Store.runStoreIO storeHandle $+                    markTimerFired (counterTimerRequest ^. #timerId) (EventId sampleUuid2)+            marked `shouldBe` Right False+            Right statusRow <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement sampleUuid timerStatusAndErrorStmt+            statusRow `shouldBe` Just ("dead", Just "operator dead-letter")++        it "records a row stranded in Firing in the stuck gauge" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        scheduleTimerTx counterTimerRequest+            -- Strand it in Firing by claiming without firing (a crashed worker).+            Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+            -- A later pass finds nothing scheduled and due, but sees the stranded row.+            workerResult <-+                Store.runStoreIO storeHandle $+                    runTimerWorker (Just keiroMetrics) dueTimerTime (\_ -> pure Nothing)+            workerResult `shouldBe` Right Nothing+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+            -- The one firing row is counted as stuck.+            lookup "keiro.timer.stuck" scalars `shouldBe` Just (IntNumber 1)+            -- It is not 'scheduled', so it does not show up as backlog.+            lookup "keiro.timer.backlog" scalars `shouldBe` Just (IntNumber 0)++    describe "Keiro.Outbox.Kafka" $ do+        it "converts an outbox row to a Kafka producer record" $ do+            let envelope = sampleIntegrationEnvelope+                row = sampleOutboxRow envelope+                record = OutboxKafka.outboxRowToKafkaRecord row+            record ^. #topic `shouldBe` envelope ^. #destination+            record ^. #key `shouldBe` Just "order-123"+            record ^. #payload `shouldBe` envelope ^. #payloadBytes+            -- Headers include identity fields and content type.+            let headers = record ^. #headers+                messageIdHeader = Prelude.lookup "keiro-message-id" headers+            messageIdHeader `shouldBe` Just "018f0f18-17aa-7000-8000-0000000000aa"++        it "drops the partition key when the envelope has no key" $ do+            let envelope = sampleIntegrationEnvelope & #key .~ Nothing+                record = OutboxKafka.integrationEventToKafkaRecord envelope+            record ^. #key `shouldBe` Nothing++    describe "Keiro.Outbox" $ around (withFreshStore fixture) $ do+        it "validates publisher options before startup" $ \_storeHandle -> do+            shouldBeRight_ (mkOutboxPublishOptions defaultPublishOptions)+            mkOutboxPublishOptions (defaultPublishOptions & #batchSize .~ 0)+                `shouldBeLeft` InvalidOutboxBatchSize 0+            mkOutboxPublishOptions (defaultPublishOptions & #maxAttempts .~ 0)+                `shouldBeLeft` InvalidOutboxMaxAttempts 0+            mkOutboxPublishOptions (defaultPublishOptions & #publishingTimeout .~ 0)+                `shouldBeLeft` InvalidOutboxPublishingTimeout 0+            mkOutboxPublishOptions (defaultPublishOptions & #backoff .~ ConstantBackoff (-1))+                `shouldBeLeft` InvalidConstantBackoff (-1)+            mkOutboxPublishOptions+                ( defaultPublishOptions+                    & #backoff+                    .~ ExponentialBackoff+                        ExponentialBackoffOptions+                            { initial = 0+                            , maxDelay = 1+                            , multiplier = 2+                            }+                )+                `shouldBeLeft` InvalidExponentialBackoffInitial 0+            mkOutboxPublishOptions+                ( defaultPublishOptions+                    & #backoff+                    .~ ExponentialBackoff+                        ExponentialBackoffOptions+                            { initial = 1+                            , maxDelay = 10+                            , multiplier = 0.5+                            }+                )+                `shouldBeLeft` InvalidExponentialBackoffMultiplier 0.5+            mkOutboxPublishOptions+                ( defaultPublishOptions+                    & #backoff+                    .~ ExponentialBackoff+                        ExponentialBackoffOptions+                            { initial = 5+                            , maxDelay = 4+                            , multiplier = 2+                            }+                )+                `shouldBeLeft` InvalidExponentialBackoffMaxDelay 5 4++        it "enqueues and looks up an outbox row" $ \storeHandle -> do+            let envelope = sampleIntegrationEnvelope+                oid = OutboxId outboxUuid1+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx oid envelope)+            lookedUp <- Store.runStoreIO storeHandle (lookupOutbox oid)+            case lookedUp of+                Right (Just row) -> do+                    row ^. #outboxId `shouldBe` oid+                    row ^. #status `shouldBe` OutboxPending+                    row ^. #attemptCount `shouldBe` 0+                    row ^. #event . #messageId `shouldBe` envelope ^. #messageId+                    row ^. #event . #destination `shouldBe` envelope ^. #destination+                    row ^. #event . #payloadBytes `shouldBe` envelope ^. #payloadBytes+                other -> expectationFailure ("expected enqueued row, got " <> show other)++        it "claims a pending row, transitions it to publishing, and increments attempt count" $ \storeHandle -> do+            let oid = OutboxId outboxUuid1+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+            now <- getCurrentTime+            Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            case rows of+                [row] -> do+                    row ^. #outboxId `shouldBe` oid+                    row ^. #status `shouldBe` OutboxPublishing+                    row ^. #attemptCount `shouldBe` 1+                other -> expectationFailure ("expected one claimed row, got " <> show other)++        it "claims contiguous per-key runs in one pass" $ \storeHandle -> do+            let keyedRows =+                    [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "run-a1" & #key .~ Just "A")+                    , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "run-a2" & #key .~ Just "A")+                    , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "run-a3" & #key .~ Just "A")+                    , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "run-a4" & #key .~ Just "A")+                    , (outboxIdFromOrdinal 5, sampleIntegrationEnvelope & #messageId .~ "run-a5" & #key .~ Just "A")+                    , (outboxIdFromOrdinal 6, sampleIntegrationEnvelope & #messageId .~ "run-b1" & #key .~ Just "B")+                    , (outboxIdFromOrdinal 7, sampleIntegrationEnvelope & #messageId .~ "run-b2" & #key .~ Just "B")+                    , (outboxIdFromOrdinal 8, sampleIntegrationEnvelope & #messageId .~ "run-b3" & #key .~ Just "B")+                    ]+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        traverse_ (uncurry enqueueIntegrationEventTx) keyedRows+            now <- getCurrentTime+            Right rows <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            fmap (^. #outboxId) rows `shouldBe` fmap fst keyedRows+            fmap (^. #attemptCount) rows `shouldBe` replicate 8 1++        it "does not let a backoff head starve other keys" $ \storeHandle -> do+            let a1Id = outboxIdFromOrdinal 1+                a2Id = outboxIdFromOrdinal 2+                b1Id = outboxIdFromOrdinal 3+                b2Id = outboxIdFromOrdinal 4+                rows =+                    [ (a1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a1" & #key .~ Just "A")+                    , (a2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-a2" & #key .~ Just "A")+                    , (b1Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b1" & #key .~ Just "B")+                    , (b2Id, sampleIntegrationEnvelope & #messageId .~ "backoff-b2" & #key .~ Just "B")+                    ]+                failA1 row+                    | row ^. #outboxId == a1Id = pure (PublishFailed "wait")+                    | otherwise = pure PublishSucceeded+                opts =+                    defaultPublishOptions+                        & #batchSize+                        .~ 1+                        & #backoff+                        .~ ConstantBackoff 3600+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        traverse_ (uncurry enqueueIntegrationEventTx) rows+            Right failedPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow failA1) opts Nothing)+            failedPass ^. #retried `shouldBe` 1+            now <- getCurrentTime+            Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            fmap (^. #outboxId) claimed `shouldBe` [b1Id, b2Id]+            Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id)+            a2Row ^. #status `shouldBe` OutboxPending++        it "claims contiguous per-source runs in one pass" $ \storeHandle -> do+            let rows =+                    [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "source-a1" & #key .~ Just "A")+                    , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "source-b1" & #key .~ Just "B")+                    , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "source-a2" & #key .~ Just "A")+                    , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "source-b2" & #key .~ Just "B")+                    ]+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        traverse_ (uncurry enqueueIntegrationEventTx) rows+            now <- getCurrentTime+            Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerSourceStream 10 now)+            fmap (^. #outboxId) claimed `shouldBe` fmap fst rows++        it "claims null-keyed rows freely alongside keyed runs" $ \storeHandle -> do+            let rows =+                    [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "null-1" & #key .~ Nothing)+                    , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "keyed-1" & #key .~ Just "A")+                    , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "null-2" & #key .~ Nothing)+                    , (outboxIdFromOrdinal 4, sampleIntegrationEnvelope & #messageId .~ "keyed-2" & #key .~ Just "A")+                    ]+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        traverse_ (uncurry enqueueIntegrationEventTx) rows+            now <- getCurrentTime+            Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            fmap (^. #outboxId) claimed `shouldBe` fmap fst rows++        it "does not claim a tail while the previous run is still publishing" $ \storeHandle -> do+            let rows =+                    [ (outboxIdFromOrdinal 1, sampleIntegrationEnvelope & #messageId .~ "publishing-a1" & #key .~ Just "A")+                    , (outboxIdFromOrdinal 2, sampleIntegrationEnvelope & #messageId .~ "publishing-a2" & #key .~ Just "A")+                    , (outboxIdFromOrdinal 3, sampleIntegrationEnvelope & #messageId .~ "publishing-a3" & #key .~ Just "A")+                    ]+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        traverse_ (uncurry enqueueIntegrationEventTx) rows+            now <- getCurrentTime+            Right firstClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            fmap (^. #outboxId) firstClaim `shouldBe` fmap fst rows+            Right secondClaim <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            secondClaim `shouldBe` []++        it "marks a claimed row as sent with published_at set" $ \storeHandle -> do+            let oid = OutboxId outboxUuid1+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+            now <- getCurrentTime+            Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now)+            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+            row ^. #status `shouldBe` OutboxSent+            row ^. #publishedAt `shouldSatisfy` isJust+            row ^. #lastError `shouldBe` Nothing++        it "reclaims a row stranded in publishing by a crashed worker through maintenance" $ \storeHandle -> do+            let oid = OutboxId outboxUuid1+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+            now <- getCurrentTime+            let pastNow = addUTCTime (-3600) now+            Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow)+            Right (Just stranded) <- Store.runStoreIO storeHandle (lookupOutbox oid)+            stranded ^. #status `shouldBe` OutboxPublishing+            publishedRef <- newIORef (0 :: Int)+            let publish _ = do+                    liftIO (modifyIORef' publishedRef (+ 1))+                    pure PublishSucceeded+            Right noPublish <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+            noPublish ^. #claimed `shouldBe` 0+            Right (Just stillStranded) <- Store.runStoreIO storeHandle (lookupOutbox oid)+            stillStranded ^. #status `shouldBe` OutboxPublishing+            Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing)+            maintenance ^. #requeued `shouldBe` 1+            maintenance ^. #deadLettered `shouldBe` 0+            Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+            summary ^. #published `shouldBe` 1+            published <- readIORef publishedRef+            published `shouldBe` 1+            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+            row ^. #status `shouldBe` OutboxSent++        it "head-of-line traffic unwedges after reclaim" $ \storeHandle -> do+            let firstId = OutboxId outboxUuid1+                secondId = OutboxId outboxUuid2+                first = sampleIntegrationEnvelope & #messageId .~ "stuck-first" & #key .~ Just "same-key"+                second = sampleIntegrationEnvelope & #messageId .~ "stuck-second" & #key .~ Just "same-key"+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx firstId first)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx secondId second)+            now <- getCurrentTime+            let pastNow = addUTCTime (-3600) now+            Right [claimedFirst] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 1 now)+            claimedFirst ^. #outboxId `shouldBe` firstId+            Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt firstId pastNow)+            publishedRef <- newIORef []+            let publish row = do+                    liftIO (modifyIORef' publishedRef (<> [row ^. #outboxId]))+                    pure PublishSucceeded+            Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing)+            maintenance ^. #requeued `shouldBe` 1+            Right firstPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+            firstPass ^. #published `shouldBe` 2+            Right secondPass <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+            secondPass ^. #published `shouldBe` 0+            published <- readIORef publishedRef+            published `shouldBe` [firstId, secondId]+            Right (Just secondRow) <- Store.runStoreIO storeHandle (lookupOutbox secondId)+            secondRow ^. #status `shouldBe` OutboxSent++        it "does not reclaim a recently claimed row" $ \storeHandle -> do+            let oid = OutboxId outboxUuid1+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+            now <- getCurrentTime+            Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            publishedRef <- newIORef (0 :: Int)+            let publish _ = do+                    liftIO (modifyIORef' publishedRef (+ 1))+                    pure PublishSucceeded+            Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+            summary ^. #claimed `shouldBe` 0+            published <- readIORef publishedRef+            published `shouldBe` 0+            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+            row ^. #status `shouldBe` OutboxPublishing++        it "a throwing batch publish callback fails every row in that publish call" $ \storeHandle -> do+            let throwId = OutboxId outboxUuid1+                okId = OutboxId outboxUuid2+                throwEvent = sampleIntegrationEnvelope & #messageId .~ "throwing-publish" & #key .~ Just "throw-key"+                okEvent = sampleIntegrationEnvelope & #messageId .~ "ok-after-throw" & #key .~ Just "ok-key"+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx throwId throwEvent)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx okId okEvent)+            let publish row+                    | row ^. #outboxId == throwId = liftIO (throwIO (userError "kafka exploded"))+                    | otherwise = pure PublishSucceeded+            Right summary <-+                Store.runStoreIO storeHandle $+                    publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing+            summary ^. #retried `shouldBe` 2+            summary ^. #published `shouldBe` 0+            Right (Just throwRow) <- Store.runStoreIO storeHandle (lookupOutbox throwId)+            throwRow ^. #status `shouldBe` OutboxFailed+            throwRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded")+            Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId)+            okRow ^. #status `shouldBe` OutboxFailed+            okRow ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "kafka exploded")++        it "a row that exhausts attempts while crash-looping is dead-lettered by maintenance" $ \storeHandle -> do+            let oid = OutboxId outboxUuid1+                opts = defaultMaintenanceOptions & #maxAttempts .~ 1+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+            now <- getCurrentTime+            let pastNow = addUTCTime (-3600) now+            Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid pastNow)+            Right summary <- Store.runStoreIO storeHandle (outboxMaintenancePass opts Nothing)+            summary ^. #requeued `shouldBe` 0+            summary ^. #deadLettered `shouldBe` 1+            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+            row ^. #status `shouldBe` OutboxDead++        it "markOutboxSent does not resurrect a dead row" $ \storeHandle -> do+            let oid = OutboxId outboxUuid1+                opts = defaultPublishOptions & #maxAttempts .~ 1 & #backoff .~ ConstantBackoff 0+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+            let publish _ = pure (PublishFailed "boom")+            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)+            now <- getCurrentTime+            Right marked <- Store.runStoreIO storeHandle (markOutboxSent oid now)+            marked `shouldBe` False+            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+            row ^. #status `shouldBe` OutboxDead++        it "publishClaimedOutbox marks success and records failures with last_error" $ \storeHandle -> do+            let okId = OutboxId outboxUuid1+                failId = OutboxId outboxUuid2+                okEvent = sampleIntegrationEnvelope+                failEvent =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "msg-fail-1"+                        & #key+                        .~ Just "order-789"+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx okId okEvent)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx failId failEvent)+            let publish row+                    | row ^. #outboxId == okId = pure PublishSucceeded+                    | otherwise = pure (PublishFailed "broker unreachable")+            Right summary <-+                Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing)+            summary ^. #claimed `shouldBe` 2+            summary ^. #published `shouldBe` 1+            summary ^. #retried `shouldBe` 1+            summary ^. #dead `shouldBe` 0+            Right (Just okRow) <- Store.runStoreIO storeHandle (lookupOutbox okId)+            okRow ^. #status `shouldBe` OutboxSent+            Right (Just failRow) <- Store.runStoreIO storeHandle (lookupOutbox failId)+            failRow ^. #status `shouldBe` OutboxFailed+            failRow ^. #lastError `shouldBe` Just "broker unreachable"++        it "publishClaimedOutbox hands a same-key run to one batch publish call" $ \storeHandle -> do+            let rows =+                    [ (outboxIdFromOrdinal (fromIntegral i), sampleIntegrationEnvelope & #messageId .~ ("batch-ok-" <> Text.pack (show i)) & #key .~ Just "batch-key")+                    | i <- [1 .. 10 :: Int]+                    ]+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        traverse_ (uncurry enqueueIntegrationEventTx) rows+            invocationRef <- newIORef (0 :: Int)+            let publish claimed = do+                    liftIO (modifyIORef' invocationRef (+ 1))+                    pure [(row ^. #outboxId, PublishSucceeded) | row <- claimed]+            Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)+            summary ^. #claimed `shouldBe` 10+            summary ^. #published `shouldBe` 10+            invocations <- readIORef invocationRef+            invocations `shouldBe` 1+            for_ (fmap fst rows) $ \oid -> do+                Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+                row ^. #status `shouldBe` OutboxSent++        it "publishClaimedOutbox skips the same-key suffix after a mid-run failure" $ \storeHandle -> do+            let row1Id = outboxIdFromOrdinal 1+                row2Id = outboxIdFromOrdinal 2+                row3Id = outboxIdFromOrdinal 3+                row4Id = outboxIdFromOrdinal 4+                row5Id = outboxIdFromOrdinal 5+                ids = [row1Id, row2Id, row3Id, row4Id, row5Id]+                rows =+                    [ (oid, sampleIntegrationEnvelope & #messageId .~ ("batch-fail-" <> Text.pack (show i)) & #key .~ Just "batch-fail-key")+                    | (i, oid) <- zip [1 .. 5 :: Int] ids+                    ]+                publish claimed =+                    pure+                        [ ( row ^. #outboxId+                          , if row ^. #outboxId == row3Id+                                then PublishFailed "pivot failed"+                                else PublishSucceeded+                          )+                        | row <- claimed+                        ]+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        traverse_ (uncurry enqueueIntegrationEventTx) rows+            Right summary <-+                Store.runStoreIO storeHandle $+                    publishClaimedOutbox publish (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing+            summary ^. #published `shouldBe` 2+            summary ^. #retried `shouldBe` 3+            Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id)+            Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id)+            Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id)+            Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id)+            Right (Just row5) <- Store.runStoreIO storeHandle (lookupOutbox row5Id)+            row1 ^. #status `shouldBe` OutboxSent+            row2 ^. #status `shouldBe` OutboxSent+            row3 ^. #status `shouldBe` OutboxFailed+            row3 ^. #attemptCount `shouldBe` 1+            row3 ^. #lastError `shouldBe` Just "pivot failed"+            row4 ^. #status `shouldBe` OutboxFailed+            row4 ^. #attemptCount `shouldBe` 0+            row4 ^. #lastError `shouldBe` Just "skipped: earlier record for the same key failed"+            row5 ^. #status `shouldBe` OutboxFailed+            row5 ^. #attemptCount `shouldBe` 0++        it "PerSourceStream keeps one source's failure from skipping another source's rows" $ \storeHandle -> do+            let rowA1 = outboxIdFromOrdinal 1+                rowB1 = outboxIdFromOrdinal 2+                rowA2 = outboxIdFromOrdinal 3+                rowB2 = outboxIdFromOrdinal 4+                mkRow oid src msgId =+                    (oid, sampleIntegrationEnvelope & #messageId .~ msgId & #source .~ src & #key .~ Nothing)+                rows =+                    [ mkRow rowA1 "per-source-a" "ps-a1"+                    , mkRow rowB1 "per-source-b" "ps-b1"+                    , mkRow rowA2 "per-source-a" "ps-a2"+                    , mkRow rowB2 "per-source-b" "ps-b2"+                    ]+                publish claimed =+                    pure+                        [ ( row ^. #outboxId+                          , if row ^. #outboxId == rowA2+                                then PublishFailed "source-a pivot failed"+                                else PublishSucceeded+                          )+                        | row <- claimed+                        ]+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        traverse_ (uncurry enqueueIntegrationEventTx) rows+            Right summary <-+                Store.runStoreIO storeHandle $+                    publishClaimedOutbox publish (defaultPublishOptions & #orderingPolicy .~ PerSourceStream & #backoff .~ ConstantBackoff 0) Nothing+            summary ^. #claimed `shouldBe` 4+            summary ^. #published `shouldBe` 3+            summary ^. #retried `shouldBe` 1+            Right (Just a1) <- Store.runStoreIO storeHandle (lookupOutbox rowA1)+            Right (Just a2) <- Store.runStoreIO storeHandle (lookupOutbox rowA2)+            Right (Just b1) <- Store.runStoreIO storeHandle (lookupOutbox rowB1)+            Right (Just b2) <- Store.runStoreIO storeHandle (lookupOutbox rowB2)+            a1 ^. #status `shouldBe` OutboxSent+            a2 ^. #status `shouldBe` OutboxFailed+            a2 ^. #attemptCount `shouldBe` 1+            a2 ^. #lastError `shouldBe` Just "source-a pivot failed"+            b1 ^. #status `shouldBe` OutboxSent+            b2 ^. #status `shouldBe` OutboxSent++        it "a late failure mark does not clobber a row that already reached a terminal state" $ \storeHandle -> do+            let oid = OutboxId outboxUuid1+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+            now <- getCurrentTime+            Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            Right True <- Store.runStoreIO storeHandle (markOutboxSent oid now)+            Right _ <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (markOutboxFailedTx oid "late failure from a timed-out worker" 5 60 now)+            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+            row ^. #status `shouldBe` OutboxSent+            row ^. #lastError `shouldBe` Nothing++        it "claims nothing while another transaction holds an uncommitted claim on a key's head" $ \storeHandle -> do+            let headId = outboxIdFromOrdinal 1+                tailId = outboxIdFromOrdinal 2+                rows =+                    [ (headId, sampleIntegrationEnvelope & #messageId .~ "claim-race-1" & #key .~ Just "claim-race-key")+                    , (tailId, sampleIntegrationEnvelope & #messageId .~ "claim-race-2" & #key .~ Just "claim-race-key")+                    ]+                OutboxId headUuid = headId+                holdClaimSql =+                    TE.encodeUtf8 $+                        "UPDATE keiro.keiro_outbox SET status = 'publishing', attempt_count = attempt_count + 1, updated_at = now() WHERE outbox_id = '"+                            <> UUID.toText headUuid+                            <> "'"+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        traverse_ (uncurry enqueueIntegrationEventTx) rows+            holderDone <- newEmptyMVar+            _ <- forkIO $ do+                holder <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $ do+                            Tx.sql holdClaimSql+                            Tx.sql "SELECT pg_sleep(2)"+                putMVar holderDone holder+            -- Let the holder acquire its uncommitted row lock, then race a claim.+            threadDelay 500000+            now <- getCurrentTime+            Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 now)+            fmap (^. #outboxId) claimed `shouldBe` []+            Right () <- takeMVar holderDone+            pure ()++        it "StopTheLine publishes singleton batches and skips the unattempted suffix" $ \storeHandle -> do+            let row1Id = outboxIdFromOrdinal 1+                row2Id = outboxIdFromOrdinal 2+                row3Id = outboxIdFromOrdinal 3+                row4Id = outboxIdFromOrdinal 4+                ids = [row1Id, row2Id, row3Id, row4Id]+                rows =+                    [ (oid, sampleIntegrationEnvelope & #messageId .~ ("stop-line-" <> Text.pack (show i)) & #key .~ Just "stop-key")+                    | (i, oid) <- zip [1 .. 4 :: Int] ids+                    ]+                publishRef = fmap (^. #outboxId)+                publish claimed =+                    pure+                        [ ( row ^. #outboxId+                          , if row ^. #outboxId == row2Id+                                then PublishFailed "stop here"+                                else PublishSucceeded+                          )+                        | row <- claimed+                        ]+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        traverse_ (uncurry enqueueIntegrationEventTx) rows+            seenRef <- newIORef []+            let trackedPublish claimed = do+                    liftIO (modifyIORef' seenRef (<> publishRef claimed))+                    publish claimed+                opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0+            Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox trackedPublish opts Nothing)+            summary ^. #published `shouldBe` 1+            summary ^. #retried `shouldBe` 3+            summary ^. #haltedOn `shouldBe` Just row2Id+            seen <- readIORef seenRef+            seen `shouldBe` take 2 ids+            Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id)+            Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id)+            row3 ^. #status `shouldBe` OutboxFailed+            row3 ^. #attemptCount `shouldBe` 0+            row4 ^. #status `shouldBe` OutboxFailed+            row4 ^. #attemptCount `shouldBe` 0++        it "publishClaimedOutbox treats a missing batch outcome as a failed row" $ \storeHandle -> do+            let okId = outboxIdFromOrdinal 1+                missingId = outboxIdFromOrdinal 2+                okEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-ok" & #key .~ Just "ok-key"+                missingEvent = sampleIntegrationEnvelope & #messageId .~ "missing-outcome-fail" & #key .~ Just "missing-key"+                publish claimed =+                    pure+                        [ (row ^. #outboxId, PublishSucceeded)+                        | row <- claimed+                        , row ^. #outboxId == okId+                        ]+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $ do+                        enqueueIntegrationEventTx okId okEvent+                        enqueueIntegrationEventTx missingId missingEvent+            Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)+            summary ^. #published `shouldBe` 1+            summary ^. #retried `shouldBe` 1+            Right (Just missingRow) <- Store.runStoreIO storeHandle (lookupOutbox missingId)+            missingRow ^. #status `shouldBe` OutboxFailed+            missingRow ^. #lastError `shouldBe` Just "publisher returned no outcome"++        it "auto-dead-letters a row after maxAttempts consecutive failures" $ \storeHandle -> do+            let oid = OutboxId outboxUuid1+                event = sampleIntegrationEnvelope & #key .~ Nothing+                opts =+                    defaultPublishOptions+                        & #batchSize+                        .~ 10+                        & #maxAttempts+                        .~ 3+                        & #backoff+                        .~ ConstantBackoff 0+                        & #orderingPolicy+                        .~ BestEffort+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx oid event)+            let publish _ = pure (PublishFailed "broker exploded")+            -- First two failures retain Failed status.+            Right s1 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)+            s1 ^. #retried `shouldBe` 1+            s1 ^. #dead `shouldBe` 0+            Right s2 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)+            s2 ^. #retried `shouldBe` 1+            s2 ^. #dead `shouldBe` 0+            -- Third failure crosses the threshold.+            Right s3 <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)+            s3 ^. #dead `shouldBe` 1+            Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+            row ^. #status `shouldBe` OutboxDead+            -- A dead row is not claimable.+            now <- getCurrentTime+            Right reclaimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now)+            reclaimed `shouldBe` []++        it "garbageCollectSent deletes only old sent rows" $ \storeHandle -> do+            let oldSentId = OutboxId outboxUuid1+                recentSentId = OutboxId outboxUuid2+                failedId = OutboxId outboxUuid3+                deadId = OutboxId outboxUuid4+                base = sampleIntegrationEnvelope & #key .~ Nothing+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx oldSentId (base & #messageId .~ "gc-old-sent"))+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx recentSentId (base & #messageId .~ "gc-recent-sent"))+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx failedId (base & #messageId .~ "gc-failed"))+            let firstPass row+                    | row ^. #outboxId == failedId = pure (PublishFailed "keep failed")+                    | otherwise = pure PublishSucceeded+                firstPassOpts =+                    defaultPublishOptions+                        & #batchSize+                        .~ 10+                        & #orderingPolicy+                        .~ BestEffort+                        & #backoff+                        .~ ConstantBackoff 3600+            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow firstPass) firstPassOpts Nothing)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx deadId (base & #messageId .~ "gc-dead"))+            let deadPass row+                    | row ^. #outboxId == deadId = pure (PublishFailed "keep dead")+                    | otherwise = pure PublishSucceeded+                deadPassOpts =+                    defaultPublishOptions+                        & #batchSize+                        .~ 10+                        & #maxAttempts+                        .~ 1+                        & #orderingPolicy+                        .~ BestEffort+            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow deadPass) deadPassOpts Nothing)+            now <- getCurrentTime+            Right () <- Store.runStoreIO storeHandle (backdateOutboxPublishedAt oldSentId (addUTCTime (-3600) now))+            Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 300 now)+            deleted `shouldBe` 1+            Right oldRow <- Store.runStoreIO storeHandle (lookupOutbox oldSentId)+            oldRow `shouldBe` Nothing+            Right (Just recentRow) <- Store.runStoreIO storeHandle (lookupOutbox recentSentId)+            recentRow ^. #status `shouldBe` OutboxSent+            Right (Just failedRow) <- Store.runStoreIO storeHandle (lookupOutbox failedId)+            failedRow ^. #status `shouldBe` OutboxFailed+            Right (Just deadRow) <- Store.runStoreIO storeHandle (lookupOutbox deadId)+            deadRow ^. #status `shouldBe` OutboxDead++        it "enforces per-key head-of-line blocking and unblocks once the predecessor reaches a terminal state" $ \storeHandle -> do+            let a1Id = OutboxId outboxUuid1+                a2Id = OutboxId outboxUuid2+                b1Id = OutboxId outboxUuid3+                a1 = sampleIntegrationEnvelope & #messageId .~ "a1" & #key .~ Just "k1"+                a2 = sampleIntegrationEnvelope & #messageId .~ "a2" & #key .~ Just "k1"+                b1 = sampleIntegrationEnvelope & #messageId .~ "b1" & #key .~ Just "k2"+            -- Insert in created_at order (a1 first, then a2, then b1).+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx a1Id a1)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx a2Id a2)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx b1Id b1)+            claimed <- newIORef []+            let publish row = do+                    liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ())))+                    if row ^. #outboxId == a1Id+                        then pure (PublishFailed "broker hiccup")+                        else pure PublishSucceeded+            -- First pass: with a one-row batch, a1 fails and both later rows remain pending.+            let firstPassOpts =+                    defaultPublishOptions+                        & #batchSize+                        .~ 1+                        & #backoff+                        .~ ConstantBackoff 0+            Right summary1 <-+                Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) firstPassOpts Nothing)+            summary1 ^. #claimed `shouldBe` 1+            claimedIds <- readIORef claimed+            claimedIds `shouldSatisfy` (a2Id `notElem`)+            claimedIds `shouldSatisfy` (a1Id `elem`)+            claimedIds `shouldSatisfy` (b1Id `notElem`)+            Right (Just a1Row) <- Store.runStoreIO storeHandle (lookupOutbox a1Id)+            a1Row ^. #status `shouldBe` OutboxFailed+            Right (Just b1Row) <- Store.runStoreIO storeHandle (lookupOutbox b1Id)+            b1Row ^. #status `shouldBe` OutboxPending+            Right (Just a2Row) <- Store.runStoreIO storeHandle (lookupOutbox a2Id)+            a2Row ^. #status `shouldBe` OutboxPending+            -- Drive a1 to terminal sent state so a2 can move. One pass claims a1+            -- (now that next_attempt_at has passed). A second pass claims a2,+            -- which becomes head-of-line once a1 reaches `sent`.+            writeIORef claimed []+            let publishOk row = do+                    liftIO (atomicModifyIORef' claimed (\xs -> ((row ^. #outboxId) : xs, ())))+                    pure PublishSucceeded+                retryOpts =+                    defaultPublishOptions+                        & #batchSize+                        .~ 1+                        & #backoff+                        .~ ConstantBackoff 0+            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing)+            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing)+            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publishOk) retryOpts Nothing)+            claimedIds2 <- readIORef claimed+            claimedIds2 `shouldSatisfy` (a1Id `elem`)+            claimedIds2 `shouldSatisfy` (a2Id `elem`)+            claimedIds2 `shouldSatisfy` (b1Id `elem`)+            Right (Just a2Row') <- Store.runStoreIO storeHandle (lookupOutbox a2Id)+            a2Row' ^. #status `shouldBe` OutboxSent++        it "allows null-keyed rows to publish independently" $ \storeHandle -> do+            let n1 = OutboxId outboxUuid1+                n2 = OutboxId outboxUuid2+                e = sampleIntegrationEnvelope & #key .~ Nothing+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx n1 (e & #messageId .~ "n1"))+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx n2 (e & #messageId .~ "n2"))+            let publish row+                    | row ^. #outboxId == n1 = pure (PublishFailed "transient")+                    | otherwise = pure PublishSucceeded+            Right summary <-+                Store.runStoreIO storeHandle $+                    publishClaimedOutbox (perRow publish) (defaultPublishOptions & #backoff .~ ConstantBackoff 0) Nothing+            summary ^. #claimed `shouldBe` 2+            summary ^. #published `shouldBe` 1+            summary ^. #retried `shouldBe` 1++        it "mints message ids with the configured TypeID prefix" $ \storeHandle -> do+            Right minted <-+                Store.runStoreIO storeHandle (mintIntegrationEvent sampleProducer sampleDraft)+            minted ^. #source `shouldBe` "ordering"+            minted ^. #destination `shouldBe` "billing.orders.v1"+            Text.isPrefixOf "msg_" (minted ^. #messageId) `shouldBe` True++        it "validates integration producer message id prefixes before startup" $ \_storeHandle -> do+            shouldBeRight_ (mkIntegrationProducer sampleProducer)+            case mkIntegrationProducer (sampleProducer & #messageIdPrefix .~ "Bad-Prefix") of+                Left (InvalidMessageIdPrefix prefix reason) -> do+                    prefix `shouldBe` "Bad-Prefix"+                    reason `shouldSatisfy` (not . Text.null)+                other -> expectationFailure ("expected invalid prefix, got " <> show (void other))++        it "draftToEvent stamps source and messageId without minting" $ \_storeHandle -> do+            let event = draftToEvent "ordering" "msg-fixed-1" sampleDraft+            event ^. #messageId `shouldBe` "msg-fixed-1"+            event ^. #source `shouldBe` "ordering"+            event ^. #destination `shouldBe` "billing.orders.v1"++        it "freshOutboxId returns distinct UUIDv7 ids" $ \storeHandle -> do+            Right ids <-+                Store.runStoreIO storeHandle (traverse (\_ -> freshOutboxId) [1 .. 4 :: Int])+            length ids `shouldBe` 4+            length (uniqueIds ids) `shouldBe` 4++        it "publishClaimedOutbox emits a Producer span with messaging semconv attributes" $ \storeHandle -> do+            (processor, spansRef) <- inMemoryListExporter+            provider <- createTracerProvider [processor] emptyTracerProviderOptions+            let tracer = makeTracer provider "keiro-test" tracerOptions+                okId = OutboxId outboxUuid1+                failId = OutboxId outboxUuid2+                okEvent = sampleIntegrationEnvelope+                failEvent =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "msg-fail-otel-1"+                        & #key+                        .~ Just "order-otel-fail"+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx okId okEvent)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx failId failEvent)+            let publish row+                    | row ^. #outboxId == okId = pure PublishSucceeded+                    | otherwise = pure (PublishFailed "broker unreachable")+                opts = defaultPublishOptions & #tracer ?~ tracer+            Right _ <- Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) opts Nothing)+            _ <- shutdownTracerProvider provider Nothing+            spans <- traverse captureSpan =<< readIORef spansRef+            length spans `shouldBe` 1+            case spans of+                [batchSpan] -> do+                    csName batchSpan `shouldBe` ("send " <> (okEvent ^. #destination))+                    show (csKind batchSpan) `shouldBe` "Producer"+                    textAttr (csAttributes batchSpan) "messaging.system" `shouldBe` Just "kafka"+                    textAttr (csAttributes batchSpan) "messaging.operation.type" `shouldBe` Just "publish"+                    textAttr (csAttributes batchSpan) "messaging.operation.name" `shouldBe` Just "send"+                    textAttr (csAttributes batchSpan) "messaging.destination.name"+                        `shouldBe` Just (okEvent ^. #destination)+                    textAttr (csAttributes batchSpan) "messaging.kafka.message.key"+                        `shouldBe` (okEvent ^. #key)+                    intAttr (csAttributes batchSpan) "keiro.outbox.batch.size" `shouldBe` Just 2+                    textAttr (csAttributes batchSpan) "error.type" `shouldBe` Just "publish_failed"+                    case csStatus batchSpan of+                        Error msg -> msg `shouldBe` "broker unreachable"+                        other -> expectationFailure ("expected Error \"broker unreachable\", got " <> show other)+                other -> expectationFailure ("expected one batch span, got " <> show (length other))++        it "publishClaimedOutbox records counters and sampleOutboxBacklog records the gauge" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let okId = OutboxId outboxUuid1+                failId = OutboxId outboxUuid2+                okEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-ok" & #key .~ Nothing+                failEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-fail" & #key .~ Nothing+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx okId okEvent)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (enqueueIntegrationEventTx failId failEvent)+            let publish row+                    | row ^. #outboxId == okId = pure PublishSucceeded+                    | otherwise = pure (PublishFailed "broker down")+                retryPassOpts =+                    defaultPublishOptions+                        & #batchSize+                        .~ 10+                        & #maxAttempts+                        .~ 5+                        & #backoff+                        .~ ConstantBackoff 0+                        & #orderingPolicy+                        .~ BestEffort+                deadPassOpts = retryPassOpts & #maxAttempts .~ 1+            -- Pass 1 (maxAttempts = 5): ok publishes, the fail row retries.+            Right summary1 <-+                Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) retryPassOpts (Just keiroMetrics))+            summary1 ^. #published `shouldBe` 1+            summary1 ^. #retried `shouldBe` 1+            -- Pass 2 (maxAttempts = 1): the failed row crosses the ceiling and dies.+            Right summary2 <-+                Store.runStoreIO storeHandle (publishClaimedOutbox (perRow publish) deadPassOpts (Just keiroMetrics))+            summary2 ^. #dead `shouldBe` 1+            -- Flush so the in-memory exporter receives the aggregates.+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+            -- Counters are cumulative across both passes.+            lookup "keiro.outbox.published" scalars `shouldBe` Just (IntNumber 1)+            lookup "keiro.outbox.retried" scalars `shouldBe` Just (IntNumber 1)+            lookup "keiro.outbox.deadlettered" scalars `shouldBe` Just (IntNumber 1)+            -- Publish passes no longer run the backlog COUNT(*) on the hot path.+            lookup "keiro.outbox.backlog" scalars `shouldBe` Nothing++            Store.runStoreIO storeHandle (sampleOutboxBacklog (Just keiroMetrics)) `shouldReturn` Right ()+            _ <- forceFlushMeterProvider provider Nothing+            sampled <- readIORef metricsRef+            let sampledScalars = flattenScalarPoints sampled+            lookup "keiro.outbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0)++    describe "Keiro.Inbox" $ around (withFreshStore fixture) $ do+        it "runs the handler once and records the row as completed" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-msg-1"+                        & #source+                        .~ "ordering"+                handler ev =+                    Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Right result1 <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+            case result1 of+                Right (InboxProcessed ()) -> pure ()+                other -> expectationFailure ("expected InboxProcessed, got " <> show other)+            Right rowCount1 <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+            rowCount1 `shouldBe` 1+            Right (Just inboxRow) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-1")+            inboxRow ^. #status `shouldBe` InboxCompleted+            inboxRow ^. #completedAt `shouldSatisfy` isJust++        it "treats a redelivery with the same messageId as a duplicate" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-msg-dup"+                        & #source+                        .~ "ordering"+                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Right (Right (InboxProcessed ())) <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+            Right result2 <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+            result2 `shouldBe` Right InboxDuplicate+            Right rowCount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+            rowCount `shouldBe` 1++        it "records inbox counters and samples backlog separately under the in-memory exporter" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let event = sampleIntegrationEnvelope & #messageId .~ "inbox-metrics-dup" & #source .~ "ordering"+                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            -- First delivery runs the handler: processed.+            Right (Right (InboxProcessed ())) <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler+            -- Second delivery of the same (source, message_id): duplicate.+            Right result2 <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction (Just keiroMetrics) PreferIntegrationMessageId event Nothing handler+            result2 `shouldBe` Right InboxDuplicate+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+            lookup "keiro.inbox.processed" scalars `shouldBe` Just (IntNumber 1)+            lookup "keiro.inbox.duplicates" scalars `shouldBe` Just (IntNumber 1)+            lookup "keiro.inbox.backlog" scalars `shouldBe` Nothing+            Store.runStoreIO storeHandle (sampleInboxBacklog (Just keiroMetrics)) `shouldReturn` Right ()+            _ <- forceFlushMeterProvider provider Nothing+            sampled <- readIORef metricsRef+            let sampledScalars = flattenScalarPoints sampled+            lookup "keiro.inbox.backlog" sampledScalars `shouldBe` Just (IntNumber 0)+            -- The handler ran exactly once (the duplicate path does not re-run it).+            Right rowCount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+            rowCount `shouldBe` 1++        it "deduplicates via PreferSourceEventIdentity even when messageId differs" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let shared = sampleIntegrationEnvelope & #source .~ "ordering"+                first = shared & #messageId .~ "republish-1"+                second = shared & #messageId .~ "republish-2"+                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Right (Right (InboxProcessed ())) <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing PreferSourceEventIdentity first Nothing handler+            Right result2 <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing PreferSourceEventIdentity second Nothing handler+            result2 `shouldBe` Right InboxDuplicate++        it "uses KafkaDeliveryIdentity when supplied" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let event = sampleIntegrationEnvelope & #source .~ "ordering"+                kafka = KafkaDeliveryRef "billing.orders.v1" 0 17+                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Right (Right (InboxProcessed ())) <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler+            Right (Right InboxDuplicate) <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing KafkaDeliveryIdentity event (Just kafka) handler+            Right (Just row) <-+                Store.runStoreIO storeHandle $+                    lookupInbox "ordering" "billing.orders.v1:0:17"+            row ^. #status `shouldBe` InboxCompleted++        it "reports DedupePolicyUnsatisfied when the envelope lacks the required field" $ \storeHandle -> do+            let event =+                    sampleIntegrationEnvelope+                        & #source+                        .~ "ordering"+                        & #sourceEventId+                        .~ Nothing+                        & #sourceGlobalPosition+                        .~ Nothing+            Right result <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing PreferSourceEventIdentity event Nothing (\_ -> pure ())+            result `shouldBe` Left (DedupePolicyUnsatisfied PreferSourceEventIdentity)++        it "leaves no inbox row when the handler condemns the transaction" $ \storeHandle -> do+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-msg-rollback"+                        & #source+                        .~ "ordering"+                handler _ = do+                    Tx.condemn+                    pure ()+            _ <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+            Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-rollback")+            row `shouldBe` Nothing++        it "leaves no inbox row when the plain handler throws" $ \storeHandle -> do+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-msg-throw-plain"+                        & #source+                        .~ "ordering"+                handler _ = (pure $! error "plain inbox handler failed") :: Tx.Transaction ()+            thrown <-+                try $+                    Store.runStoreIO storeHandle $+                        runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+            case thrown of+                Left (_ :: SomeException) -> pure ()+                Right other -> expectationFailure ("expected handler exception, got " <> show (void other))+            Right row <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-throw-plain")+            row `shouldBe` Nothing++        it "exports markFailedTx from the public inbox module and preserves explicit failure marks" $ \storeHandle -> do+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-msg-public-failed"+                        & #source+                        .~ "ordering"+                handler _ = do+                    markFailedTx "ordering" "inbox-msg-public-failed" "operator failed" (event ^. #occurredAt)+                    pure ()+            Right (Right (InboxProcessed ())) <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-public-failed")+            row ^. #status `shouldBe` InboxFailed+            row ^. #lastError `shouldBe` Just "operator failed"++        it "a throwing handler records a failed attempt instead of looping" $ \storeHandle -> do+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-msg-poison-1"+                        & #source+                        .~ "ordering"+                handler _ = (pure $! error "inbox exploded") :: Tx.Transaction ()+            Right result <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing handler+            case result of+                Right (InboxHandlerFailed err attempts) -> do+                    Text.isInfixOf "inbox exploded" err `shouldBe` True+                    attempts `shouldBe` 1+                other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other)+            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-1")+            row ^. #status `shouldBe` InboxFailed+            row ^. #attemptCount `shouldBe` 1+            row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "inbox exploded")++        it "a transient poison message succeeds on retry" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-msg-poison-transient"+                        & #source+                        .~ "ordering"+                failOnce _ = (pure $! error "temporary inbox failure") :: Tx.Transaction ()+                succeeding ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Right result1 <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing failOnce+            case result1 of+                Right (InboxHandlerFailed _ 1) -> pure ()+                other -> expectationFailure ("expected first failed attempt, got " <> show other)+            Right result2 <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionWithRetries Nothing 3 PreferIntegrationMessageId event Nothing succeeding+            result2 `shouldBe` Right (InboxProcessed ())+            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-transient")+            row ^. #status `shouldBe` InboxCompleted+            row ^. #attemptCount `shouldBe` 1+            Right rowCount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+            rowCount `shouldBe` 1++        it "an unrecoverable message dead-letters at the ceiling" $ \storeHandle -> do+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-msg-poison-dead"+                        & #source+                        .~ "ordering"+                handler _ = (pure $! error "always broken") :: Tx.Transaction ()+            Right result1 <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler+            Right result2 <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler+            Right result3 <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionWithRetries Nothing 2 PreferIntegrationMessageId event Nothing handler+            case (result1, result2, result3) of+                ( Right (InboxHandlerFailed _ 1)+                    , Right (InboxHandlerFailed _ 2)+                    , Right (InboxPreviouslyFailed _)+                    ) -> pure ()+                other -> expectationFailure ("unexpected poison lifecycle: " <> show other)+            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-msg-poison-dead")+            row ^. #status `shouldBe` InboxFailed+            row ^. #attemptCount `shouldBe` 2++        it "processes a batch of distinct messages in one transaction" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let events =+                    [ sampleIntegrationEnvelope+                        & #messageId+                        .~ ("inbox-batch-msg-" <> Text.pack (show n))+                        & #source+                        .~ "batch-ordering"+                    | n <- [1 .. 50 :: Int]+                    ]+                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Right results <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler+            results `shouldBe` replicate 50 (Right (InboxProcessed ()))+            Right rowCount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+            rowCount `shouldBe` 50+            Right inboxRows <- Store.runStoreIO storeHandle (listInbox "batch-ordering")+            length inboxRows `shouldBe` 50+            all ((== InboxCompleted) . (^. #status)) inboxRows `shouldBe` True++        it "deduplicates repeated messages within one batch" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-batch-dup"+                        & #source+                        .~ "batch-ordering"+                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Right results <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing), (event, Nothing)] handler+            results `shouldBe` [Right (InboxProcessed ()), Right InboxDuplicate]+            Right rowCount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+            rowCount `shouldBe` 1++        it "falls back per message when one batch handler throws" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let events =+                    [ sampleIntegrationEnvelope+                        & #messageId+                        .~ ("inbox-batch-poison-" <> Text.pack (show n))+                        & #source+                        .~ "batch-ordering"+                    | n <- [1 .. 5 :: Int]+                    ]+                handler ev+                    | ev ^. #messageId == "inbox-batch-poison-3" =+                        (pure $! error "batch poison") :: Tx.Transaction ()+                    | otherwise =+                        Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Right results <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler+            case results of+                [ Right (InboxProcessed ())+                    , Right (InboxProcessed ())+                    , Right (InboxHandlerFailed err 1)+                    , Right (InboxProcessed ())+                    , Right (InboxProcessed ())+                    ] ->+                        Text.isInfixOf "batch poison" err `shouldBe` True+                other -> expectationFailure ("unexpected batch fallback results: " <> show other)+            Right rowCount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+            rowCount `shouldBe` 4+            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-poison-3")+            row ^. #status `shouldBe` InboxFailed+            row ^. #attemptCount `shouldBe` 1+            row ^. #lastError `shouldSatisfy` maybe False (Text.isInfixOf "batch poison")++        it "reports duplicates across batch calls" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-batch-existing-dup"+                        & #source+                        .~ "batch-ordering"+                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Right first <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler+            first `shouldBe` [Right (InboxProcessed ())]+            Right second <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope [(event, Nothing)] handler+            second `shouldBe` [Right InboxDuplicate]+            Right rowCount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+            rowCount `shouldBe` 1++        it "falls back per message when one batch handler condemns the transaction" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let events =+                    [ sampleIntegrationEnvelope+                        & #messageId+                        .~ ("inbox-batch-condemn-" <> Text.pack (show n))+                        & #source+                        .~ "batch-ordering"+                    | n <- [1 .. 3 :: Int]+                    ]+                handler ev+                    | ev ^. #messageId == "inbox-batch-condemn-2" = Tx.condemn+                    | otherwise = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Right results <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionBatch Nothing 3 PreferIntegrationMessageId PersistFullEnvelope ((,Nothing) <$> events) handler+            -- The condemned single-message retry reports processed by the+            -- documented single-path contract; what matters is that the+            -- innocent batch mates actually committed.+            results `shouldBe` replicate 3 (Right (InboxProcessed ()))+            Right rowCount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+            rowCount `shouldBe` 2+            Right (Just mate1) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-1")+            Right (Just mate3) <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-3")+            mate1 ^. #status `shouldBe` InboxCompleted+            mate3 ^. #status `shouldBe` InboxCompleted+            Right condemned <- Store.runStoreIO storeHandle (lookupInbox "batch-ordering" "inbox-batch-condemn-2")+            condemned `shouldBe` Nothing++        it "classifies a legacy processing row as InboxInProgress without running the handler" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-legacy-processing"+                        & #source+                        .~ "ordering"+                handler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.sql "INSERT INTO keiro.keiro_inbox (source, dedupe_key, content_type, payload_bytes, status) VALUES ('ordering', 'inbox-legacy-processing', 'application/json', ''::bytea, 'processing')"+            Right result <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+            result `shouldBe` Right InboxInProgress+            Right rowCount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+            rowCount `shouldBe` 0+            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-legacy-processing")+            row ^. #status `shouldBe` InboxProcessing++        it "runs the handler once when two workers race the same dedupe key" $ \storeHandle -> do+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-race-dup"+                        & #source+                        .~ "ordering"+                slowHandler ev = do+                    Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+                    Tx.sql "SELECT pg_sleep(1.5)"+                fastHandler ev = Tx.statement (ev ^. #messageId) inboxTestCounterInsertStmt+            firstDone <- newEmptyMVar+            _ <- forkIO $ do+                first <-+                    Store.runStoreIO storeHandle $+                        runInboxTransaction Nothing PreferIntegrationMessageId event Nothing slowHandler+                putMVar firstDone first+            -- Let the slow worker insert its uncommitted row, then race the+            -- same dedupe key: the second insert must block on the unique+            -- constraint until the first commits, then classify as duplicate.+            threadDelay 400000+            Right second <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing fastHandler+            Right first <- takeMVar firstDone+            first `shouldBe` Right (InboxProcessed ())+            second `shouldBe` Right InboxDuplicate+            Right rowCount <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction (Tx.statement () inboxTestCounterCountStmt)+            rowCount `shouldBe` 1++        it "can persist only dedupe columns for successful rows" $ \storeHandle -> do+            let kafka = KafkaDeliveryRef "billing.orders.v1" 1 42+                event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-slim-success"+                        & #source+                        .~ "ordering"+                        & #payloadBytes+                        .~ "full success payload"+                        & #attributes+                        ?~ object ["source" Aeson..= ("slim-test" :: Text)]+                handler _ = pure ()+            Right (Right (InboxProcessed ())) <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler+            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-success")+            row ^. #event . #payloadBytes `shouldBe` ""+            row ^. #event . #attributes `shouldBe` Nothing+            row ^. #event . #traceContext `shouldBe` Nothing+            row ^. #event . #schemaReference `shouldBe` Nothing+            row ^. #event . #messageId `shouldBe` "inbox-slim-success"+            row ^. #event . #sourceEventId `shouldBe` event ^. #sourceEventId+            row ^. #event . #sourceGlobalPosition `shouldBe` event ^. #sourceGlobalPosition+            row ^. #event . #causationId `shouldBe` event ^. #causationId+            row ^. #event . #correlationId `shouldBe` event ^. #correlationId+            row ^. #event . #occurredAt `shouldBe` event ^. #occurredAt+            row ^. #kafka `shouldBe` Just kafka+            Right redelivery <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionWith Nothing PersistDedupeOnly PreferIntegrationMessageId event (Just kafka) handler+            redelivery `shouldBe` Right InboxDuplicate++        it "keeps full failed rows even when successful rows are dedupe-only" $ \storeHandle -> do+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-slim-failed"+                        & #source+                        .~ "ordering"+                        & #payloadBytes+                        .~ "full failed payload"+                        & #attributes+                        ?~ object ["source" Aeson..= ("failed-slim-test" :: Text)]+                handler _ = (pure $! error "slim failure") :: Tx.Transaction ()+            Right result <-+                Store.runStoreIO storeHandle $+                    runInboxTransactionWithRetriesWith Nothing 3 PersistDedupeOnly PreferIntegrationMessageId event Nothing handler+            case result of+                Right (InboxHandlerFailed err 1) ->+                    Text.isInfixOf "slim failure" err `shouldBe` True+                other -> expectationFailure ("expected InboxHandlerFailed, got " <> show other)+            Right (Just row) <- Store.runStoreIO storeHandle (lookupInbox "ordering" "inbox-slim-failed")+            row ^. #status `shouldBe` InboxFailed+            row ^. #event . #payloadBytes `shouldBe` event ^. #payloadBytes+            row ^. #event . #attributes `shouldBe` event ^. #attributes+            row ^. #event . #traceContext `shouldBe` event ^. #traceContext+            row ^. #event . #schemaReference `shouldBe` event ^. #schemaReference++        it "garbage-collects completed rows older than the retention window" $ \storeHandle -> do+            let event =+                    sampleIntegrationEnvelope+                        & #messageId+                        .~ "inbox-msg-gc"+                        & #source+                        .~ "ordering"+                handler _ = pure ()+            Right (Right (InboxProcessed ())) <-+                Store.runStoreIO storeHandle $+                    runInboxTransaction Nothing PreferIntegrationMessageId event Nothing handler+            -- Backdate the row so it falls outside the retention window.+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.sql+                            "UPDATE keiro.keiro_inbox SET completed_at = now() - interval '40 days' WHERE message_id = 'inbox-msg-gc'"+            now <- getCurrentTime+            Right deleted <- Store.runStoreIO storeHandle (garbageCollectCompleted (nominalDays 30) now)+            deleted `shouldBe` 1+            Right rows <- Store.runStoreIO storeHandle (listInbox "ordering")+            rows `shouldBe` []++    describe "Keiro.Inbox.Kafka" $ do+        it "reconstructs an integration event from headers and payload" $ do+            let envelope = sampleIntegrationEnvelope+                headers = integrationHeaders envelope+                receivedAt = addUTCTime 60 (envelope ^. #occurredAt)+                record =+                    InboxKafka.KafkaInboundRecord+                        { topic = "billing.orders.v1"+                        , partition = 2+                        , offset = 113+                        , key = Just "order-123"+                        , payload = envelope ^. #payloadBytes+                        , headers+                        , receivedAt+                        }+            case InboxKafka.integrationEventFromKafka record of+                Right (rebuilt, kafkaRef) -> do+                    rebuilt ^. #messageId `shouldBe` envelope ^. #messageId+                    rebuilt ^. #source `shouldBe` envelope ^. #source+                    rebuilt ^. #destination `shouldBe` envelope ^. #destination+                    rebuilt ^. #eventType `shouldBe` envelope ^. #eventType+                    rebuilt ^. #schemaVersion `shouldBe` envelope ^. #schemaVersion+                    rebuilt ^. #sourceEventId `shouldBe` envelope ^. #sourceEventId+                    rebuilt ^. #sourceGlobalPosition `shouldBe` envelope ^. #sourceGlobalPosition+                    rebuilt ^. #payloadBytes `shouldBe` envelope ^. #payloadBytes+                    rebuilt ^. #occurredAt `shouldBe` envelope ^. #occurredAt+                    rebuilt ^. #attributes `shouldBe` envelope ^. #attributes+                    kafkaRef ^. #topic `shouldBe` "billing.orders.v1"+                    kafkaRef ^. #partition `shouldBe` 2+                    kafkaRef ^. #offset `shouldBe` 113+                Left err -> expectationFailure ("expected Right, got Left " <> show err)++        it "falls back to receivedAt when the occurredAt header is absent" $ do+            let envelope = sampleIntegrationEnvelope+                receivedAt = addUTCTime 60 (envelope ^. #occurredAt)+                headers = filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope)+                record =+                    InboxKafka.KafkaInboundRecord+                        { topic = "billing.orders.v1"+                        , partition = 2+                        , offset = 113+                        , key = Just "order-123"+                        , payload = envelope ^. #payloadBytes+                        , headers+                        , receivedAt+                        }+            case InboxKafka.integrationEventFromKafka record of+                Right (rebuilt, _) -> rebuilt ^. #occurredAt `shouldBe` receivedAt+                Left err -> expectationFailure ("expected Right, got Left " <> show err)++        it "rejects malformed occurredAt headers" $ do+            let envelope = sampleIntegrationEnvelope+                headers = ("keiro-occurred-at", "not-a-time") : filter ((/= "keiro-occurred-at") . Prelude.fst) (integrationHeaders envelope)+                record =+                    InboxKafka.KafkaInboundRecord+                        { topic = "billing.orders.v1"+                        , partition = 2+                        , offset = 113+                        , key = Just "order-123"+                        , payload = envelope ^. #payloadBytes+                        , headers+                        , receivedAt = envelope ^. #occurredAt+                        }+            InboxKafka.integrationEventFromKafka record+                `shouldBe` Left (InboxKafka.InvalidTimeHeader "keiro-occurred-at" "not-a-time")++        it "reports MissingHeader for an essential header" $ do+            let envelope = sampleIntegrationEnvelope+                headers = filter ((/= "keiro-message-id") . Prelude.fst) (integrationHeaders envelope)+                record =+                    InboxKafka.KafkaInboundRecord+                        { topic = "billing.orders.v1"+                        , partition = 0+                        , offset = 0+                        , key = Nothing+                        , payload = envelope ^. #payloadBytes+                        , headers+                        , receivedAt = envelope ^. #occurredAt+                        }+            InboxKafka.integrationEventFromKafka record+                `shouldBe` Left (InboxKafka.MissingHeader "keiro-message-id")++        it "withConsumerSpan parents the consumer span under an upstream producer span via W3C headers" $ do+            (processor, spansRef) <- inMemoryListExporter+            provider <- createTracerProvider [processor] emptyTracerProviderOptions+            let tracer = makeTracer provider "keiro-test" tracerOptions+                -- Clear the baked-in TraceContext on the sample so the only+                -- `traceparent` on the wire comes from the active producer+                -- span (via `injectTraceContext`).+                envelope = sampleIntegrationEnvelope & #traceContext .~ Nothing+                producerRecord = OutboxKafka.integrationEventToKafkaRecord envelope+            producerHeadersText <-+                Telemetry.withProducerSpan (Just tracer) envelope producerRecord $ \_ -> do+                    let baseHeaders =+                            [(TE.decodeUtf8 n, TE.decodeUtf8 v) | (n, v) <- producerRecord ^. #headers]+                    Telemetry.injectTraceContext baseHeaders+            -- Build the inbound record the consumer would receive and open the+            -- consumer span around a no-op body.+            now <- getCurrentTime+            let inbound =+                    InboxKafka.KafkaInboundRecord+                        { topic = envelope ^. #destination+                        , partition = 7+                        , offset = 42+                        , key = envelope ^. #key+                        , payload = envelope ^. #payloadBytes+                        , headers = producerHeadersText+                        , receivedAt = now+                        }+            Telemetry.withConsumerSpan (Just tracer) (Just "billing-cg") inbound (Just envelope) $ \_ ->+                pure ()+            _ <- shutdownTracerProvider provider Nothing+            spans <- traverse captureSpan =<< readIORef spansRef+            length spans `shouldBe` 2+            let findByName needle = case [s | s <- spans, csName s == needle] of+                    (s : _) -> s+                    [] -> error ("no span captured with name=" <> Text.unpack needle)+                producerSp = findByName ("send " <> envelope ^. #destination)+                consumerSp = findByName ("process " <> envelope ^. #destination)+            -- Same trace id end-to-end (cross-process parenting).+            traceId (csContext producerSp) `shouldBe` traceId (csContext consumerSp)+            -- Consumer's parent is the producer span.+            case csParent consumerSp of+                Nothing -> expectationFailure "consumer span has no parent"+                Just parent -> do+                    parentCtx <- getSpanContext parent+                    spanId parentCtx `shouldBe` spanId (csContext producerSp)+            -- Consumer span carries the expected attributes.+            show (csKind consumerSp) `shouldBe` "Consumer"+            textAttr (csAttributes consumerSp) "messaging.system" `shouldBe` Just "kafka"+            textAttr (csAttributes consumerSp) "messaging.operation.type" `shouldBe` Just "process"+            textAttr (csAttributes consumerSp) "messaging.destination.name"+                `shouldBe` Just (envelope ^. #destination)+            textAttr (csAttributes consumerSp) "messaging.destination.partition.id"+                `shouldBe` Just "7"+            textAttr (csAttributes consumerSp) "messaging.consumer.group.name"+                `shouldBe` Just "billing-cg"+            textAttr (csAttributes consumerSp) "messaging.message.id"+                `shouldBe` Just (envelope ^. #messageId)++    describe "Keiro cross-context Kafka integration" $ around (withFreshStores2 fixture) $ do+        it "publishes an Ordering integration event and runs the Billing handler exactly once across duplicate deliveries" $ \(ordering, billing) -> do+            Right () <-+                Store.runStoreIO billing $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)")+            topic <- newKafkaTopic+            -- Ordering side: enqueue an outbox row representing a published event.+            let orderingEvent = orderSubmittedEnvelope "order-aaa" 7 "msg-aaa"+                oid = OutboxId outboxUuid1+            Right () <-+                Store.runStoreIO ordering $+                    Store.runTransaction (enqueueIntegrationEventTx oid orderingEvent)+            -- Run the publisher worker: push records to the in-process topic.+            Right pubSummary1 <-+                Store.runStoreIO ordering $+                    publishClaimedOutbox (perRow (kafkaTopicPublish topic)) defaultPublishOptions Nothing+            pubSummary1 ^. #published `shouldBe` 1+            -- Billing side: consume from the topic.+            records1 <- drainKafkaTopic topic+            record1 <- case records1 of+                [r] -> pure r+                other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable"+            Right consumed1 <-+                Store.runStoreIO billing $+                    consumeAndApply record1 billingReactionHandler+            consumed1 `shouldBe` ConsumeApplied (InboxProcessed ())+            Right rowCount1 <-+                Store.runStoreIO billing $+                    Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt)+            rowCount1 `shouldBe` 1++            -- Simulate Kafka redelivery: pretend the same Kafka record was+            -- delivered again at a different offset. The producer also retries+            -- (the outbox flips back to pending and the worker republishes).+            let redelivered = redeliverWithDifferentOffset record1+            Right consumed2 <-+                Store.runStoreIO billing $+                    consumeAndApply redelivered billingReactionHandler+            consumed2 `shouldBe` ConsumeApplied InboxDuplicate+            Right rowCount2 <-+                Store.runStoreIO billing $+                    Store.runTransaction (Tx.statement () billingReceivedOrdersCountStmt)+            rowCount2 `shouldBe` 1++        it "preserves per-partition ordering for two events sharing a Kafka key" $ \(ordering, billing) -> do+            Right () <-+                Store.runStoreIO billing $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)")+            Right () <-+                Store.runStoreIO billing $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_event_log (seq BIGSERIAL PRIMARY KEY, source TEXT NOT NULL, event_type TEXT NOT NULL, order_id TEXT NOT NULL)")+            topic <- newKafkaTopic+            -- Two events for the same order key.+            let submittedEnv = orderSubmittedEnvelope "order-bbb" 4 "msg-bbb-1"+                cancelledEnv = orderCancelledEnvelope "order-bbb" "msg-bbb-2"+                submittedId = OutboxId outboxUuid1+                cancelledId = OutboxId outboxUuid2+            Right () <-+                Store.runStoreIO ordering $+                    Store.runTransaction (enqueueIntegrationEventTx submittedId submittedEnv)+            Right () <-+                Store.runStoreIO ordering $+                    Store.runTransaction (enqueueIntegrationEventTx cancelledId cancelledEnv)+            -- Run-claiming lets a same-key contiguous run drain in one pass.+            let drainOnce =+                    publishClaimedOutbox+                        (perRow (kafkaTopicPublish topic))+                        (defaultPublishOptions & #backoff .~ ConstantBackoff 0)+                        Nothing+            Right s1 <- Store.runStoreIO ordering drainOnce+            Right s2 <- Store.runStoreIO ordering drainOnce+            (s1 ^. #published) + (s2 ^. #published) `shouldBe` 2+            records <- drainKafkaTopic topic+            length records `shouldBe` 2+            -- Apply both records to billing in delivery order.+            for_ records $ \record -> do+                Right consumed <-+                    Store.runStoreIO billing $+                        consumeAndApply record (loggingReactionHandler "billing")+                case consumed of+                    ConsumeApplied (InboxProcessed ()) -> pure ()+                    other -> expectationFailure ("expected processed, got " <> show other)+            Right events <-+                Store.runStoreIO billing $+                    Store.runTransaction (Tx.statement () billingEventLogStmt)+            events `shouldBe` [("OrderSubmitted", "order-bbb"), ("OrderCancelled", "order-bbb")]++        it "head-of-line blocks a same-key successor when the first send fails repeatedly until the first row reaches dead status" $ \(ordering, billing) -> do+            Right () <-+                Store.runStoreIO billing $+                    Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS billing_received_orders (order_id TEXT PRIMARY KEY, quantity BIGINT NOT NULL)")+            topic <- newKafkaTopic+            let submittedEnv = orderSubmittedEnvelope "order-ccc" 1 "msg-ccc-1"+                cancelledEnv = orderCancelledEnvelope "order-ccc" "msg-ccc-2"+                firstId = OutboxId outboxUuid1+                secondId = OutboxId outboxUuid2+            Right () <-+                Store.runStoreIO ordering $+                    Store.runTransaction (enqueueIntegrationEventTx firstId submittedEnv)+            Right () <-+                Store.runStoreIO ordering $+                    Store.runTransaction (enqueueIntegrationEventTx secondId cancelledEnv)+            -- Failing publish for the first row, success for any other.+            let publish row+                    | row ^. #outboxId == firstId =+                        pure (PublishFailed "simulated broker reject")+                    | otherwise = do+                        kafkaTopicAccept topic row+                        pure PublishSucceeded+                deadOpts =+                    defaultPublishOptions+                        & #batchSize+                        .~ 1+                        & #backoff+                        .~ ConstantBackoff 0+                        & #maxAttempts+                        .~ 2+            -- This test drives the pre-M3 sequential failure/dead-letter path+            -- with one-row batches. M3 adds suffix skipping for larger claimed+            -- same-key runs.+            -- First pass: the first row attempts once and fails; the second is+            -- outside the one-row claim window.+            Right pass1 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing)+            pass1 ^. #retried `shouldBe` 1+            pass1 ^. #published `shouldBe` 0+            -- Second pass crosses maxAttempts and dead-letters the first row.+            Right pass2 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing)+            pass2 ^. #dead `shouldBe` 1+            Right (Just firstRow) <- Store.runStoreIO ordering (lookupOutbox firstId)+            firstRow ^. #status `shouldBe` OutboxDead+            -- With the first row dead, the second becomes claimable and publishes.+            Right pass3 <- Store.runStoreIO ordering (publishClaimedOutbox (perRow publish) deadOpts Nothing)+            pass3 ^. #published `shouldBe` 1+            Right (Just secondRow) <- Store.runStoreIO ordering (lookupOutbox secondId)+            secondRow ^. #status `shouldBe` OutboxSent+            -- Billing only sees the second event.+            records <- drainKafkaTopic topic+            record <- case records of+                [r] -> pure r+                other -> expectationFailure ("expected 1 record, got " <> show (length other)) *> error "unreachable"+            Right consumed <-+                Store.runStoreIO billing $+                    consumeAndApply record billingReactionHandler+            consumed `shouldBe` ConsumeApplied (InboxProcessed ())++    describe "Keiro.Integration.Event" $ do+        it "round-trips a JSON envelope through encode and decode" $ do+            let envelope = sampleIntegrationEnvelope+                payload = OrderSubmittedPayload "order-123" 5+                encoded = encodeJsonIntegrationEvent envelope payload+            decodeJsonIntegrationEvent encoded `shouldBe` Right payload++        it "preserves identity and routing through encode" $ do+            let envelope = sampleIntegrationEnvelope+                encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5)+            encoded ^. #messageId `shouldBe` envelope ^. #messageId+            encoded ^. #source `shouldBe` "ordering"+            encoded ^. #destination `shouldBe` "billing.orders.v1"+            encoded ^. #key `shouldBe` Just "order-123"+            encoded ^. #eventType `shouldBe` "OrderSubmitted"+            encoded ^. #schemaVersion `shouldBe` 1+            encoded ^. #contentType `shouldBe` ApplicationJson++        it "emits the canonical wire headers" $ do+            let envelope = sampleIntegrationEnvelope+                headers = integrationHeaders envelope+            Prelude.lookup headerMessageId headers `shouldBe` Just (envelope ^. #messageId)+            Prelude.lookup headerSchemaVersion headers `shouldBe` Just "1"+            Prelude.lookup headerContentType headers `shouldBe` Just "application/json"+            Prelude.lookup headerSchemaSubject headers `shouldBe` Just "billing.orders.v1.OrderSubmitted"+            Prelude.lookup headerSourceEventId headers `shouldBe` Just "018f0f18-17aa-7000-8000-000000000003"+            Prelude.lookup headerSourceGlobalPosition headers `shouldBe` Just "42"+            Prelude.lookup headerTraceParent headers+                `shouldBe` Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"++        it "preserves a different content type without claiming JSON" $ do+            let envelope =+                    sampleIntegrationEnvelope+                        & #contentType+                        .~ OtherContentType "application/vnd.apache.avro.binary"+                        & #payloadBytes+                        .~ "\x00\x01\x02"+                headers = integrationHeaders envelope+            Prelude.lookup headerContentType headers+                `shouldBe` Just "application/vnd.apache.avro.binary"+            decodeJsonIntegrationEvent envelope+                `shouldBe` ( Left (IntegrationEvent.UnsupportedContentType "application/vnd.apache.avro.binary") ::+                                Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload+                           )++        it "reports malformed JSON payloads as decode errors instead of throwing" $ do+            let envelope =+                    sampleIntegrationEnvelope+                        & #payloadBytes+                        .~ "{not-json"+            case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of+                Left (IntegrationEvent.MalformedPayload _) -> pure ()+                other -> expectationFailure ("expected MalformedPayload, got " <> show other)++        it "reports a JSON value that does not satisfy the target type as DecodeFailed" $ do+            let envelope =+                    sampleIntegrationEnvelope+                        & #payloadBytes+                        .~ "{\"orderId\":\"order-123\"}"+            case decodeJsonIntegrationEvent envelope :: Either IntegrationEvent.IntegrationEventError OrderSubmittedPayload of+                Left (IntegrationEvent.DecodeFailed _) -> pure ()+                other -> expectationFailure ("expected DecodeFailed, got " <> show other)++        it "parses content-type headers back to the canonical type" $ do+            parseContentType "application/json" `shouldBe` ApplicationJson+            parseContentType "Application/JSON" `shouldBe` ApplicationJson+            parseContentType "application/json; charset=utf-8" `shouldBe` ApplicationJson+            parseContentType "APPLICATION/JSON ; CHARSET=UTF-8" `shouldBe` ApplicationJson+            parseContentType "application/vnd.apache.avro.binary"+                `shouldBe` OtherContentType "application/vnd.apache.avro.binary"++        it "preserves the payload bytes through integrationPayload" $ do+            let envelope = sampleIntegrationEnvelope+                encoded = encodeJsonIntegrationEvent envelope (OrderSubmittedPayload "order-123" 5)+            integrationPayload encoded `shouldBe` (encoded ^. #payloadBytes)++    describe "Keiro.Telemetry" $ do+        it "is a pass-through under a noop (Nothing) tracer" $ do+            counter <- newIORef (0 :: Int)+            let envelope = sampleIntegrationEnvelope+                record = OutboxKafka.integrationEventToKafkaRecord envelope+            result <-+                Telemetry.withProducerSpan Nothing envelope record $ \mSpan -> do+                    atomicModifyIORef' counter (\n -> (n + 1, ()))+                    pure (mSpan, "ok" :: Text)+            callsAfter <- readIORef counter+            callsAfter `shouldBe` (1 :: Int)+            snd result `shouldBe` "ok"+            fst result `shouldSatisfy` isNothing++        it "re-exports AttributeKeys whose textual payload matches the spec name" $ do+            attrKeyText Telemetry.messaging_operation_type `shouldBe` "messaging.operation.type"+            attrKeyText Telemetry.messaging_operation_name `shouldBe` "messaging.operation.name"+            attrKeyText Telemetry.messaging_destination_partition_id `shouldBe` "messaging.destination.partition.id"+            attrKeyText Telemetry.messaging_consumer_group_name `shouldBe` "messaging.consumer.group.name"+            attrKeyText Telemetry.messaging_client_id `shouldBe` "messaging.client.id"+            attrKeyTextInt64 Telemetry.messaging_kafka_offset `shouldBe` "messaging.kafka.offset"+            attrKeyText Telemetry.db_system_name `shouldBe` "db.system.name"+            attrKeyText Telemetry.db_namespace `shouldBe` "db.namespace"+            attrKeyText Telemetry.db_collection_name `shouldBe` "db.collection.name"+            attrKeyText Telemetry.db_operation_name `shouldBe` "db.operation.name"+            attrKeyText Telemetry.keiro_stream_name `shouldBe` "keiro.stream.name"+            attrKeyTextInt64 Telemetry.keiro_retry_attempt `shouldBe` "keiro.retry.attempt"+            attrKeyTextInt64 Telemetry.keiro_events_appended `shouldBe` "keiro.events.appended"+            attrKeyText Telemetry.keiro_replay_divergence `shouldBe` "keiro.replay.divergence"++        it "extracts a TraceContext from a W3C traceparent header pair" $ do+            let traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+                tracestate = "vendor1=value1"+                hs = [(headerTraceParent, traceparent), ("tracestate", tracestate)]+            Telemetry.traceContextFromHeaders hs+                `shouldBe` Just (TraceContext traceparent (Just tracestate))++        it "returns Nothing when the traceparent header is missing" $ do+            Telemetry.traceContextFromHeaders [("content-type", "application/json")]+                `shouldBe` Nothing++        it "injectTraceContext is a no-op when no span is active on the thread" $ do+            let baseline = [("content-type", "application/json")]+            injected <- Telemetry.injectTraceContext baseline+            injected `shouldBe` baseline++        it "traceContextFromCurrentSpan returns Nothing outside any span" $ do+            tc <- Telemetry.traceContextFromCurrentSpan+            tc `shouldBe` Nothing++    describe "Keiro.Workflow" $ around (withFreshStore fixture) $ do+        it "journals each step once, returns Completed, and runs each side effect once" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "demo"+                wid = WorkflowId "demo-1"+            result <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)+            result `shouldBe` Right (Completed (1, 2))+            sideEffects <- readIORef counter+            sideEffects `shouldBe` 2+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:demo-demo-1") (StreamVersion 0) 10+            Vector.length recorded `shouldBe` 3+            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+                `shouldSatisfy` \case+                    Right [StepRecorded "first" _ _, StepRecorded "second" _ _, WorkflowCompleted _] -> True+                    _ -> False++        it "replays recorded steps without re-running their side effects" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "replay"+                wid = WorkflowId "r-1"+            first <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)+            first `shouldBe` Right (Completed (1, 2))+            afterFirst <- readIORef counter+            afterFirst `shouldBe` 2+            -- A second run with the same id is exactly the crash-restart scenario.+            second <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)+            second `shouldBe` Right (Completed (1, 2))+            afterSecond <- readIORef counter+            afterSecond `shouldBe` 2+            -- The deterministic ids and pre-load gating leave the journal at 3 events.+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:replay-r-1") (StreamVersion 0) 10+            Vector.length recorded `shouldBe` 3++        it "reuses the recorded result for a repeated step name in one run" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "samename"+                wid = WorkflowId "s-1"+                duplicateStepWorkflow = do+                    a <- step (StepName "dup") (liftIO (incrementAndRead counter))+                    b <- step (StepName "dup") (liftIO (incrementAndRead counter))+                    pure (a, b)+            result <- Store.runStoreIO storeHandle $ runWorkflow name wid duplicateStepWorkflow+            result `shouldBe` Right (Completed (1, 1))+            sideEffects <- readIORef counter+            sideEffects `shouldBe` 1++        it "suspends on an unresolved awaitStep, journaling no completion" $ \storeHandle -> do+            let name = WorkflowName "awaiter"+                wid = WorkflowId "a-1"+            result <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow+            result `shouldBe` Right Suspended+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:awaiter-a-1") (StreamVersion 0) 10+            Vector.length recorded `shouldBe` 0++        it "resumes and completes once an awaited step is externally completed" $ \storeHandle -> do+            let name = WorkflowName "awaiter2"+                wid = WorkflowId "a-2"+            suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow+            suspended `shouldBe` Right Suspended+            -- Simulate a wake source recording the awaited step's resolution.+            Right () <- Store.runStoreIO storeHandle $ do+                now <- liftIO getCurrentTime+                appendJournalEntry name wid (StepRecorded "awk:test" (toJSON (42 :: Int)) now)+            resumed <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow+            resumed `shouldBe` Right (Completed 42)+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:awaiter2-a-2") (StreamVersion 0) 10+            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+                `shouldSatisfy` \case+                    Right [StepRecorded "awk:test" _ _, WorkflowCompleted _] -> True+                    _ -> False++        it "treats a duplicate external journal append as idempotent" $ \storeHandle -> do+            let name = WorkflowName "duplicate-append"+                wid = WorkflowId "da-1"+                stepKey = "awk:test"+                eventAt t = StepRecorded stepKey (toJSON (42 :: Int)) t+            now <- getCurrentTime+            Right firstId <-+                Store.runStoreIO storeHandle $+                    appendJournalEntryReturningId name wid (eventAt now)+            secondResult <-+                Store.runStoreIO storeHandle $+                    appendJournalEntryReturningId name wid (eventAt now)+            secondId <- case secondResult of+                Right value -> pure value+                Left err -> expectationFailure ("expected idempotent duplicate append, got " <> show err) *> error "unreachable"+            secondId `shouldBe` firstId+            Right indexed <- Store.runStoreIO storeHandle $ loadStepIndex name wid 0+            Map.lookup stepKey indexed `shouldBe` Just (toJSON (42 :: Int))+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:duplicate-append-da-1") (StreamVersion 0) 10+            Vector.length recorded `shouldBe` 1++        it "returns the journaled value when another writer records the same step mid-flight" $ \storeHandle -> do+            let name = WorkflowName "journal-race"+                wid = WorkflowId "jr-1"+                body =+                    step (StepName "raced") $ do+                        now <- liftIO getCurrentTime+                        appendJournalEntry name wid (StepRecorded "raced" (toJSON ("winner" :: Text)) now)+                        pure ("loser" :: Text)+            outcome <- Store.runStoreIO storeHandle $ runWorkflow name wid body+            outcome `shouldBe` Right (Completed "winner")+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:journal-race-jr-1") (StreamVersion 0) 10+            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+                `shouldSatisfy` \case+                    Right [StepRecorded "raced" value _, WorkflowCompleted _] -> value == toJSON ("winner" :: Text)+                    _ -> False++        it "returns the JSON round-trip of a fresh step result" $ \storeHandle -> do+            let name = WorkflowName "roundtrip-step"+                wid = WorkflowId "rs-1"+                body = step (StepName "approx") (pure (Approx 1.7))+            first <- Store.runStoreIO storeHandle $ runWorkflow name wid body+            first `shouldBe` Right (Completed (Approx 2.0))+            replay <- Store.runStoreIO storeHandle $ runWorkflow name wid body+            replay `shouldBe` Right (Completed (Approx 2.0))++        it "throws WorkflowStepDecodeError on the first run when the recorded result cannot decode" $ \storeHandle -> do+            let name = WorkflowName "bad-roundtrip"+                wid = WorkflowId "br-1"+                body = step (StepName "bad") (pure RejectingRoundTrip)+            Store.runStoreIO storeHandle (runWorkflow name wid body)+                `shouldThrow` \case+                    WorkflowStepDecodeError key _ -> key == "bad"+                    _ -> False+            Store.runStoreIO storeHandle (stepExists name wid 0 "bad")+                `shouldReturn` Right True++        it "discovers unfinished workflows via the step index" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            Right (Completed _) <-+                Store.runStoreIO storeHandle $+                    runWorkflow (WorkflowName "done") (WorkflowId "d-1") (demoWorkflow counter)+            Right Suspended <-+                Store.runStoreIO storeHandle $+                    runWorkflow (WorkflowName "pending") (WorkflowId "p-1") (stepThenAwaitWorkflow counter)+            now <- getCurrentTime+            Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)+            unfinished `shouldBe` [("p-1", "pending")]++    describe "Keiro.Workflow instance table" $ around (withFreshStore fixture) $ do+        it "creates and completes a workflow instance row transactionally with the journal" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "inst-complete"+                wid = WorkflowId "ic-1"+            Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)+            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+            row ^. #workflowId `shouldBe` "ic-1"+            row ^. #workflowName `shouldBe` "inst-complete"+            row ^. #generation `shouldBe` 0+            row ^. #status `shouldBe` Instance.WfCompleted+            row ^. #completedAt `shouldSatisfy` isJust++        it "records suspended status for workflows that park before journaling" $ \storeHandle -> do+            let name = WorkflowName "inst-suspended"+                wid = WorkflowId "is-1"+            Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid neverArmingWorkflow+            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+            row ^. #status `shouldBe` Instance.WfSuspended+            row ^. #generation `shouldBe` 0+            row ^. #completedAt `shouldBe` Nothing++        it "creates child instance rows at spawn time and flips them to cancelled" $ \storeHandle -> do+            let childWid = WorkflowId "inst-child"+                childName = WorkflowName "ship"+            Right Suspended <-+                Store.runStoreIO storeHandle $+                    runWorkflow (WorkflowName "inst-parent") (WorkflowId "ip-1") (parentWorkflow childWid)+            Right (Just spawned) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid+            spawned ^. #status `shouldBe` Instance.WfRunning+            Right True <- Store.runStoreIO storeHandle $ cancelChild (ChildHandle childName childWid)+            Right (Just cancelledRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childWid+            cancelledRow ^. #status `shouldBe` Instance.WfCancelled+            cancelledRow ^. #completedAt `shouldSatisfy` isJust++        it "bumps the instance generation when continueAsNew rotates" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "inst-rotate"+                wid = WorkflowId "ir-1"+            Right ContinuedAsNew <-+                Store.runStoreIO storeHandle $+                    runWorkflow name wid (rollingTotal counter 1 2)+            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+            row ^. #generation `shouldBe` 1+            row ^. #status `shouldBe` Instance.WfRunning++        it "does not let a late append resurrect a terminal instance row" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "inst-terminal"+                wid = WorkflowId "it-1"+            Right (Completed _) <- Store.runStoreIO storeHandle $ runWorkflow name wid (demoWorkflow counter)+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO storeHandle $+                    appendJournalEntry name wid (StepRecorded "late" (toJSON True) now)+            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+            row ^. #status `shouldBe` Instance.WfCompleted++        it "discovers unfinished workflows from the instance table" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let completedName = WorkflowName "discover-completed"+                cancelledName = WorkflowName "discover-cancelled"+                crashedName = WorkflowName "discover-crashed"+                rotatedName = WorkflowName "discover-rotated"+            Right (Completed _) <-+                Store.runStoreIO storeHandle $+                    runWorkflow completedName (WorkflowId "done") (demoWorkflow counter)+            cancelledAt <- getCurrentTime+            Right () <-+                Store.runStoreIO storeHandle $+                    appendJournalEntry cancelledName (WorkflowId "cancelled") (WorkflowCancelled cancelledAt)+            Left (_ :: SimulatedCrash) <-+                try $+                    Store.runStoreIO storeHandle $+                        runWorkflow crashedName (WorkflowId "crashed") (crashAfterStep1 counter)+            Right ContinuedAsNew <-+                Store.runStoreIO storeHandle $+                    runWorkflow rotatedName (WorkflowId "rotated") (rollingTotal counter 1 2)+            now <- getCurrentTime+            Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)+            unfinished+                `shouldBe` [ ("crashed", "discover-crashed")+                           , ("rotated", "discover-rotated")+                           ]++    describe "Keiro.Workflow snapshots" $ around (withFreshStore fixture) $ do+        it "does not fail committed workflow steps when snapshot writes fail" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            let opts =+                    defaultWorkflowRunOptions+                        & #snapshotPolicy+                        .~ Every 2+                        & #metrics+                        ?~ keiroMetrics+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.sql "ALTER TABLE keiro.keiro_snapshots ADD CONSTRAINT keiro_snapshots_no_writes CHECK (false) NOT VALID"+            counter <- newIORef (0 :: Int)+            result <-+                Store.runStoreIO storeHandle $+                    runWorkflowWith opts (WorkflowName "snap-write-failure") (WorkflowId "wf1") (countingSixSteps counter)+            result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+            Right journal <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:snap-write-failure-wf1") (StreamVersion 0) 100+            Vector.length journal `shouldBe` 7+            Right snapshotVersionDuringFailure <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "wf:snap-write-failure-wf1" snapshotVersionForStreamStmt+            snapshotVersionDuringFailure `shouldBe` Nothing+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            lookup "keiro.snapshot.write.failures" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 3)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.sql "ALTER TABLE keiro.keiro_snapshots DROP CONSTRAINT keiro_snapshots_no_writes"+            recoveryCounter <- newIORef (0 :: Int)+            recovery <-+                Store.runStoreIO storeHandle $+                    runWorkflowWith opts (WorkflowName "snap-write-recovery") (WorkflowId "wf2") (countingSixSteps recoveryCounter)+            recovery `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+            Right snapshotVersionAfterRecovery <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "wf:snap-write-recovery-wf2" snapshotVersionForStreamStmt+            snapshotVersionAfterRecovery `shouldBe` Just (StreamVersion 6)++        -- Validation (a): a snapshot row appears at the expected version and+        -- decodes to the full accumulated step map.+        it "writes a snapshot of the accumulated step map after Every 2 fires" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "snap"+                wid = WorkflowId "w1"+            result <-+                Store.runStoreIO storeHandle $+                    runWorkflowWith+                        (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2)+                        name+                        wid+                        (countingSixSteps counter)+            result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+            -- Every 2 fired at versions 2, 4, 6; the upsert keeps the highest (6).+            Right snapVersion <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "wf:snap-w1" snapshotVersionForStreamStmt+            snapVersion `shouldBe` Just (StreamVersion 6)+            -- and the row decodes to the six-entry accumulated map.+            Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:snap-w1")+            case mSeed of+                Just (m, v) -> do+                    v `shouldBe` StreamVersion 6+                    Map.keys m `shouldBe` ["s1", "s2", "s3", "s4", "s5", "s6"]+                Nothing -> expectationFailure "expected a workflow snapshot row"++        -- The OnTerminal completion-site wiring: only the final WorkflowCompleted+        -- append (version 7) triggers the snapshot.+        it "writes a terminal snapshot under OnTerminal at the completion version" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "term"+                wid = WorkflowId "tm1"+            result <-+                Store.runStoreIO storeHandle $+                    runWorkflowWith+                        (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal)+                        name+                        wid+                        (countingSixSteps counter)+            result `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+            Right snapVersion <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement "wf:term-tm1" snapshotVersionForStreamStmt+            snapVersion `shouldBe` Just (StreamVersion 7)++        -- Validation (b): re-hydration reads only the tail after the snapshot+        -- version, and the journaled steps short-circuit (the counter stays put).+        it "reads only the tail after the snapshot version on re-hydration" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "tail"+                wid = WorkflowId "t1"+                opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2+            first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+            first `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+            afterFirst <- readIORef counter+            afterFirst `shouldBe` 6+            -- A full version-0 replay would read every journal event...+            Right full <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion 0) 100+            Vector.length full `shouldBe` 7 -- six StepRecorded + one WorkflowCompleted+            -- ...whereas the runtime seeds from the snapshot and reads only the tail.+            Right (Just (seedMap, StreamVersion sv)) <-+                Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:tail-t1")+            Map.size seedMap `shouldBe` 6+            Right tailEvents <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:tail-t1") (StreamVersion sv) 100+            Vector.length tailEvents `shouldSatisfy` (< Vector.length full)+            Vector.length tailEvents `shouldBe` 1 -- only the WorkflowCompleted at v7+            -- Re-hydration completes from the seed without re-running any step.+            second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+            second `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+            afterSecond <- readIORef counter+            afterSecond `shouldBe` 6++        -- Validation (c): a Never run and an Every 2 run produce identical results+        -- and identical journals, and the snapshot seed equals a full replay.+        it "produces identical results and journals under Never and Every 2" $ \storeHandle -> do+            counterN <- newIORef (0 :: Int)+            counterE <- newIORef (0 :: Int)+            neverRes <-+                Store.runStoreIO storeHandle $+                    runWorkflowWith+                        (defaultWorkflowRunOptions & #snapshotPolicy .~ Never)+                        (WorkflowName "corr-never")+                        (WorkflowId "c1")+                        (countingSixSteps counterN)+            everyRes <-+                Store.runStoreIO storeHandle $+                    runWorkflowWith+                        (defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2)+                        (WorkflowName "corr-every")+                        (WorkflowId "c1")+                        (countingSixSteps counterE)+            neverRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+            everyRes `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+            Right neverEvents <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:corr-never-c1") (StreamVersion 0) 100+            Right everyEvents <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:corr-every-c1") (StreamVersion 0) 100+            let stepResults evs =+                    [ (k, v)+                    | Right (StepRecorded k v _) <- decodeRecorded workflowJournalCodec <$> Vector.toList evs+                    ]+            stepResults neverEvents `shouldBe` stepResults everyEvents+            -- The snapshot seed equals the map a full version-0 replay would fold.+            Right (Just (seedMap, _)) <-+                Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:corr-every-c1")+            seedMap `shouldBe` Map.fromList (stepResults everyEvents)++        -- Validation (d): an advisory snapshot whose discriminant no longer matches+        -- is ignored and the workflow hydrates via full replay.+        it "hydrates via full replay when the snapshot discriminant mismatches" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "dmiss"+                wid = WorkflowId "d1"+                opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 2+            _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement ("wf:dmiss-d1", "stale-shape") corruptSnapshotShapeStmt+            Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:dmiss-d1")+            mSeed `shouldBe` Nothing+            resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+            resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])++        -- Validation (d), second arm: corrupt snapshot JSON is treated as a miss.+        it "hydrates via full replay when the snapshot JSON is corrupt" $ \storeHandle -> do+            (exporter, metricsRef) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            keiroMetrics <- Telemetry.newKeiroMetrics meter+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "cjson"+                wid = WorkflowId "d2"+                opts =+                    defaultWorkflowRunOptions+                        & #snapshotPolicy+                        .~ Every 2+                        & #metrics+                        ?~ keiroMetrics+            _ <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement ("wf:cjson-d2", Aeson.String "bad") corruptSnapshotStateStmt+            Right mSeed <- Store.runStoreIO storeHandle $ loadWorkflowSnapshot (StreamName "wf:cjson-d2")+            mSeed `shouldBe` Nothing+            resumed <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (countingSixSteps counter)+            resumed `shouldBe` Right (Completed [1, 2, 3, 4, 5, 6])+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef metricsRef+            let scalars = flattenScalarPoints exported+            lookup "keiro.snapshot.decode.failures" scalars `shouldBe` Just (IntNumber 1)+            lookup "keiro.snapshot.read.misses" scalars `shouldBe` Just (IntNumber 2)++    describe "Keiro.Workflow.Resume" $ around (withFreshStore fixture) $ do+        -- M2: crash mid-run, then a resume pass drives the workflow to Completed+        -- without re-running the already-journaled step.+        it "resumes a crashed mid-run workflow, running only the un-journaled tail" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "crash-demo"+                wid = WorkflowId "cd-1"+            -- Simulate a crash after step 1's append has committed.+            crashed <-+                try+                    ( Store.runStoreIO storeHandle $+                        runWorkflow name wid (crashAfterStep1 counter)+                    ) ::+                    IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int))))+            case crashed of+                Left _ -> pure () -- the SimulatedCrash unwound the run, as intended+                Right other -> expectationFailure ("expected a simulated crash, got " <> show other)+            readIORef counter >>= \c -> c `shouldBe` 1+            -- Resume with a registry mapping the name to the FULL definition.+            let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter))+            Right summary <-+                Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry+            summary+                `shouldBe` ResumeSummary+                    { discovered = 1+                    , resumed = 1+                    , completed = 1+                    , stillSuspended = 0+                    , unknownName = 0+                    , failed = 0+                    , transientErrors = 0+                    , leaseSkipped = 0+                    }+            -- Step 1 short-circuited; steps 2 and 3 ran exactly once.+            readIORef counter >>= \c -> c `shouldBe` 3+            -- The journal now holds s1, s2, s3, WorkflowCompleted.+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:crash-demo-cd-1") (StreamVersion 0) 10+            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+                `shouldSatisfy` \case+                    Right [StepRecorded "s1" _ _, StepRecorded "s2" _ _, StepRecorded "s3" _ _, WorkflowCompleted _] -> True+                    _ -> False+            -- A second pass discovers nothing — the workflow is finished.+            Right summary2 <-+                Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry+            summary2 `shouldBe` emptyResumeSummary++        -- M3: a workflow suspended on an awaited step is driven to Completed once+        -- that step is journaled (here simulated; an EP-39/EP-40 wake source would+        -- journal the same StepRecorded end to end).+        it "resumes a suspended workflow once its awaited step is journaled" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "await-demo"+                wid = WorkflowId "ad-1"+            suspended <-+                Store.runStoreIO storeHandle $ runWorkflow name wid (awaitingThenStep counter)+            suspended `shouldBe` Right Suspended+            -- Simulate the wake source resolving the await.+            Right () <- Store.runStoreIO storeHandle $ do+                now <- liftIO getCurrentTime+                appendJournalEntry name wid (StepRecorded "awk:approval" (toJSON ("ok" :: Text)) now)+            let registry = Map.singleton name (WorkflowDef (\_wid -> awaitingThenStep counter))+            Right summary <-+                Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry+            summary+                `shouldBe` ResumeSummary+                    { discovered = 1+                    , resumed = 1+                    , completed = 1+                    , stillSuspended = 0+                    , unknownName = 0+                    , failed = 0+                    , transientErrors = 0+                    , leaseSkipped = 0+                    }+            readIORef counter >>= \c -> c `shouldBe` 1+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:await-demo-ad-1") (StreamVersion 0) 10+            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+                `shouldSatisfy` \case+                    Right [StepRecorded "awk:approval" _ _, StepRecorded "use" _ _, WorkflowCompleted _] -> True+                    _ -> False++        -- M4: a discovered workflow whose name is absent from the registry is+        -- skipped and counted, never silently dropped or fatal.+        it "skips and counts a workflow whose name is absent from the registry" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "orphan"+                wid = WorkflowId "or-1"+            crashed <-+                try+                    ( Store.runStoreIO storeHandle $+                        runWorkflow name wid (crashAfterStep1 counter)+                    ) ::+                    IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int))))+            case crashed of+                Left _ -> pure ()+                Right other -> expectationFailure ("expected a simulated crash, got " <> show other)+            -- Empty registry: the orphan is surfaced via unknownName, not completed.+            Right summary <-+                Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions Map.empty+            summary+                `shouldBe` ResumeSummary+                    { discovered = 1+                    , resumed = 0+                    , completed = 0+                    , stillSuspended = 0+                    , unknownName = 1+                    , failed = 0+                    , transientErrors = 0+                    , leaseSkipped = 0+                    }+            -- The journal is unchanged: still one step, no completion.+            Right recorded <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:orphan-or-1") (StreamVersion 0) 10+            Vector.length recorded `shouldBe` 1++        it "isolates a poison workflow so a healthy workflow still completes" $ \storeHandle -> do+            healthyCounter <- newIORef (0 :: Int)+            let poisonName = WorkflowName "poison"+                poisonId = WorkflowId "poison-1"+                healthyName = WorkflowName "healthy"+                healthyId = WorkflowId "healthy-1"+                opts =+                    defaultWorkflowResumeOptions+                        & #maxAttempts+                        .~ 1+                        & #logEvent+                        .~ const (pure ())+                registry =+                    Map.fromList+                        [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))+                        , (healthyName, WorkflowDef (\_ -> threeStep healthyCounter))+                        ]+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO storeHandle $+                    appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now)+            crashed <-+                try+                    ( Store.runStoreIO storeHandle $+                        runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter)+                    ) ::+                    IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int))))+            case crashed of+                Left _ -> pure ()+                Right other -> expectationFailure ("expected a simulated crash, got " <> show other)+            Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+            summary+                `shouldBe` emptyResumeSummary+                    { discovered = 2+                    , resumed = 2+                    , completed = 1+                    , failed = 1+                    }+            readIORef healthyCounter >>= \c -> c `shouldBe` 3+            Right (Just poisonRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance poisonName poisonId+            poisonRow ^. #status `shouldBe` Instance.WfFailed++        it "marks a crashing workflow failed and short-circuits later direct runs" $ \storeHandle -> do+            let name = WorkflowName "terminal-poison"+                wid = WorkflowId "tp-1"+                opts =+                    defaultWorkflowResumeOptions+                        & #maxAttempts+                        .~ 1+                        & #logEvent+                        .~ const (pure ())+                registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO storeHandle $+                    appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now)+            Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+            failed summary `shouldBe` 1+            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+            row ^. #status `shouldBe` Instance.WfFailed+            row ^. #attempts `shouldBe` 1+            direct <- Store.runStoreIO storeHandle $ runWorkflow name wid (step (StepName "never") (pure (1 :: Int)))+            direct `shouldBe` Right Failed+            Right recordedFailed <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:terminal-poison-tp-1") (StreamVersion 0) 10+            traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedFailed)+                `shouldSatisfy` \case+                    Right events -> any (\case WorkflowFailed{} -> True; _ -> False) events+                    _ -> False++        it "classifies thrown store errors as transient without consuming attempts" $ \storeHandle -> do+            let name = WorkflowName "transient"+                wid = WorkflowId "tr-1"+                opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ())+                registry =+                    Map.singleton name $+                        WorkflowDef+                            ( \_ -> do+                                _ <- throwError (Store.ConnectionLost "boom")+                                pure (0 :: Int)+                            )+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO storeHandle $+                    appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now)+            Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+            transientErrors summary `shouldBe` 1+            failed summary `shouldBe` 0+            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+            row ^. #attempts `shouldBe` 0+            row ^. #status `shouldBe` Instance.WfRunning++        it "keeps the fixed-poll loop alive when one pass contains a poison workflow" $ \storeHandle -> do+            done <- newEmptyMVar+            healthyCounter <- newIORef (0 :: Int)+            let poisonName = WorkflowName "fixed-loop-poison"+                poisonId = WorkflowId "flp-1"+                healthyName = WorkflowName "fixed-loop-healthy"+                healthyId = WorkflowId "flh-1"+                opts =+                    defaultWorkflowResumeOptions+                        & #pollInterval+                        .~ 50_000+                        & #maxAttempts+                        .~ 1+                        & #logEvent+                        .~ const (pure ())+                healthyBody = threeStepThenSignal healthyCounter done+                registry =+                    Map.fromList+                        [ (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))+                        , (healthyName, WorkflowDef (\_ -> healthyBody))+                        ]+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO storeHandle $+                    appendJournalEntry poisonName poisonId (StepRecorded "seed" (toJSON True) now)+            crashed <-+                try+                    ( Store.runStoreIO storeHandle $+                        runWorkflow healthyName healthyId (crashAfterStep1 healthyCounter)+                    ) ::+                    IO (Either SomeException (Either Store.StoreError (WorkflowOutcome (Int, Int, Int))))+            case crashed of+                Left _ -> pure ()+                Right other -> expectationFailure ("expected a simulated crash, got " <> show other)+            worker <- forkIO (void (Store.runStoreIO storeHandle (runWorkflowResumeWorkerWith opts registry)))+            completed <- timeout 5_000_000 (takeMVar done)+            status <- threadStatus worker+            killThread worker+            completed `shouldBe` Just ()+            status `shouldSatisfy` \case+                ThreadFinished -> False+                ThreadDied -> False+                _ -> True++        it "claims one workflow instance for a single live owner and releases it" $ \storeHandle -> do+            let name = WorkflowName "lease-claim"+                wid = WorkflowId "lc-1"+            Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid+            claimedA `shouldBe` True+            Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid+            claimedB `shouldBe` False+            Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid+            Right claimedBAfterRelease <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid+            claimedBAfterRelease `shouldBe` True++        it "lets an expired workflow lease be taken and resets attempts on progressed release" $ \storeHandle -> do+            let name = WorkflowName "lease-expire"+                wid = WorkflowId "le-1"+            Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 30 name wid+            claimedA `shouldBe` True+            Right attempt <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Instance.recordCrashTx "le-1" "lease-expire" "boom"+            attempt `shouldBe` 1+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.sql "UPDATE keiro.keiro_workflows SET lease_expires_at = now() - interval '1 second', next_attempt_at = now() - interval '1 second' WHERE workflow_id = 'le-1' AND workflow_name = 'lease-expire'"+            Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid+            claimedB `shouldBe` True+            Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-b" True name wid+            Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+            row ^. #attempts `shouldBe` 0+            row ^. #lastError `shouldBe` Nothing+            row ^. #nextAttemptAt `shouldBe` Nothing+            row ^. #leasedBy `shouldBe` Nothing++        it "skips a resume candidate held by another live lease owner" $ \storeHandle -> do+            ran <- newIORef False+            let name = WorkflowName "lease-skip"+                wid = WorkflowId "ls-1"+                registry =+                    Map.singleton name $+                        WorkflowDef+                            ( \_ -> do+                                liftIO (writeIORef ran True)+                                pure (0 :: Int)+                            )+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO storeHandle $+                    appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now)+            Right foreignClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "foreign-owner" 30 name wid+            foreignClaim `shouldBe` True+            Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry+            summary+                `shouldBe` emptyResumeSummary+                    { discovered = 1+                    , leaseSkipped = 1+                    }+            readIORef ran `shouldReturn` False++        -- M4: resume on an already-completed workflow is a genuine no-op.+        it "discovers nothing for an already-completed workflow and is stable" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "done-demo"+                wid = WorkflowId "dd-1"+            done <- Store.runStoreIO storeHandle $ runWorkflow name wid (threeStep counter)+            done `shouldBe` Right (Completed (1, 2, 3))+            readIORef counter >>= \c -> c `shouldBe` 3+            let registry = Map.singleton name (WorkflowDef (\_wid -> threeStep counter))+            Right summary1 <-+                Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry+            summary1 `shouldBe` emptyResumeSummary+            Right summary2 <-+                Store.runStoreIO storeHandle $ resumeWorkflowsOnce defaultWorkflowResumeOptions registry+            summary2 `shouldBe` emptyResumeSummary+            readIORef counter >>= \c -> c `shouldBe` 3++    describe "Keiro.Workflow continue-as-new" $ around (withFreshStore fixture) $ do+        -- EP-48 headline proof (Checks 1 & 2): a 300-step rolling-total workflow that+        -- rotates every 50 steps keeps each physical generation journal bounded by+        -- K = rotateEvery + 2 (at most rotateEvery work steps + the one seed step that+        -- opened the generation + the one terminal marker), yet returns the correct+        -- final total. A single non-rotating run would put all 300 steps on one+        -- journal and the per-generation `<= K` bound would fail.+        it "rotates a long workflow, bounds each generation, and returns the correct total" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "roller"+                wid = WorkflowId "r-1"+                rotateEvery = 50 :: Int+                total = 300 :: Int+                k = rotateEvery + 2+                body = rollingTotal counter rotateEvery total+                -- Re-invoke runWorkflow until it Completes; each call resolves and+                -- advances the current generation, exactly as the resume worker does.+                drive :: Int -> IO Int+                drive budget+                    | budget <= 0 =+                        expectationFailure "workflow did not complete within the rotation budget" >> pure (-1)+                    | otherwise = do+                        outcome <- Store.runStoreIO storeHandle (runWorkflow name wid body)+                        case outcome of+                            Right ContinuedAsNew -> drive (budget - 1)+                            Right (Completed t) -> pure t+                            other -> expectationFailure ("unexpected outcome: " <> show other) >> pure (-1)+            -- The first invocation rotates (generation 0 did rotateEvery steps).+            firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid body)+            firstOutcome `shouldBe` Right ContinuedAsNew+            -- Drive the remaining generations to completion (bounded passes).+            finalTotal <- drive (total `div` rotateEvery + 3)+            -- Check 2: correct result, and each side effect ran exactly once.+            finalTotal `shouldBe` total+            readIORef counter >>= (`shouldBe` total)+            -- The workflow rotated to its final generation (300/50 = 6 generations: 0..5).+            Right gen <- Store.runStoreIO storeHandle (currentGeneration name wid)+            gen `shouldBe` (total `div` rotateEvery - 1)+            -- Check 1: every generation's physical journal is bounded by K, and the+            -- total is split ACROSS generations (bounded per generation, not in+            -- aggregate). Each generation holds exactly 1 seed + rotateEvery work + 1+            -- marker = K events, so the sum is total + 2 per generation.+            lengths <-+                traverse+                    ( \g -> do+                        let streamName = workflowGenerationStreamName name wid g+                        Right evs <- Store.runStoreIO storeHandle (Store.readStreamForward streamName (StreamVersion 0) 1000)+                        pure (Vector.length evs)+                    )+                    [0 .. gen]+            for_ lengths (`shouldSatisfy` (<= k))+            sum lengths `shouldBe` (total + 2 * (gen + 1))+            -- The first generation ends with a rotation marker; the last with a+            -- completion marker.+            Right gen0evs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid 0) (StreamVersion 0) 1000)+            (decodeRecorded workflowJournalCodec <$> Vector.toList gen0evs)+                `shouldSatisfy` any+                    ( \case+                        Right (WorkflowContinuedAsNew 1 _) -> True+                        _ -> False+                    )+            Right lastEvs <- Store.runStoreIO storeHandle (Store.readStreamForward (workflowGenerationStreamName name wid gen) (StreamVersion 0) 1000)+            (decodeRecorded workflowJournalCodec <$> Vector.toList lastEvs)+                `shouldSatisfy` any+                    ( \case+                        Right (WorkflowCompleted _) -> True+                        _ -> False+                    )++        -- EP-48 Check 3: discovery and resume follow the CURRENT generation. After a+        -- rotation the rotated (newer) generation is unfinished and discoverable —+        -- the older generation's WorkflowContinuedAsNew marker does NOT mask it — and+        -- the resume worker drives the rotated generation forward to completion.+        it "rediscovers and resumes a rotated workflow on its current generation" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "roller2"+                wid = WorkflowId "r-2"+                rotateEvery = 50 :: Int+                total = 150 :: Int+                registry = Map.singleton name (WorkflowDef (\_ -> rollingTotal counter rotateEvery total))+                resumeUntilDone :: Int -> IO ()+                resumeUntilDone budget+                    | budget <= 0 = expectationFailure "resume did not complete the rotated workflow"+                    | otherwise = do+                        Right summary <-+                            Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)+                        if completed summary == 1 then pure () else resumeUntilDone (budget - 1)+            -- First run rotates onto generation 1.+            firstOutcome <- Store.runStoreIO storeHandle (runWorkflow name wid (rollingTotal counter rotateEvery total))+            firstOutcome `shouldBe` Right ContinuedAsNew+            -- The rotated current generation (1) is unfinished and discoverable.+            now <- getCurrentTime+            Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)+            unfinished `shouldBe` [("r-2", "roller2")]+            -- The resume worker drives the rotated generation(s) to completion.+            resumeUntilDone (total `div` rotateEvery + 3)+            readIORef counter >>= (`shouldBe` total)+            -- Finished: discovery now reports nothing for it.+            finalNow <- getCurrentTime+            Right finalUnfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds finalNow)+            finalUnfinished `shouldBe` []++    describe "Keiro.Workflow patch API" $ around (withFreshStore fixture) $ do+        it "an in-flight instance observes the OLD branch; a fresh instance the NEW branch; the decision is journaled once and stable" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "patchwf"+                inflight = WorkflowId "inflight-1"+                fresh = WorkflowId "fresh-1"+                patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId++            -- 1. Run the in-flight instance to a suspension under the PRE-patch code.+            pre <- Store.runStoreIO storeHandle $ runWorkflow name inflight (prePatchWorkflow counter)+            pre `shouldBe` Right Suspended++            -- 2. Redeploy: re-run the SAME instance id under the POST-patch code. It+            --    already journaled reserve-inventory, so it is in flight -> False.+            r1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter)+            r1 `shouldBe` Right (Completed "old-branch")++            -- 3. Replay the in-flight instance again: same OLD branch, every time.+            r2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name inflight (postPatchWorkflow counter)+            r2 `shouldBe` Right (Completed "old-branch")++            -- 4. A fresh instance under the POST-patch code takes the NEW branch.+            f1 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter)+            f1 `shouldBe` Right (Completed "new-branch")+            -- and stays on the new branch on replay.+            f2 <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name fresh (postPatchWorkflow counter)+            f2 `shouldBe` Right (Completed "new-branch")++            -- 5. The patch decision is journaled exactly once per instance, with the+            --    expected Bool, on the patch:<id> key.+            Right inflightJournal <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:patchwf-inflight-1") (StreamVersion 0) 20+            let inflightDecisions =+                    [ v+                    | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList inflightJournal)+                    , StepRecorded k v _ <- [ev]+                    , k == patchStepName fraudPatchId+                    ]+            inflightDecisions `shouldBe` [toJSON False]++            Right freshJournal <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (StreamName "wf:patchwf-fresh-1") (StreamVersion 0) 20+            let freshDecisions =+                    [ v+                    | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal)+                    , StepRecorded k v _ <- [ev]+                    , k == patchStepName fraudPatchId+                    ]+            freshDecisions `shouldBe` [toJSON True]+            let freshPatchSets =+                    [ v+                    | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList freshJournal)+                    , StepRecorded k v _ <- [ev]+                    , k == patchSetStepName+                    ]+            freshPatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]]++        it "a fresh instance suspended before its patch call still takes the NEW branch" $ \storeHandle -> do+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "patch-after-suspend"+                wid = WorkflowId "pas-1"+                patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId+            Right Suspended <-+                Store.runStoreIO storeHandle $+                    runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter)+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO storeHandle $+                    appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now)+            resumed <-+                Store.runStoreIO storeHandle $+                    runWorkflowWith patchOptions name wid (postPatchAfterSuspendWorkflow counter)+            resumed `shouldBe` Right (Completed "new-branch")++        it "an in-flight instance with only wake-source completions stays on the OLD branch" $ \storeHandle -> do+            let name = WorkflowName "patch-wake-only"+                wid = WorkflowId "pwo-1"+                patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId+            Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid prePatchWakeOnlyWorkflow+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO storeHandle $+                    appendJournalEntry name wid (StepRecorded "awk:gate" Aeson.Null now)+            resumed <-+                Store.runStoreIO storeHandle $+                    runWorkflowWith patchOptions name wid postPatchWakeOnlyWorkflow+            resumed `shouldBe` Right (Completed "old-branch")++        it "records the active patch set again for a fresh rotated generation" $ \storeHandle -> do+            let name = WorkflowName "patch-rotating"+                wid = WorkflowId "pr-1"+                patchOptions = defaultWorkflowRunOptions & #activePatches .~ Set.singleton fraudPatchId+            first <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow+            first `shouldBe` Right ContinuedAsNew+            second <- Store.runStoreIO storeHandle $ runWorkflowWith patchOptions name wid rotatingPatchWorkflow+            second `shouldBe` Right (Completed "new-branch")+            Right gen1Journal <-+                Store.runStoreIO storeHandle $+                    Store.readStreamForward (workflowGenerationStreamName name wid 1) (StreamVersion 0) 20+            let gen1PatchSets =+                    [ v+                    | Right ev <- map (decodeRecorded workflowJournalCodec) (Vector.toList gen1Journal)+                    , StepRecorded k v _ <- [ev]+                    , k == patchSetStepName+                    ]+            gen1PatchSets `shouldBe` [toJSON [unPatchId fraudPatchId]]++    describe "Keiro.Wake" $ around (withFreshStore fixture) $ do+        -- EP-50: the wake primitive over kiroku's existing per-store notifier.+        it "returns WokenByTimeout when idle (no append)" $ \store -> do+            wake <- wakeSignalFromStore store+            reason <- waitForWake wake 200000 -- 200 ms+            reason `shouldBe` WokenByTimeout++        it "returns WokenByNotify promptly after a real append" $ \store -> do+            wake <- wakeSignalFromStore store+            -- A real append bumps the streams row and fires kiroku's NOTIFY on+            -- kiroku.events; the store's notifier ticks the broadcast channel.+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO store $+                    appendJournalEntry (WorkflowName "wakedemo") (WorkflowId "w1") (StepRecorded "s" (toJSON True) now)+            reason <- waitForWake wake 5000000 -- generous 5 s ceiling; the round-trip is milliseconds+            reason `shouldBe` WokenByNotify++        it "neverWake always returns WokenByTimeout" $ \_store -> do+            reason <- waitForWake neverWake 100000+            reason `shouldBe` WokenByTimeout++    describe "Keiro.Workflow push latency (EP-50)" $ around (withFreshStore fixture) $ do+        -- The user-visible win: a gated workflow resumes within sub-second of the+        -- gate append, under a deliberately large (10 s) fallback — so a pass that+        -- resumes it sub-second can only have been woken by the NOTIFY, not the poll.+        it "resumes a gated workflow sub-second after the gate append (10s fallback)" $ \store -> do+            done <- newEmptyMVar+            let name = WorkflowName "pushwf"+                wid = WorkflowId "p-1"+                registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done))+                opts = defaultWorkflowResumeOptions & #pollInterval .~ 10000000 -- 10 s fallback+            first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done))+            first `shouldBe` Right Suspended+            worker <- forkIO (runWorkflowResumeWorkerPush store opts registry)+            -- Let the worker start, duplicate the tick channel, and park in its wait+            -- before we append, so the gate's NOTIFY cannot be missed.+            threadDelay 250000+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO store $+                    appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now)+            resumed <- timeout 5000000 (takeMVar done)+            t1 <- getCurrentTime+            killThread worker+            resumed `shouldBe` Just ()+            let latency = realToFrac (diffUTCTime t1 now) :: Double+            latency `shouldSatisfy` (< 1.0)++        it "logs a failed push pass and keeps draining after the store recovers" $ \store -> do+            done <- newEmptyMVar+            logs <- newIORef []+            let name = WorkflowName "push-recover"+                wid = WorkflowId "pr-1"+                registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done))+                opts =+                    defaultWorkflowResumeOptions+                        & #pollInterval+                        .~ 100_000+                        & #logEvent+                        .~ \event -> modifyIORef' logs (<> [event])+                waitForPassFailure = timeout 5_000_000 $ do+                    let go = do+                            seen <- readIORef logs+                            if any isPassFailure seen+                                then pure ()+                                else threadDelay 20_000 >> go+                    go+                isPassFailure = \case+                    ResumePassFailed{} -> True+                    _ -> False+            first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done))+            first `shouldBe` Right Suspended+            Right () <-+                Store.runStoreIO store $+                    Store.runTransaction $+                        Tx.sql "ALTER TABLE keiro.keiro_workflow_steps RENAME TO keiro_workflow_steps_hidden"+            worker <- forkIO (runWorkflowResumeWorkerPush store opts registry)+            logged <- waitForPassFailure+            logged `shouldBe` Just ()+            Right () <-+                Store.runStoreIO store $+                    Store.runTransaction $+                        Tx.sql "ALTER TABLE keiro.keiro_workflow_steps_hidden RENAME TO keiro_workflow_steps"+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO store $+                    appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now)+            resumed <- timeout 5_000_000 (takeMVar done)+            status <- threadStatus worker+            killThread worker+            resumed `shouldBe` Just ()+            status `shouldSatisfy` \case+                ThreadFinished -> False+                ThreadDied -> False+                _ -> True++    describe "Keiro.Workflow push fallback (EP-50)" $ around (withFreshStore fixture) $ do+        -- Push is strictly an optimization: with the worker on 'neverWake' (every+        -- NOTIFY dropped) and a small fallback, the gated workflow still drains on+        -- the durable poll.+        it "still drains on the fallback timeout when no notification is delivered" $ \store -> do+            done <- newEmptyMVar+            let name = WorkflowName "fallbackwf"+                wid = WorkflowId "f-1"+                registry = Map.singleton name (WorkflowDef (\_ -> gateThenSignal done))+                onePass = void (Store.runStoreIO store (resumeWorkflowsOnce defaultWorkflowResumeOptions registry))+            first <- Store.runStoreIO store (runWorkflow name wid (gateThenSignal done))+            first `shouldBe` Right Suspended+            worker <- forkIO (runPollLoopWith neverWake 200000 onePass) -- 200 ms fallback, no notifications+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO store $+                    appendJournalEntry name wid (StepRecorded "awk:gate" (toJSON ()) now)+            resumed <- timeout 5000000 (takeMVar done)+            killThread worker+            resumed `shouldBe` Just ()++    describe "Shard lease" $ around (withFreshStore fixture) $ do+        -- EP-51 M2: claim / renew / release / expiry at the SQL layer, with explicit+        -- `now` timestamps standing in for the passage of time (no workers yet). The+        -- exclusion guarantee is the FOR UPDATE SKIP LOCKED claim; disjointness and+        -- failover are both observable purely from the lease table.+        let subName = SubscriptionName "orders-shard"+            wA = WorkerId sampleUuid+            wB = WorkerId sampleUuid2+            ttl = 30 :: NominalDiffTime+            t0 = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)+            tExpired = addUTCTime 60 t0 -- past A's 30 s lease+            shardOpts = defaultShardedWorkerOptions (Category (CategoryName "orders")) 4+        it "validates sharded worker options before startup" $ \_store -> do+            shouldBeRight_ (mkShardedWorkerOptions shardOpts)+            mkShardedWorkerOptions (shardOpts & #shardCount .~ 0)+                `shouldBeLeft` InvalidShardCount 0+            mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 0)+                `shouldBeLeft` InvalidShardLeaseTtl 0+            mkShardedWorkerOptions (shardOpts & #renewInterval .~ 0)+                `shouldBeLeft` InvalidShardRenewInterval 0+            mkShardedWorkerOptions (shardOpts & #leaseTtl .~ 10 & #renewInterval .~ 10)+                `shouldBeLeft` InvalidShardLeaseRenewInterval 10 10+            mkShardedWorkerOptions (shardOpts & #batchSize .~ 0)+                `shouldBeLeft` InvalidShardBatchSize 0+            mkShardedWorkerOptions (shardOpts & #bufferSize .~ 0)+                `shouldBeLeft` InvalidShardBufferSize 0+            mkShardedWorkerOptions (shardOpts & #handlerRetryDelay .~ KirokuSub.RetryDelay (-1))+                `shouldBeLeft` InvalidShardHandlerRetryDelay (KirokuSub.RetryDelay (-1))+            mkShardedWorkerOptions (shardOpts & #retryPolicy .~ KirokuSub.RetryPolicy 0)+                `shouldBeLeft` InvalidShardRetryMaxAttempts 0++        it "ensureShardRows populates N rows once (idempotent on re-run)" $ \store -> do+            Right () <- Store.runStoreIO store $ Store.runTransaction $ do+                ensureShardRows subName 4+                ensureShardRows subName 4+            Right rows <- Store.runStoreIO store $ Store.runTransaction (listShardOwnership subName)+            map (\(b, _, _) -> b) rows `shouldBe` [0, 1, 2, 3]+            all (\(_, o, _) -> isNothing o) rows `shouldBe` True++        it "worker A claims all N when free; B claims 0 while A holds valid leases" $ \store -> do+            Right claimedA <- Store.runStoreIO store $ Store.runTransaction $ do+                ensureShardRows subName 4+                claimShardsTx subName wA 4 t0 ttl+            claimedA `shouldBe` [0, 1, 2, 3]+            Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl)+            claimedB `shouldBe` []++        it "B claims A's buckets after A's lease expires; A then renews nothing" $ \store -> do+            Right _ <- Store.runStoreIO store $ Store.runTransaction $ do+                ensureShardRows subName 4+                claimShardsTx subName wA 4 t0 ttl+            Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 tExpired ttl)+            claimedB `shouldBe` [0, 1, 2, 3]+            -- A lost every bucket to B, so its renew returns the empty set: this is how+            -- a worker learns it no longer owns a bucket and stops reading it.+            Right heldA <- Store.runStoreIO store $ Store.runTransaction (renewLeaseTx subName wA tExpired ttl)+            heldA `shouldBe` []++        it "renewLease returns only still-held buckets" $ \store -> do+            Right held <- Store.runStoreIO store $ Store.runTransaction $ do+                ensureShardRows subName 4+                _ <- claimShardsTx subName wA 4 t0 ttl+                renewLeaseTx subName wA t0 ttl+            held `shouldBe` [0, 1, 2, 3]++        it "releaseShards: relinquished buckets are immediately claimable" $ \store -> do+            Right _ <- Store.runStoreIO store $ Store.runTransaction $ do+                ensureShardRows subName 4+                _ <- claimShardsTx subName wA 4 t0 ttl+                releaseShardsTx subName wA [0, 1]+            -- Even while A's lease over 2,3 is still valid, the released 0,1 are claimable.+            Right claimedB <- Store.runStoreIO store $ Store.runTransaction (claimShardsTx subName wB 4 t0 ttl)+            claimedB `shouldBe` [0, 1]++        it "fairShareTarget divides buckets evenly (ceil)" $ \_store -> do+            fairShareTarget 6 3 `shouldBe` 2+            fairShareTarget 6 4 `shouldBe` 2+            fairShareTarget 7 3 `shouldBe` 3+            fairShareTarget 4 0 `shouldBe` 4 -- a non-positive estimate claims everything+        it "acquireOutcome keeps previous ownership on acquire failure" $ \_store -> do+            let previous = Set.fromList [0, 2]+            acquireOutcome previous (Left "database unavailable")+                `shouldBe` (previous, Just (ShardAcquireFailed "database unavailable"))+            acquireOutcome previous (Right (Set.fromList [1, 3]))+                `shouldBe` (Set.fromList [1, 3], Nothing)++        it "ensureShards rejects a shardCount mismatch" $ \store -> do+            let lease4 =+                    ShardLease+                        { subscriptionName = subName+                        , workerId = wA+                        , shardCount = 4+                        , leaseTtl = ttl+                        }+                lease6 =+                    ShardLease+                        { subscriptionName = subName+                        , workerId = wA+                        , shardCount = 6+                        , leaseTtl = ttl+                        }+            Right () <- Store.runStoreIO store (ensureShards lease4)+            Store.runStoreIO store (ensureShards lease6)+                `shouldThrow` \case+                    ShardCountMismatch name configured found ->+                        name == "orders-shard" && configured == 6 && found == [4]++    describe "Sharded subscription single worker" $ around (withFreshStore fixture) $ do+        -- EP-51 M3: one process owning all N buckets drains a seeded category exactly+        -- once. The sink is idempotent on event_id, so "count == total" proves every+        -- event was delivered with none missing and none surviving as a duplicate row.+        it "one worker with N=4 buckets drains a seeded category exactly once" $ \store -> do+            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+            total <- seedOrders store 8 5 -- 40 events across 8 streams+            let opts =+                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4)+                        { leaseTtl = 3+                        , renewInterval = 0.3+                        }+            w <- forkIO (runShardedSubscriptionGroup store (SubscriptionName "orders-sub") opts (sinkHandler store 1))+            drained <- waitUntilSinkCount store total 20_000_000+            killThread w+            drained `shouldBe` True+            count <- shardSinkCount store+            count `shouldBe` total+            maxW <- maxWorkersPerStream store+            maxW `shouldBe` 1++    describe "Sharded subscription drain and failover" $ around (withFreshStore fixture) $ do+        -- EP-51 M5: the behavioural acceptance. Three worker processes cooperatively+        -- partition a category; we let ownership converge on the *empty* category+        -- first (so the churn of cold-start rebalancing touches no events), then seed+        -- and drain under stable membership — so each stream is owned by exactly one+        -- worker throughout the drain. Then we kill a worker and prove its buckets are+        -- re-homed and the new events drain (failover via lease expiry).+        let sub = SubscriptionName "orders-failover"+            mkOpts = (defaultShardedWorkerOptions (Category (CategoryName "orders")) 6){leaseTtl = 3, renewInterval = 0.3}+        it "three workers drain disjointly, then re-home a killed worker's buckets" $ \store -> do+            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+            w1 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 1))+            w2 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 2))+            w3 <- forkIO (runShardedSubscriptionGroup store sub mkOpts (sinkHandler store 3))+            -- Wait for cooperative balance on the empty category: all 6 buckets owned,+            -- spread across >= 2 workers, none holding more than its fair share.+            balanced <- waitShardsBalanced store sub 6 2 15_000_000+            balanced `shouldBe` True+            -- Now seed and drain under stable membership.+            total1 <- seedOrders store 12 5 -- 60 events+            ok1 <- waitUntilSinkCount store total1 25_000_000+            ok1 `shouldBe` True+            -- Disjoint: no stream key was processed by two workers (stable membership,+            -- so no re-homing split any stream).+            maxW <- maxWorkersPerStream store+            maxW `shouldBe` 1+            -- The work genuinely spread (not a monopoly): at least two workers participated.+            spread <- distinctWorkers store+            spread `shouldSatisfy` (>= 2)+            -- Counts sum to total with no duplicate event id (PK on event_id + count).+            c1 <- shardSinkCount store+            c1 `shouldBe` total1+            -- Kill worker 1 (its readers stop; it stops renewing, so its leases expire).+            killThread w1+            -- Seed more across all streams; some hash to worker 1's now-orphaned buckets.+            total2 <- seedOrders store 12 5 -- another 60+            -- Failover: a surviving worker re-claims the expired buckets and drains the+            -- new events. If re-homing did not happen, events on worker 1's buckets would+            -- never drain and this would time out.+            ok2 <- waitUntilSinkCount store (total1 + total2) 30_000_000+            killThread w2+            killThread w3+            ok2 `shouldBe` True+            c2 <- shardSinkCount store+            c2 `shouldBe` (total1 + total2)++        it "a killed worker relinquishes its leases immediately" $ \store -> do+            let subImmediate = SubscriptionName "orders-immediate-release"+                longTtlOpts =+                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4)+                        { leaseTtl = 30+                        , renewInterval = 0.2+                        }+            w <- forkIO (runShardedSubscriptionGroup store subImmediate longTtlOpts (sinkHandler store 1))+            owned <- waitShardsBalanced store subImmediate 4 1 10_000_000+            owned `shouldBe` True+            killThread w+            released <- waitShardsUnowned store subImmediate 4 3_000_000+            released `shouldBe` True++        it "a handler exception is retried in place and drains" $ \store -> do+            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+            thrown <- newIORef False+            errors <- newIORef []+            let subRestart = SubscriptionName "orders-reader-restart"+                opts =+                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 2)+                        { leaseTtl = 3+                        , renewInterval = 0.2+                        , handlerRetryDelay = KirokuSub.RetryDelay 0.05+                        , onShardError = Just (\err -> modifyIORef' errors (err :))+                        }+                handler ev = do+                    firstTime <-+                        atomicModifyIORef'+                            thrown+                            ( \seen ->+                                if seen+                                    then (seen, False)+                                    else (True, True)+                            )+                    when firstTime (throwIO (userError "reader boom"))+                    sinkHandler store 1 ev+            w <- forkIO (runShardedSubscriptionGroup store subRestart opts handler)+            balanced <- waitShardsBalanced store subRestart 2 1 10_000_000+            balanced `shouldBe` True+            total <- seedOrders store 4 2+            drained <- waitUntilSinkCount store total 20_000_000+            killThread w+            drained `shouldBe` True+            seenErrors <- readIORef errors+            seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True)++    describe "Sharded subscription ack coupling" $ around (withFreshStore fixture) $ do+        it "redelivers a batch-tail event whose handler was killed mid-flight" $ \store -> do+            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+            total <- seedOrders store 1 5+            enteredTail <- newEmptyMVar+            holdTail <- newEmptyMVar+            let sub = SubscriptionName "orders-ack-tail"+                opts =+                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1)+                        { leaseTtl = 3+                        , renewInterval = 0.3+                        }+                blockingHandler ev = do+                    let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload)+                    when (orderNumber == Right (4 :: Int)) $ do+                        putMVar enteredTail ()+                        takeMVar holdTail+                    sinkHandler store 1 ev+            first <- forkIO (runShardedSubscriptionGroup store sub opts blockingHandler)+            entered <- timeout 10_000_000 (takeMVar enteredTail)+            entered `shouldBe` Just ()+            -- The old pull bridge replies Continue before invoking the handler;+            -- leave enough time for its batch-tail checkpoint to commit while the+            -- handler remains blocked. The ack-coupled bridge introduced by EP-96+            -- remains blocked on the unfilled reply instead.+            threadDelay 200_000+            killThread first+            second <- forkIO (runShardedSubscriptionGroup store sub opts (sinkHandler store 2))+            drained <- waitUntilSinkCount store total 20_000_000+            killThread second+            drained `shouldBe` True+            shardSinkCount store `shouldReturn` total++        it "loses no events when a bucket is shed mid-drain during rebalance" $ \store -> do+            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+            total <- seedOrders store 24 5+            let sub = SubscriptionName "orders-ack-rebalance"+                opts =+                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 4)+                        { leaseTtl = 3+                        , renewInterval = 0.3+                        , batchSize = 1+                        }+                slowHandler tag ev = do+                    threadDelay 100_000+                    sinkHandler store tag ev+            first <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 1))+            -- acquireOwnedBuckets claims one bucket per pass. Starting the joiner+            -- while A owns three leaves one claimable bucket for B, making B visible;+            -- A's next pass then sheds its excess third bucket while its handler is+            -- deliberately slow and in flight.+            ownsThree <- waitUntilOwnedShardCount store sub 3 10_000_000+            ownsThree `shouldBe` True+            second <- forkIO (runShardedSubscriptionGroup store sub opts (slowHandler 2))+            drained <- waitUntilSinkCount store total 30_000_000+            killThread first+            killThread second+            drained `shouldBe` True+            shardSinkCount store `shouldReturn` total++        it "allows zombie overlap duplicates without losing an event" $ \store -> do+            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+            total <- seedOrders store 1 5+            entered <- newEmptyMVar+            release <- newEmptyMVar+            deliveries <- newIORef ([] :: [EventId])+            successor <- newIORef Nothing+            readersA <- newIORef Map.empty+            let sub = SubscriptionName "orders-ack-zombie"+                opts =+                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1)+                        { leaseTtl = 2+                        , renewInterval = 0.2+                        }+                leaseA =+                    ShardLease+                        { subscriptionName = sub+                        , workerId = WorkerId sampleUuid+                        , shardCount = 1+                        , leaseTtl = 2+                        }+                handlerA delivery = do+                    let ev = delivery ^. #event+                    modifyIORef' deliveries ((ev ^. #eventId) :)+                    putMVar entered ()+                    takeMVar release+                    sinkHandler store 1 ev+                    pure ShardAckOk+                handlerB delivery = do+                    let ev = delivery ^. #event+                    modifyIORef' deliveries ((ev ^. #eventId) :)+                    sinkHandler store 2 ev+                    pure ShardAckOk+                cleanup = do+                    void (tryPutMVar release ())+                    mSuccessor <- readIORef successor+                    for_ mSuccessor killThread+                    now <- getCurrentTime+                    let cleanupWorker = WorkerId sampleUuid2+                    _ <- Store.runStoreIO store $ Store.runTransaction $ do+                        releaseShardsTx sub (WorkerId sampleUuid) [0]+                        claimShardsTx sub cleanupWorker 1 now 30+                    void (reconcileShardsOnce store leaseA opts readersA handlerA)+            ( do+                    Right () <- Store.runStoreIO store (ensureShards leaseA)+                    void (reconcileShardsOnce store leaseA opts readersA handlerA)+                    timeout 10_000_000 (takeMVar entered) `shouldReturn` Just ()+                    -- A no longer renews, but its reader remains alive and blocked+                    -- with one unacknowledged event. B can claim after expiry and+                    -- must therefore receive that event again from the checkpoint.+                    threadDelay 2_500_000+                    workerB <- forkIO (runShardedSubscriptionGroupAck store sub opts handlerB)+                    writeIORef successor (Just workerB)+                    drained <- waitUntilSinkCount store total 20_000_000+                    drained `shouldBe` True+                    raw <- readIORef deliveries+                    length raw `shouldSatisfy` (> total)+                    shardSinkCount store `shouldReturn` total+                )+                `finally` cleanup++        it "dead-letters a poison event after bounded retries and keeps draining" $ \store -> do+            Right () <- Store.runStoreIO store $ Store.runTransaction (Tx.sql createShardSinkSql)+            total <- seedOrders store 1 4+            poisonDeliveries <- newIORef (0 :: Int)+            errors <- newIORef []+            let sub = SubscriptionName "orders-ack-poison"+                opts =+                    (defaultShardedWorkerOptions (Category (CategoryName "orders")) 1)+                        { leaseTtl = 3+                        , renewInterval = 0.2+                        , handlerRetryDelay = KirokuSub.RetryDelay 0.05+                        , retryPolicy = KirokuSub.RetryPolicy 3+                        , onShardError = Just (\err -> modifyIORef' errors (err :))+                        }+                handler ev = do+                    let orderNumber = parseEither (withObject "OrderPlaced" (.: "n")) (ev ^. #payload)+                    if orderNumber == Right (1 :: Int)+                        then do+                            modifyIORef' poisonDeliveries (+ 1)+                            throwIO (userError "poison order")+                        else sinkHandler store 1 ev+            worker <- forkIO (runShardedSubscriptionGroup store sub opts handler)+            drained <- waitUntilSinkCount store (total - 1) 20_000_000+            details <- shardDeadLetterDetails store "orders-ack-poison"+            attempts <- readIORef poisonDeliveries+            seenErrors <- readIORef errors+            killThread worker+            drained `shouldBe` True+            attempts `shouldBe` 3+            details `shouldBe` (1, Just "max retry attempts exceeded (3)", Just 3)+            seenErrors `shouldSatisfy` all (\case ShardReaderDied _ _ -> False; _ -> True)++    describe "Keiro.Workflow observability" $ around (withFreshStore fixture) $ do+        -- The headline operability signal: executed (real work) vs replayed+        -- (recorded history), recorded by the runtime through an SDK meter and read+        -- back from the in-memory exporter — plus the active gauge and the+        -- journal-length histogram.+        it "records workflow instruments through an SDK meter" $ \storeHandle -> do+            (exporter, ref) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            metrics <- Telemetry.newKeiroMetrics meter+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "obs"+                wid = WorkflowId "obs-1"+                opts = defaultWorkflowRunOptions & #metrics .~ Just metrics+            -- First run: both steps miss → two executions.+            first <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter)+            first `shouldBe` Right (Completed (1, 2))+            -- Second run, same id: both steps hit → two replays.+            second <- Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (demoWorkflow counter)+            second `shouldBe` Right (Completed (1, 2))+            -- The side effects ran exactly twice across both runs (the replay run+            -- short-circuited every step).+            readIORef counter >>= \c -> c `shouldBe` 2+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef ref+            let scalars = flattenScalarPoints exported+                hists = flattenHistogramPoints exported+            lookup "keiro.workflow.steps.executed" scalars `shouldBe` Just (IntNumber 2)+            lookup "keiro.workflow.steps.replayed" scalars `shouldBe` Just (IntNumber 2)+            -- One journal-length observation per completed run (two completions).+            [c | (n, c, _) <- hists, n == "keiro.workflow.journal.length"] `shouldBe` [2]+            -- Both runs finished, so the live-run count returned to zero.+            lookup "keiro.workflow.active" scalars `shouldBe` Just (IntNumber 0)++        -- The resume worker increments keiro.workflow.resumed per re-invocation and+        -- samples keiro.workflow.awakeables.pending each pass.+        it "records a resume and the pending-awakeable count when the worker re-invokes" $ \storeHandle -> do+            (exporter, ref) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+            metrics <- Telemetry.newKeiroMetrics meter+            counter <- newIORef (0 :: Int)+            let name = WorkflowName "obs-resume"+                wid = WorkflowId "obs-r-1"+            -- Suspend a workflow so it has a step row but no completion: the resume+            -- worker will re-invoke it (and stay Suspended, which still counts as a+            -- re-invocation).+            suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (stepThenAwaitWorkflow counter)+            suspended `shouldBe` Right Suspended+            -- Register one pending awakeable (independent of the suspended workflow's+            -- own await) so the pending gauge has something to count.+            let aid = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "ext") (WorkflowId "1") "cb")+            Right () <-+                Store.runStoreIO storeHandle $ Store.runTransaction $ Awk.registerAwakeableTx aid "ext" "1"+            -- One resume pass with metrics threaded through the run options.+            let registry = Map.singleton name (WorkflowDef (\_wid -> stepThenAwaitWorkflow counter))+                resumeOpts =+                    defaultWorkflowResumeOptions+                        & #runOptions+                        .~ (defaultWorkflowRunOptions & #metrics .~ Just metrics)+            Right _summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce resumeOpts registry+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef ref+            let scalars = flattenScalarPoints exported+            lookup "keiro.workflow.resumed" scalars `shouldBe` Just (IntNumber 1)+            lookup "keiro.workflow.awakeables.pending" scalars `shouldBe` Just (IntNumber 1)++        -- The no-op idiom end to end: defaultWorkflowRunOptions carries metrics =+        -- Nothing, so a run on a dedicated provider exports no points at all.+        it "records nothing through a Nothing handle" $ \storeHandle -> do+            (exporter, ref) <- inMemoryMetricExporter+            (provider, _env) <-+                createMeterProvider+                    emptyMaterializedResources+                    defaultSdkMeterProviderOptions{metricExporter = Just exporter}+            counter <- newIORef (0 :: Int)+            result <-+                Store.runStoreIO storeHandle $+                    runWorkflow (WorkflowName "obs-noop") (WorkflowId "obs-n-1") (demoWorkflow counter)+            result `shouldBe` Right (Completed (1, 2))+            _ <- forceFlushMeterProvider provider Nothing+            exported <- readIORef ref+            flattenScalarPoints exported `shouldBe` []+            flattenHistogramPoints exported `shouldBe` []++    describe "Keiro.Workflow.Snapshot codec" $ do+        -- Pure (no-DB) round-trip of the workflow state codec.+        it "round-trips a non-trivial accumulated step map and carries the sentinel shape hash" $ do+            let m =+                    Map.fromList+                        [ ("first", toJSON (1 :: Int))+                        , ("second", toJSON ["a", "b" :: Text])+                        , ("sleep:42", Aeson.Null)+                        ]+            (workflowStateCodec ^. #decode) ((workflowStateCodec ^. #encode) m) `shouldBe` Right m+            (workflowStateCodec ^. #shapeHash) `shouldBe` "keiro.workflow.stepmap.v1"+            (workflowStateCodec ^. #stateCodecVersion) `shouldBe` 1++    describe "Keiro.Workflow.Types journal codec" $ do+        -- Pure (no-DB) round-trip of the EP-48 rotation marker, proving the+        -- additive WorkflowContinuedAsNew constructor encodes and decodes+        -- self-describingly within schemaVersion 1.+        it "round-trips a WorkflowContinuedAsNew rotation marker" $ do+            let t = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 3600)+                marker = WorkflowContinuedAsNew 3 t+            (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) marker) ((workflowJournalCodec ^. #encode) marker)+                `shouldBe` Right marker+            (workflowJournalCodec ^. #schemaVersion) `shouldBe` 1+            EventType "WorkflowContinuedAsNew" `elem` (workflowJournalCodec ^. #eventTypes) `shouldBe` True++        it "validates workflow identity smart constructors" $ do+            mkWorkflowName "orderFulfillment" `shouldBe` Right (WorkflowName "orderFulfillment")+            mkWorkflowName "" `shouldBe` Left WorkflowNameEmpty+            mkWorkflowName "order-fulfillment" `shouldBe` Left (WorkflowNameInvalidChar '-' "order-fulfillment")+            mkWorkflowName "order:fulfillment" `shouldBe` Left (WorkflowNameInvalidChar ':' "order:fulfillment")+            mkWorkflowName "order#1" `shouldBe` Left (WorkflowNameInvalidChar '#' "order#1")+            mkWorkflowId "550e8400-e29b-41d4-a716-446655440000"+                `shouldBe` Right (WorkflowId "550e8400-e29b-41d4-a716-446655440000")+            mkWorkflowId "" `shouldBe` Left WorkflowIdEmpty+            mkWorkflowId "customer:42" `shouldBe` Left (WorkflowIdInvalidChar ':' "customer:42")+            mkWorkflowId "customer#42" `shouldBe` Left (WorkflowIdInvalidChar '#' "customer#42")++    describe "Keiro.Workflow.Sleep" $ do+        -- Pure (no-DB) checks of the id/payload/step-name helpers.+        it "derives a deterministic, distinct timer id" $ do+            let name = WorkflowName "wf"+                wid = WorkflowId "w-1"+                sleepGolden = uuidLiteral "a95d5e7f-a43d-5ee2-9243-8206f0d8734a"+            sleepTimerId name wid 0 "sleep:cool" `shouldBe` sleepTimerId name wid 0 "sleep:cool"+            (sleepTimerId name wid 0 "sleep:cool" == sleepTimerId name wid 0 "sleep:other")+                `shouldBe` False+            sleepTimerId name wid 0 "sleep:cool"+                `shouldBe` TimerId sleepGolden+            sleepTimerId name wid 1 "sleep:cool" `shouldNotBe` sleepTimerId name wid 0 "sleep:cool"+            sleepTimerId name wid 2 "sleep:cool" `shouldNotBe` sleepTimerId name wid 1 "sleep:cool"++        it "round-trips and recognises its timer payload" $ do+            parseSleepPayload (sleepTimerPayload "sleep:cool") `shouldBe` Just "sleep:cool"+            parseSleepPayload (object ["kind" Aeson..= ("counter-timeout" :: Text)])+                `shouldBe` Nothing++        it "prefixes the journal step name with the reserved sleep prefix" $+            sleepStepName (StepName "cool") `shouldBe` "sleep:cool"++        around (withFreshStore fixture) $ do+            it "arms a timer and suspends, then a fired timer resumes the workflow" $ \storeHandle -> do+                counter <- newIORef (0 :: Int)+                let name = WorkflowName "sleepdemo"+                    wid = WorkflowId "sd-1"+                    journalStream = StreamName "wf:sleepdemo-sd-1"+                    TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool"+                -- First run: 'a' runs, the sleep arms a timer, and the run suspends.+                outcome1 <-+                    Store.runStoreIO storeHandle $+                        runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0)+                outcome1 `shouldBe` Right Suspended+                afterFirst <- readIORef counter+                afterFirst `shouldBe` 1+                -- The journal holds only 'a' (no completion, no sleep:cool yet).+                Right recorded1 <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward journalStream (StreamVersion 0) 100+                traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded1)+                    `shouldSatisfy` \case+                        Right [StepRecorded "a" _ _] -> True+                        _ -> False+                -- The durable wait is a single Scheduled timer row carrying the+                -- workflow-sleep payload.+                Right timerRow <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Tx.statement timerUuid sleepTimerStatusStmt+                timerRow `shouldSatisfy` \case+                    Just (status, payload) ->+                        status == "scheduled" && parseSleepPayload payload == Just "sleep:cool"+                    Nothing -> False+                -- Fire the timer through the routing worker (no PM fallback needed).+                fireTime <- getCurrentTime+                fireResult <-+                    Store.runStoreIO storeHandle $+                        runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing)+                case fireResult of+                    Right (Just timer) -> timer ^. #status `shouldBe` Firing+                    other -> expectationFailure ("expected a fired sleep timer, got " <> show other)+                -- The row is now Fired and the journal gained sleep:cool.+                Right afterFire <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Tx.statement timerUuid sleepTimerStatusStmt+                fmap fst afterFire `shouldBe` Just "fired"+                Right recorded2 <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward journalStream (StreamVersion 0) 100+                traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded2)+                    `shouldSatisfy` \case+                        Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _] -> True+                        _ -> False+                -- Second run completes: 'a' and the sleep short-circuit, only 'b' runs.+                outcome2 <-+                    Store.runStoreIO storeHandle $+                        runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 0)+                outcome2 `shouldBe` Right (Completed (1, 2))+                afterSecond <- readIORef counter+                afterSecond `shouldBe` 2+                Right recorded3 <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward journalStream (StreamVersion 0) 100+                traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded3)+                    `shouldSatisfy` \case+                        Right [StepRecorded "a" _ _, StepRecorded "sleep:cool" _ _, StepRecorded "b" _ _, WorkflowCompleted _] -> True+                        _ -> False++            it "respects a positive delay: not due before fire_at, fires after" $ \storeHandle -> do+                counter <- newIORef (0 :: Int)+                let name = WorkflowName "sleepwait"+                    wid = WorkflowId "rt-1"+                    journalStream = StreamName "wf:sleepwait-rt-1"+                clockBeforeFire <- getCurrentTime+                outcome1 <-+                    Store.runStoreIO storeHandle $+                        runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1)+                outcome1 `shouldBe` Right Suspended+                afterFirst <- readIORef counter+                afterFirst `shouldBe` 1+                -- A worker whose clock is before fire_at claims nothing.+                notDue <-+                    Store.runStoreIO storeHandle $+                        runTimerWorker Nothing clockBeforeFire workflowSleepFireAction+                notDue `shouldBe` Right Nothing+                Right recordedMid <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward journalStream (StreamVersion 0) 100+                traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedMid)+                    `shouldSatisfy` \case+                        Right [StepRecorded "a" _ _] -> True+                        _ -> False+                -- Wait out the one-second delay, then the worker fires it.+                threadDelay 1_200_000+                afterDelay <- getCurrentTime+                fired <-+                    Store.runStoreIO storeHandle $+                        runTimerWorker Nothing afterDelay workflowSleepFireAction+                fired `shouldSatisfy` \case+                    Right (Just _) -> True+                    _ -> False+                Right recordedWoken <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward journalStream (StreamVersion 0) 100+                traverse (decodeRecorded workflowJournalCodec) (Vector.toList recordedWoken)+                    `shouldSatisfy` \case+                        Right [StepRecorded "a" _ _, StepRecorded "sleep:wait" _ _] -> True+                        _ -> False+                outcome2 <-+                    Store.runStoreIO storeHandle $+                        runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1)+                outcome2 `shouldBe` Right (Completed (1, 2))+                afterSecond <- readIORef counter+                afterSecond `shouldBe` 2++            it "does not postpone fire_at when a resume pass re-arms the sleep" $ \storeHandle -> do+                counter <- newIORef (0 :: Int)+                let name = WorkflowName "sleeponce"+                    wid = WorkflowId "so-1"+                    TimerId timerUuid = sleepTimerId name wid 0 "sleep:cool"+                    registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "cool") 300))+                Right Suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow name wid (sleepDemoNamed counter (StepName "cool") 300)+                Right (Just firstFireAt) <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Tx.statement timerUuid sleepTimerFireAtStmt+                Right summary <-+                    Store.runStoreIO storeHandle $+                        resumeWorkflowsOnce defaultWorkflowResumeOptions registry+                discovered summary `shouldBe` 0+                Right (Just secondFireAt) <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Tx.statement timerUuid sleepTimerFireAtStmt+                secondFireAt `shouldBe` firstFireAt+                readIORef counter >>= (`shouldBe` 1)++            it "skips a sleeping workflow until wake_after expires" $ \storeHandle -> do+                counter <- newIORef (0 :: Int)+                let name = WorkflowName "sleepwakeafter"+                    wid = WorkflowId "swa-1"+                Right Suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60)+                now <- getCurrentTime+                Right mWakeAfter <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid+                case mWakeAfter of+                    Nothing -> expectationFailure "expected wake_after"+                    Just wakeAfter -> wakeAfter `shouldSatisfy` (> now)+                Right early <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds now+                early `shouldBe` []+                Right due <- Store.runStoreIO storeHandle $ findUnfinishedWorkflowIds (addUTCTime 61 now)+                due `shouldBe` [("swa-1", "sleepwakeafter")]++            it "does not re-invoke a parked sleeper before wake_after" $ \storeHandle -> do+                counter <- newIORef (0 :: Int)+                let name = WorkflowName "sleepquiet"+                    wid = WorkflowId "sq-1"+                    registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 60))+                    pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)+                Right Suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60)+                Right s1 <- pass+                Right s2 <- pass+                Right s3 <- pass+                map discovered [s1, s2, s3] `shouldBe` [0, 0, 0]+                readIORef counter >>= (`shouldBe` 1)++            it "treats a missing instance row during sleep arm as a no-op wake hint update" $ \storeHandle -> do+                let name = WorkflowName "sleepmissingrow"+                    wid = WorkflowId "smr-1"+                    body = sleepNamed (StepName "wait") 60 >> pure ()+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body+                Right () <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Tx.statement ("smr-1", "sleepmissingrow") deleteWorkflowInstanceStmt+                Store.runStoreIO storeHandle (runWorkflow name wid body)+                    `shouldReturn` Right Suspended++            it "fires a sleep longer than the resume cadence under an active resume worker" $ \storeHandle -> do+                counter <- newIORef (0 :: Int)+                let name = WorkflowName "sleepactive"+                    wid = WorkflowId "sa-1"+                    registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 1))+                    drive 0 = expectationFailure "active resume cadence kept postponing the sleep"+                    drive n = do+                        Right summary <-+                            Store.runStoreIO storeHandle $+                                resumeWorkflowsOnce defaultWorkflowResumeOptions registry+                        now <- getCurrentTime+                        _ <-+                            Store.runStoreIO storeHandle $+                                runWorkflowTimerWorker Nothing now (\_ -> pure Nothing)+                        if completed summary == 1+                            then pure ()+                            else threadDelay 250_000 >> drive (n - 1)+                Right Suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1)+                drive (16 :: Int)+                readIORef counter >>= (`shouldBe` 2)++            it "uses generation-namespaced timer ids after continueAsNew" $ \storeHandle -> do+                counter <- newIORef (0 :: Int)+                let name = WorkflowName "sleeproll"+                    wid = WorkflowId "sr-1"+                    registry = Map.singleton name (WorkflowDef (\_ -> rollingSleepWorkflow counter))+                    drive 0 = expectationFailure "rolling sleep did not complete"+                    drive n = do+                        Right summary <-+                            Store.runStoreIO storeHandle $+                                resumeWorkflowsOnce defaultWorkflowResumeOptions registry+                        now <- getCurrentTime+                        _ <-+                            Store.runStoreIO storeHandle $+                                runWorkflowTimerWorker Nothing now (\_ -> pure Nothing)+                        if completed summary == 1+                            then pure ()+                            else drive (n - 1)+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (rollingSleepWorkflow counter)+                drive (12 :: Int)+                readIORef counter >>= (`shouldBe` 3)++    describe "Keiro.Workflow.Awakeable" $ do+        -- Pure (no-DB) check of the deterministic id derivation.+        it "derives a deterministic AwakeableId, stable across calls and label-sensitive" $ do+            let aid1 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval"+                aid2 = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "approval"+                aidOther = deterministicAwakeableId (WorkflowName "w") (WorkflowId "1") "other"+                awakeableGolden = uuidLiteral "ccaeaf74-3ffe-5ea5-a118-a3441a95c279"+            aid1 `shouldBe` aid2+            (aid1 == aidOther) `shouldBe` False+            aid1 `shouldBe` AwakeableId awakeableGolden++        around (withFreshStore fixture) $ do+            it "schema: registers, completes once (idempotent), cancels, and counts pending rows" $ \storeHandle -> do+                let aidA = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "a")+                    aidB = awakeableIdToUuid (deterministicAwakeableId (WorkflowName "sch") (WorkflowId "1") "b")+                now <- getCurrentTime+                Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ do+                    Awk.registerAwakeableTx aidA "sch" "1"+                    Awk.registerAwakeableTx aidB "sch" "1"+                Right pendingCount <- Store.runStoreIO storeHandle Awk.countPendingAwakeables+                pendingCount `shouldBe` 2+                Right (Just rowA) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA+                rowA ^. #status `shouldBe` Awk.Pending+                rowA ^. #payload `shouldBe` Nothing+                -- Complete A once; the status-guarded UPDATE makes a re-complete a no-op.+                Right firstComplete <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Awk.completeAwakeableTx aidA (toJSON ("done" :: Text)) now+                firstComplete `shouldBe` True+                Right secondComplete <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Awk.completeAwakeableTx aidA (toJSON ("again" :: Text)) now+                secondComplete `shouldBe` False+                Right (Just rowA') <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable aidA+                rowA' ^. #status `shouldBe` Awk.Completed+                rowA' ^. #payload `shouldBe` Just (toJSON ("done" :: Text))+                -- Cancel the still-pending B; both rows are now resolved.+                Right cancelled <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Awk.cancelAwakeableTx aidB+                cancelled `shouldBe` True+                Right pendingAfter <- Store.runStoreIO storeHandle Awk.countPendingAwakeables+                pendingAfter `shouldBe` 0++            it "suspends on an unsignalled awakeable, recording a pending row and no completion" $ \storeHandle -> do+                aidRef <- newIORef Nothing+                let name = WorkflowName "approval"+                    wid = WorkflowId "wf1"+                outcome1 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                outcome1 `shouldBe` Right Suspended+                aid <- readRequiredAwakeableId aidRef+                Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)+                row ^. #status `shouldBe` Awk.Pending+                row ^. #payload `shouldBe` Nothing+                Right pendingNow <- Store.runStoreIO storeHandle Awk.countPendingAwakeables+                pendingNow `shouldBe` 1+                Right recorded <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100+                traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded)+                    `shouldSatisfy` \case+                        Right [StepRecorded stepName value _] ->+                            stepName == awakeableAllocStepPrefix <> "approval" && value == toJSON aid+                        _ -> False++            it "resumes with the signalled payload after signalAwakeable" $ \storeHandle -> do+                aidRef <- newIORef Nothing+                let name = WorkflowName "approval"+                    wid = WorkflowId "wf1"+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                aid <- readRequiredAwakeableId aidRef+                let awkStep = "awk:" <> awakeableIdText aid+                Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)+                signalled `shouldBe` True+                Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)+                row ^. #status `shouldBe` Awk.Completed+                row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text))+                Right afterSignal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100+                traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterSignal)+                    `shouldSatisfy` \case+                        Right [StepRecorded allocStep _ _, StepRecorded s r _] ->+                            allocStep == awakeableAllocStepPrefix <> "approval" && s == awkStep && r == toJSON ("ok" :: Text)+                        _ -> False+                outcome2 <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                outcome2 `shouldBe` Right (Completed "ok!")+                Right afterResume <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:approval-wf1") (StreamVersion 0) 100+                traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterResume)+                    `shouldSatisfy` \case+                        Right [StepRecorded allocStep _ _, StepRecorded s1 _ _, StepRecorded "use" _ _, WorkflowCompleted _] ->+                            allocStep == awakeableAllocStepPrefix <> "approval" && s1 == awkStep+                        _ -> False++            it "is idempotent: a second signal returns False and does not change the value" $ \storeHandle -> do+                aidRef <- newIORef Nothing+                let name = WorkflowName "idem"+                    wid = WorkflowId "wf-i"+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                aid <- readRequiredAwakeableId aidRef+                let awkStep = "awk:" <> awakeableIdText aid+                Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)+                Right again <- Store.runStoreIO storeHandle $ signalAwakeable aid ("later" :: Text)+                again `shouldBe` False+                Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)+                row ^. #payload `shouldBe` Just (toJSON ("ok" :: Text))+                Right recorded <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:idem-wf-i") (StreamVersion 0) 100+                Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded))+                [r | StepRecorded s r _ <- decoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)]++            it "throws WorkflowAwakeableCancelled after cancelAwakeable" $ \storeHandle -> do+                aidRef <- newIORef Nothing+                let name = WorkflowName "cancelwf"+                    wid = WorkflowId "wf2"+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                aid <- readRequiredAwakeableId aidRef+                Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid+                cancelled `shouldBe` True+                Right (Just row) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)+                row ^. #status `shouldBe` Awk.Cancelled+                Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef))+                    `shouldThrow` (== WorkflowAwakeableCancelled aid)+                Right recorded <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:cancelwf-wf2") (StreamVersion 0) 100+                Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded))+                any (\case WorkflowCompleted{} -> True; _ -> False) decoded `shouldBe` False++            it "re-appends a missing journal entry when re-signalled (crash-safe)" $ \storeHandle -> do+                aidRef <- newIORef Nothing+                let name = WorkflowName "crash"+                    wid = WorkflowId "wf3"+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                aid <- readRequiredAwakeableId aidRef+                let awkStep = "awk:" <> awakeableIdText aid+                -- Simulate "row completed but the journal append did not happen" by+                -- completing the row directly, bypassing signalAwakeable's journal write.+                now <- getCurrentTime+                Right completedRow <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now+                completedRow `shouldBe` True+                Right beforeRepair <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100+                Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair))+                [() | StepRecorded s _ _ <- beforeDecoded, s == awkStep] `shouldBe` []+                -- A re-signal with the same payload returns False (already completed) but+                -- repairs the missing journal entry from the stored payload.+                Right repaired <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)+                repaired `shouldBe` False+                Right afterRepair <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:crash-wf3") (StreamVersion 0) 100+                Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair))+                [r | StepRecorded s r _ <- afterDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)]++            it "repairs a completed awakeable row from the await arm without a second signal" $ \storeHandle -> do+                aidRef <- newIORef Nothing+                let name = WorkflowName "crash-arm"+                    wid = WorkflowId "wf4"+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                aid <- readRequiredAwakeableId aidRef+                let awkStep = "awk:" <> awakeableIdText aid+                now <- getCurrentTime+                Right True <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Awk.completeAwakeableTx (awakeableIdToUuid aid) (toJSON ("ok" :: Text)) now+                repairedRun <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                repairedRun `shouldBe` Right Suspended+                Right repairedJournal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:crash-arm-wf4") (StreamVersion 0) 100+                Right repairedDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList repairedJournal))+                [r | StepRecorded s r _ <- repairedDecoded, s == awkStep] `shouldBe` [toJSON ("ok" :: Text)]+                completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                completed `shouldBe` Right (Completed "ok!")++            it "refuses a forged coordinate-derived id for a fresh awakeable" $ \storeHandle -> do+                aidRef <- newIORef Nothing+                let name = WorkflowName "fresh-awake"+                    wid = WorkflowId "fa-1"+                    forged = deterministicAwakeableId name wid "approval"+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                real <- readRequiredAwakeableId aidRef+                real `shouldNotBe` forged+                Right forgedSignal <- Store.runStoreIO storeHandle $ signalAwakeable forged ("bad" :: Text)+                forgedSignal `shouldBe` False+                Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                stillSuspended `shouldBe` Suspended+                Right realSignal <- Store.runStoreIO storeHandle $ signalAwakeable real ("ok" :: Text)+                realSignal `shouldBe` True+                completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                completed `shouldBe` Right (Completed "ok!")++            it "adopts a generation-0 legacy deterministic row" $ \storeHandle -> do+                aidRef <- newIORef Nothing+                let name = WorkflowName "legacy-awake"+                    wid = WorkflowId "la-1"+                    legacy = deterministicAwakeableId name wid "approval"+                Right () <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid)+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                adopted <- readRequiredAwakeableId aidRef+                adopted `shouldBe` legacy+                Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text)+                completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+                completed `shouldBe` Right (Completed "ok!")++            it "allocates a fresh awakeable for the same label after continueAsNew" $ \storeHandle -> do+                idsRef <- newIORef []+                let name = WorkflowName "awake-roll"+                    wid = WorkflowId "ar-1"+                    body = rollingAwakeableWorkflow idsRef+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body+                ids1 <- readIORef idsRef+                [firstAid] <- pure ids1+                Right True <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("first" :: Text)+                Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body+                ids2 <- readIORef idsRef+                case ids2 of+                    [firstAgain, secondAid] -> do+                        firstAgain `shouldBe` firstAid+                        secondAid `shouldNotBe` firstAid+                        Right staleSignal <- Store.runStoreIO storeHandle $ signalAwakeable firstAid ("stale" :: Text)+                        staleSignal `shouldBe` False+                        Right stillSuspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body+                        stillSuspended `shouldBe` Suspended+                        Right True <- Store.runStoreIO storeHandle $ signalAwakeable secondAid ("second" :: Text)+                        completed <- Store.runStoreIO storeHandle $ runWorkflow name wid body+                        completed `shouldBe` Right (Completed "second")+                    other -> expectationFailure ("expected two awakeable ids, got " <> show other)++    describe "Keiro.Workflow.Child" $ do+        -- M2: the reserved spawn/result step-name derivations are stable.+        it "derives the child spawn and result step names" $ do+            childSpawnStepName (WorkflowId "c1") `shouldBe` "child:c1"+            childResultStepName (WorkflowId "c1") `shouldBe` "child:c1:result"++        -- M3(a): the new terminal journal constructors round-trip through the codec.+        it "round-trips WorkflowCancelled and WorkflowFailed through the journal codec" $ do+            let t = UTCTime (ModifiedJulianDay 0) 0+                rt ev = (workflowJournalCodec ^. #decode) ((workflowJournalCodec ^. #eventType) ev) ((workflowJournalCodec ^. #encode) ev)+            rt (WorkflowCancelled t) `shouldBe` Right (WorkflowCancelled t)+            rt (WorkflowFailed "boom" t) `shouldBe` Right (WorkflowFailed "boom" t)++        around (withFreshStore fixture) $ do+            -- M1: the keiro_workflow_children table and its schema helpers.+            it "schema: registers, completes, cancels, and counts child links" $ \storeHandle -> do+                Right () <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Child.registerChildTx "c-1" "ship" "p-1" "parent" "child:c-1:result"+                Right (Just row) <- Store.runStoreIO storeHandle $ Child.lookupChild "c-1" "ship"+                row ^. #status `shouldBe` Child.Running+                row ^. #parentId `shouldBe` "p-1"+                row ^. #parentName `shouldBe` "parent"+                row ^. #awaitStep `shouldBe` "child:c-1:result"+                now <- getCurrentTime+                Right firstComplete <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Child.markChildResultTx "c-1" "ship" (toJSON ("packed+labelled" :: Text)) now+                firstComplete `shouldBe` True+                Right secondComplete <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Child.markChildResultTx "c-1" "ship" (toJSON ("again" :: Text)) now+                secondComplete `shouldBe` False+                Right () <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Child.registerChildTx "c-2" "ship" "p-1" "parent" "child:c-2:result"+                Right cancelled <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Child.markChildCancelledTx "c-2" "ship"+                cancelled `shouldBe` True+                Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p-1" "parent"+                map (^. #childId) kids `shouldBe` ["c-1", "c-2"]+                Right active <- Store.runStoreIO storeHandle Child.countActiveChildren+                active `shouldBe` (0 :: Int)+                Right st <- Store.runStoreIO storeHandle $ Child.childStatus "c-1" "ship"+                st `shouldBe` Just Child.ChildCompleted++            -- M4: spawn -> drive the child (with the completion hook) -> resume parent.+            it "spawns a child, drives it, propagates its result, and resumes the parent to Completed" $ \storeHandle -> do+                let childWid = WorkflowId "ship-1"+                suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid)+                suspended `shouldBe` Right Suspended+                Right parentJournal1 <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10+                Right decoded1 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal1))+                decoded1 `shouldSatisfy` \case+                    [StepRecorded "child:ship-1" _ _] -> True+                    _ -> False+                Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship"+                childRow ^. #status `shouldBe` Child.Running+                childRow ^. #parentId `shouldBe` "p1"+                childRow ^. #parentName `shouldBe` "parent"+                childRow ^. #awaitStep `shouldBe` "child:ship-1:result"+                -- 2) drive the child through runChildWorkflow (propagates on completion).+                childOutcome <-+                    Store.runStoreIO storeHandle $+                        runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow+                childOutcome `shouldBe` Right (Completed "packed+labelled")+                Right childJournal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:ship-ship-1") (StreamVersion 0) 10+                traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal)+                    `shouldSatisfy` \case+                        Right [StepRecorded "pack" _ _, StepRecorded "label" _ _, WorkflowCompleted _] -> True+                        _ -> False+                Right parentJournal2 <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10+                Right decoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal2))+                [r | StepRecorded "child:ship-1:result" r _ <- decoded2]+                    `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]]+                Right (Just childRow2) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-1" "ship"+                childRow2 ^. #status `shouldBe` Child.ChildCompleted+                -- 3) resume the parent: it replays past awaitChild and completes.+                resumed <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p1") (parentWorkflow childWid)+                resumed `shouldBe` Right (Completed "done:packed+labelled")+                Right parentJournal3 <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:parent-p1") (StreamVersion 0) 10+                Right decoded3 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal3))+                any (\case StepRecorded "notify" _ _ -> True; _ -> False) decoded3 `shouldBe` True+                any (\case WorkflowCompleted{} -> True; _ -> False) decoded3 `shouldBe` True++            it "repairs a completed child row from awaitChild without another completion hook" $ \storeHandle -> do+                let childWid = WorkflowId "ship-crash"+                Right Suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid)+                now <- getCurrentTime+                Right transitioned <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Child.markChildResultTx "ship-crash" "ship" (toJSON ("packed+labelled" :: Text)) now+                transitioned `shouldBe` True+                Right beforeRepair <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10+                Right beforeDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList beforeRepair))+                [r | StepRecorded "child:ship-crash:result" r _ <- beforeDecoded] `shouldBe` []+                repaired <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid)+                repaired `shouldBe` Right Suspended+                Right afterRepair <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:parent-p-crash") (StreamVersion 0) 10+                Right afterDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList afterRepair))+                [r | StepRecorded "child:ship-crash:result" r _ <- afterDecoded]+                    `shouldBe` [object ["ok" Aeson..= ("packed+labelled" :: Text)]]+                completed <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p-crash") (parentWorkflow childWid)+                completed `shouldBe` Right (Completed "done:packed+labelled")++            -- M5: re-invoking the parent does not re-spawn the child (crash survival).+            it "does not re-spawn the child when the parent is re-invoked" $ \storeHandle -> do+                let childWid = WorkflowId "ship-2"+                s1 <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid)+                s1 `shouldBe` Right Suspended+                Right (Just beforeRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-2" "ship"+                let createdAt0 = beforeRow ^. #createdAt+                s2 <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p2") (parentWorkflow childWid)+                s2 `shouldBe` Right Suspended+                Right parentJournal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:parent-p2") (StreamVersion 0) 10+                Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal))+                length [() | StepRecorded "child:ship-2" _ _ <- decoded] `shouldBe` 1+                Right kids <- Store.runStoreIO storeHandle $ Child.lookupChildrenOfParent "p2" "parent"+                length kids `shouldBe` 1+                map (^. #createdAt) kids `shouldBe` [createdAt0]++            -- M5: cancelling a child stops it and makes the parent's awaitChild throw.+            it "cancels a child: the child stops and the parent's awaitChild throws" $ \storeHandle -> do+                let childWid = WorkflowId "cancel-child"+                    h = ChildHandle (WorkflowName "ship") childWid+                s1 <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid)+                s1 `shouldBe` Right Suspended+                Right cancelled <- Store.runStoreIO storeHandle $ cancelChild h+                cancelled `shouldBe` True+                Right childJournal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10+                Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal))+                any (\case WorkflowCancelled{} -> True; _ -> False) childDecoded `shouldBe` True+                Right st <- Store.runStoreIO storeHandle $ Child.childStatus "cancel-child" "ship"+                st `shouldBe` Just Child.ChildCancelled+                Right parentJournal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:parent-p3") (StreamVersion 0) 10+                Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal))+                [r | StepRecorded "child:cancel-child:result" r _ <- parentDecoded]+                    `shouldBe` [object ["cancelled" Aeson..= True]]+                -- driving the child returns Cancelled and runs none of its steps.+                childOutcome <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "ship") childWid shipWorkflow+                childOutcome `shouldBe` Right Keiro.Workflow.Cancelled+                Right childJournal2 <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:ship-cancel-child") (StreamVersion 0) 10+                Right childDecoded2 <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal2))+                any (\case StepRecorded "pack" _ _ -> True; _ -> False) childDecoded2 `shouldBe` False+                -- re-invoking the parent throws WorkflowChildCancelled.+                Store.runStoreIO+                    storeHandle+                    (runWorkflow (WorkflowName "parent") (WorkflowId "p3") (parentWorkflow childWid))+                    `shouldThrow` (== WorkflowChildCancelled (WorkflowName "ship") childWid)++            it "repairs a cancelled child row when cancelChild is retried after the row flip" $ \storeHandle -> do+                let childWid = WorkflowId "cancel-child-crash"+                    h = ChildHandle (WorkflowName "ship") childWid+                Right Suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-crash") (parentWorkflow childWid)+                Right transitioned <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Child.markChildCancelledTx "cancel-child-crash" "ship"+                transitioned `shouldBe` True+                Right retried <- Store.runStoreIO storeHandle $ cancelChild h+                retried `shouldBe` False+                Right childJournal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:ship-cancel-child-crash") (StreamVersion 0) 10+                Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal))+                any (\case WorkflowCancelled{} -> True; _ -> False) childDecoded `shouldBe` True+                Right parentJournal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:parent-p-cancel-crash") (StreamVersion 0) 10+                Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal))+                [r | StepRecorded "child:cancel-child-crash:result" r _ <- parentDecoded]+                    `shouldBe` [object ["cancelled" Aeson..= True]]++            it "heals a cancelled-but-unmarked child from runChildWorkflow" $ \storeHandle -> do+                let childWid = WorkflowId "cancel-child-drive"+                Right Suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p-cancel-drive") (parentWorkflow childWid)+                Right True <-+                    Store.runStoreIO storeHandle $+                        Store.runTransaction $+                            Child.markChildCancelledTx "cancel-child-drive" "ship"+                childOutcome <-+                    Store.runStoreIO storeHandle $+                        runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow+                childOutcome `shouldBe` Right Keiro.Workflow.Cancelled+                Right childJournal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:ship-cancel-child-drive") (StreamVersion 0) 10+                Right childDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList childJournal))+                any (\case WorkflowCancelled{} -> True; _ -> False) childDecoded `shouldBe` True+                Right parentJournal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:parent-p-cancel-drive") (StreamVersion 0) 10+                Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal))+                [r | StepRecorded "child:cancel-child-drive:result" r _ <- parentDecoded]+                    `shouldBe` [object ["cancelled" Aeson..= True]]++            it "delivers an honest child result equal to the old cancellation sentinel" $ \storeHandle -> do+                let childWid = WorkflowId "json-cancelled-object"+                Right Suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid)+                childOutcome <-+                    Store.runStoreIO storeHandle $+                        runChildWorkflow defaultWorkflowRunOptions (WorkflowName "json-child") childWid jsonObjectChildWorkflow+                childOutcome `shouldBe` Right (Completed (object ["cancelled" Aeson..= True]))+                completed <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "json-parent") (WorkflowId "jp1") (jsonObjectParentWorkflow childWid)+                completed `shouldBe` Right (Completed (object ["cancelled" Aeson..= True]))+                Right parentJournal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:json-parent-jp1") (StreamVersion 0) 10+                Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal))+                [r | StepRecorded "child:json-cancelled-object:result" r _ <- parentDecoded]+                    `shouldBe` [object ["ok" Aeson..= object ["cancelled" Aeson..= True]]]++            it "throws WorkflowStepDecodeError when an enveloped child result has the wrong type" $ \storeHandle -> do+                let childWid = WorkflowId "decode-child"+                Right Suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid)+                Store.runStoreIO+                    storeHandle+                    (childCompletionHook (WorkflowName "ship") childWid (toJSON (42 :: Int)))+                    `shouldReturn` Right ()+                Store.runStoreIO+                    storeHandle+                    (runWorkflow (WorkflowName "parent") (WorkflowId "p-decode") (parentWorkflow childWid))+                    `shouldThrow` \case+                        WorkflowStepDecodeError key _ -> key == "child:decode-child:result"+                        _ -> False++            it "wakes a parent with WorkflowChildFailed when a child reaches the failure ceiling" $ \storeHandle -> do+                let childWid = WorkflowId "failed-child"+                    registry =+                        Map.fromList+                            [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid))+                            , (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text)))+                            ]+                    opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1+                Right Suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid)+                Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+                failed summary `shouldBe` 1+                Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "failed-child" "ship"+                childRow ^. #status `shouldBe` Child.ChildFailed+                Store.runStoreIO+                    storeHandle+                    (runWorkflow (WorkflowName "parent") (WorkflowId "p-failed-child") (parentWorkflow childWid))+                    `shouldThrow` \case+                        WorkflowChildFailed (WorkflowName "ship") (WorkflowId "failed-child") reason ->+                            "SimulatedCrash" `Text.isInfixOf` reason+                        _ -> False++            it "stops at the next step boundary when a workflow is cancelled mid-run" $ \storeHandle -> do+                counter <- newIORef 0+                let name = WorkflowName "self-cancel"+                    wid = WorkflowId "sc1"+                outcome <-+                    Store.runStoreIO storeHandle $+                        runWorkflow name wid (selfCancellingWorkflow name wid counter)+                outcome `shouldBe` Right Keiro.Workflow.Cancelled+                readIORef counter `shouldReturn` 2+                Right recorded <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:self-cancel-sc1") (StreamVersion 0) 10+                Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded))+                any (\case StepRecorded "three" _ _ -> True; _ -> False) decoded `shouldBe` False++            -- EP-42 worker-driven variant: the resume worker drives both parent and+            -- child from a registry, selecting childCompletionHook for the child and+            -- union-discovering the zero-step child.+            it "drives a parent and its child to completion through the resume worker" $ \storeHandle -> do+                let childWid = WorkflowId "ship-3"+                    registry =+                        Map.fromList+                            [ (WorkflowName "parent", WorkflowDef (\_ -> parentWorkflow childWid))+                            , (WorkflowName "ship", WorkflowDef (\_ -> shipWorkflow))+                            ]+                Right Suspended <-+                    Store.runStoreIO storeHandle $+                        runWorkflow (WorkflowName "parent") (WorkflowId "p4") (parentWorkflow childWid)+                let drive = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)+                Right _ <- drive+                Right _ <- drive+                Right _ <- drive+                Right parentJournal <-+                    Store.runStoreIO storeHandle $+                        Store.readStreamForward (StreamName "wf:parent-p4") (StreamVersion 0) 10+                Right parentDecoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList parentJournal))+                any (\case WorkflowCompleted{} -> True; _ -> False) parentDecoded `shouldBe` True+                Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "ship-3" "ship"+                childRow ^. #status `shouldBe` Child.ChildCompleted++            it "attaches to a completed child after continueAsNew" $ \storeHandle -> do+                let childWid = WorkflowId "ship-rotated"+                    parentName = WorkflowName "parent-rotating"+                    parentId = WorkflowId "p-rotating"+                    body = rotatingParentWorkflow childWid+                Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body+                childOutcome <-+                    Store.runStoreIO storeHandle $+                        runChildWorkflow defaultWorkflowRunOptions (WorkflowName "ship") childWid shipWorkflow+                childOutcome `shouldBe` Right (Completed "packed+labelled")+                Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body+                repair <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body+                repair `shouldBe` Right Suspended+                completed <- Store.runStoreIO storeHandle $ runWorkflow parentName parentId body+                completed `shouldBe` Right (Completed "packed+labelled")++    describe "Keiro.Workflow.Gc" $ around (withFreshStore fixture) $ do+        it "deletes terminal workflow data after retention" $ \storeHandle -> do+            let name = WorkflowName "gc-basic"+                wid = WorkflowId "gb-1"+                gcStreamName = workflowGenerationStreamName name wid 0+                aid = fromMaybe (error "invalid gc awakeable uuid") (fromString "00000000-0000-0000-0000-0000000000a1")+                timerId = fromMaybe (error "invalid gc timer uuid") (fromString "00000000-0000-0000-0000-0000000000a2")+            counter <- newIORef (0 :: Int)+            Right (Completed _) <-+                Store.runStoreIO storeHandle $+                    runWorkflowWith+                        (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal)+                        name+                        wid+                        (demoWorkflow counter)+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $ do+                        Awk.registerAwakeableTx aid "gc-basic" "gb-1"+                        Tx.statement (timerId, "gc-basic", "gb-1", now, object ["kind" Aeson..= ("keiro.workflow.sleep" :: Text)], "fired") insertGcTimerStmt+            Right beforeCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1"+            beforeCounts `shouldBe` (1, 3, 1, 0, 1, 1)+            Right freshSummary <-+                Store.runStoreIO storeHandle $+                    WorkflowGc.gcWorkflowsOnce+                        now+                        WorkflowGc.WorkflowGcPolicy{retention = 3600, batchSize = 10}+            freshSummary `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 0, deleted = 0}+            Right (Just _) <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName+            Right deletedSummary <-+                Store.runStoreIO storeHandle $+                    WorkflowGc.gcWorkflowsOnce+                        (addUTCTime 1 now)+                        WorkflowGc.WorkflowGcPolicy{retention = 0, batchSize = 10}+            deletedSummary `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 1, deleted = 1}+            Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId gcStreamName+            Right afterCounts <- Store.runStoreIO storeHandle $ workflowOwnedRowCounts "gc-basic" "gb-1"+            afterCounts `shouldBe` (0, 0, 0, 0, 0, 0)++        it "keeps completed children while a parent is live and converges after partial cleanup" $ \storeHandle -> do+            let parentName = WorkflowName "gc-live-parent"+                parentId = WorkflowId "gp-1"+                childName = WorkflowName "gc-child"+                childId = WorkflowId "gc-1"+            now <- getCurrentTime+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $ do+                        Instance.upsertInstanceTx "gp-1" "gc-live-parent" 0 Instance.WfRunning Nothing+                        Child.registerChildTx "gc-1" "gc-child" "gp-1" "gc-live-parent" "child:gc-1:result"+                        void (Child.markChildResultTx "gc-1" "gc-child" (toJSON ("ok" :: Text)) now)+            Right () <-+                Store.runStoreIO storeHandle $+                    appendJournalEntry childName childId (WorkflowCompleted now)+            Right held <-+                Store.runStoreIO storeHandle $+                    WorkflowGc.gcWorkflowsOnce+                        (addUTCTime 1 now)+                        WorkflowGc.WorkflowGcPolicy{retention = 0, batchSize = 10}+            held `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 0, deleted = 0}+            Right childStillThere <- Store.runStoreIO storeHandle $ Store.lookupStreamId (workflowGenerationStreamName childName childId 0)+            childStillThere `shouldSatisfy` isJust+            Right () <-+                Store.runStoreIO storeHandle $+                    appendJournalEntry parentName parentId (WorkflowCompleted now)+            Right () <-+                Store.runStoreIO storeHandle $+                    Store.runTransaction $+                        Tx.statement ("gc-1", "gc-child") deleteGcStepsStmt+            Right collected <-+                Store.runStoreIO storeHandle $+                    WorkflowGc.gcWorkflowsOnce+                        (addUTCTime 1 now)+                        WorkflowGc.WorkflowGcPolicy{retention = 0, batchSize = 10}+            collected `shouldBe` WorkflowGc.WorkflowGcSummary{scanned = 2, deleted = 2}+            Right parentGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance parentName parentId+            parentGone `shouldBe` Nothing+            Right childGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance childName childId+            childGone `shouldBe` Nothing+            Right childRows <- Store.runStoreIO storeHandle $ workflowOwnedChildCount "gc-child" "gc-1"+            childRows `shouldBe` 0++{- | Increment a shared counter and return its new value (the step's side+effect, so replay can be proven by watching the counter).+-}+incrementAndRead :: IORef Int -> IO Int+incrementAndRead ref = atomicModifyIORef' ref (\n -> (n + 1, n + 1))++{- | Six numbered steps, each returning its index after bumping a shared+counter. The counter lets a re-hydration prove the steps short-circuit+(it stays at 6 when every step is replayed from the journal/snapshot).+-}+countingSixSteps :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es [Int]+countingSixSteps counter =+    mapM+        (\i -> step (StepName ("s" <> Text.pack (show i))) (liftIO (incrementAndRead counter) >> pure i))+        [1 .. 6]++newtype Approx = Approx Double+    deriving stock (Eq, Show)++instance ToJSON Approx where+    toJSON (Approx d) = toJSON (round d :: Int)++instance FromJSON Approx where+    parseJSON value = do+        n <- Aeson.parseJSON value+        pure (Approx (fromIntegral (n :: Int)))++data RejectingRoundTrip = RejectingRoundTrip+    deriving stock (Eq, Show)++instance ToJSON RejectingRoundTrip where+    toJSON RejectingRoundTrip = Aeson.String "not-an-object"++instance FromJSON RejectingRoundTrip where+    parseJSON = Aeson.withObject "RejectingRoundTrip" $ \_ -> pure RejectingRoundTrip++{- | A distinguished exception used to simulate a process crash mid-workflow+(after a step has committed its journal append but before completion).+-}+data SimulatedCrash = SimulatedCrash+    deriving stock (Show)++instance Exception SimulatedCrash++{- | A three-step workflow; each step bumps a shared counter so a resume can+prove steps short-circuit (the counter only advances for steps that run).+-}+threeStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int)+threeStep counter = do+    a <- step (StepName "s1") (liftIO (incrementAndRead counter))+    b <- step (StepName "s2") (liftIO (incrementAndRead counter))+    c <- step (StepName "s3") (liftIO (incrementAndRead counter))+    pure (a, b, c)++threeStepThenSignal :: (Workflow :> es, IOE :> es) => IORef Int -> MVar () -> Eff es (Int, Int, Int)+threeStepThenSignal counter done = do+    result <- threeStep counter+    liftIO (putMVar done ())+    pure result++{- | Runs step @"s1"@ (which commits its own journal append) then crashes, so+the journal is left with one StepRecorded and no WorkflowCompleted.+-}+crashAfterStep1 :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int, Int)+crashAfterStep1 counter = do+    _ <- step (StepName "s1") (liftIO (incrementAndRead counter))+    _ <- liftIO (throwIO SimulatedCrash)+    pure (0, 0, 0)++{- | Awaits an external step, then runs a step that bumps the counter. Used to+prove the resume worker drives a suspended workflow to completion once its+awaited step is journaled.+-}+awaitingThenStep :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text+awaitingThenStep counter = do+    decision <- awaitStep (StepName "awk:approval") (pure ())+    _ <- step (StepName "use") (liftIO (incrementAndRead counter) >> pure (decision <> "!"))+    pure (decision <> "-done")++{- | A rolling-total workflow (EP-48 continue-as-new acceptance). It adds @total@+unit-valued work steps to a running total, rotating its journal every+@rotateEvery@ steps via 'continueAsNew'. The carried seed is the pair+@(runningTotal, stepsDoneGlobally)@ so each generation knows the global+progress; @genDone@ counts steps within the /current/ generation to bound it.+Each work step bumps @counter@ exactly once (proving rotation neither drops+nor double-counts) and returns 1, so the final total equals @total@.++Step names are the global step index (@w0@, @w1@, …), so they are unique+within each generation's journal and replay-stable. Note the regression+direction: on a tree where 'continueAsNew' did not rotate, this body would put+all @total@ steps on generation 0's single journal and the per-generation+@<= K@ bound below would fail for @total > K@.+-}+rollingTotal :: (Workflow :> es, IOE :> es) => IORef Int -> Int -> Int -> Eff es Int+rollingTotal counter rotateEvery total = do+    (acc0, done0) <- restoreSeed (0 :: Int, 0 :: Int)+    go acc0 done0 0+  where+    go acc done genDone+        | done >= total = pure acc -- all global work done: this generation completes+        | genDone >= rotateEvery = continueAsNew (acc, done) -- bound this generation; carry onward+        | otherwise = do+            n <-+                step+                    (StepName ("w" <> Text.pack (show done)))+                    (liftIO (modifyIORef' counter (+ 1) >> pure (1 :: Int)))+            go (acc + n) (done + 1) (genDone + 1)++-- The patch id under test (EP-49).+fraudPatchId :: PatchId+fraudPatchId = PatchId "fraud-check-v2"++{- | The workflow BEFORE the patch shipped: reserve, then await an external step+(so an instance can be left in flight, mid-journal, with one ordinary step+recorded and no completion). Used to create the in-flight instance.+-}+prePatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text+prePatchWorkflow counter = do+    _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ())+    (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ()) -- park here, in flight+    pure "old-done"++{- | The workflow AFTER the patch shipped: the same first step, then a+patch-gated cross-cutting branch. The in-flight instance (which already+journaled reserve-inventory under the pre-patch code) must observe False and+take the OLD branch; a fresh instance must observe True and take the NEW branch.+-}+postPatchWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text+postPatchWorkflow counter = do+    _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ())+    useNew <- patch fraudPatchId+    if useNew+        then step (StepName "new-charge") (pure "new-branch")+        else step (StepName "old-charge") (pure "old-branch")++postPatchAfterSuspendWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Text+postPatchAfterSuspendWorkflow counter = do+    _ <- step (StepName "reserve-inventory") (liftIO (incrementAndRead counter) >> pure ())+    (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ())+    useNew <- patch fraudPatchId+    if useNew+        then step (StepName "new-charge") (pure "new-branch")+        else step (StepName "old-charge") (pure "old-branch")++prePatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text+prePatchWakeOnlyWorkflow = do+    (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ())+    pure "old-done"++postPatchWakeOnlyWorkflow :: (Workflow :> es) => Eff es Text+postPatchWakeOnlyWorkflow = do+    (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ())+    useNew <- patch fraudPatchId+    if useNew+        then step (StepName "new-charge") (pure "new-branch")+        else step (StepName "old-charge") (pure "old-branch")++rotatingPatchWorkflow :: (Workflow :> es) => Eff es Text+rotatingPatchWorkflow = do+    seed <- restoreSeed (0 :: Int)+    if seed < 1+        then continueAsNew (seed + 1)+        else do+            useNew <- patch fraudPatchId+            if useNew+                then step (StepName "new-charge") (pure "new-branch")+                else step (StepName "old-charge") (pure "old-branch")++{- | A workflow (EP-50 push tests) that awaits an external "awk:gate" step, then+runs a step that fills @done@ — so a test can observe the exact moment the+workflow resumes to completion. Awaiting first means the journal is empty until+the external gate append, which is what makes the instance discoverable by the+resume worker (the gate's StepRecorded is the first index row).+-}+gateThenSignal :: (Workflow :> es, IOE :> es) => MVar () -> Eff es Text+gateThenSignal done = do+    (_ :: ()) <- awaitStep (StepName "awk:gate") (pure ())+    _ <- step (StepName "after-gate") (liftIO (putMVar done ()) >> pure ())+    pure "resumed"++-- | A two-step workflow whose steps each bump a shared counter.+demoWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int)+demoWorkflow counter = do+    a <- step (StepName "first") (liftIO (incrementAndRead counter))+    b <- step (StepName "second") (liftIO (incrementAndRead counter))+    pure (a, b)++{- | A workflow that immediately awaits a step nothing ever arms — used to+exercise the suspend path and external completion.+-}+neverArmingWorkflow :: (Workflow :> es) => Eff es Int+neverArmingWorkflow = awaitStep (StepName "awk:test") (pure ())++{- | The awakeable validation workflow: allocate a durable promise, suspend on+it, and (once signalled) append "!" to the payload through a recorded step.+-}+approvalFlowWithId :: (Workflow :> es, Store :> es, IOE :> es) => IORef (Maybe AwakeableId) -> Eff es Text+approvalFlowWithId ref = do+    (aid, await) <- awakeableNamed (StepName "approval")+    liftIO (writeIORef ref (Just aid))+    v <- await+    step (StepName "use") (pure (v <> "!"))++readRequiredAwakeableId :: IORef (Maybe AwakeableId) -> IO AwakeableId+readRequiredAwakeableId ref =+    readIORef ref >>= \case+        Just aid -> pure aid+        Nothing -> fail "workflow did not allocate an awakeable id"++uuidLiteral :: String -> UUID+uuidLiteral raw =+    case fromString raw of+        Just uuid -> uuid+        Nothing -> error ("invalid UUID literal in test: " <> raw)++{- | A two-step workflow with a durable sleep between the steps. The sleep's+name and delay are parameters so one helper drives both the zero-delta and+the real-time tests.+-}+sleepDemoNamed ::+    (Workflow :> es, Store :> es, IOE :> es) =>+    IORef Int -> StepName -> NominalDiffTime -> Eff es (Int, Int)+sleepDemoNamed counter sName delta = do+    a <- step (StepName "a") (liftIO (incrementAndRead counter))+    sleepNamed sName delta+    b <- step (StepName "b") (liftIO (incrementAndRead counter))+    pure (a, b)++rollingSleepWorkflow ::+    (Workflow :> es, Store :> es, IOE :> es) =>+    IORef Int -> Eff es Int+rollingSleepWorkflow counter = do+    seed <- restoreSeed (0 :: Int)+    _ <- step (StepName "work") (liftIO (incrementAndRead counter))+    if seed < 2+        then sleepNamed (StepName "cool") 0 >> continueAsNew (seed + 1)+        else pure seed++rollingAwakeableWorkflow ::+    (Workflow :> es, Store :> es, IOE :> es) =>+    IORef [AwakeableId] -> Eff es Text+rollingAwakeableWorkflow idsRef = do+    seed <- restoreSeed (0 :: Int)+    (aid, await) <- awakeableNamed (StepName "gate")+    liftIO (modifyIORef' idsRef (\ids -> if aid `elem` ids then ids else ids <> [aid]))+    value <- await+    if seed < 1+        then continueAsNew (seed + 1)+        else step (StepName "use") (pure value)++rotatingParentWorkflow ::+    (Workflow :> es, Store :> es, IOE :> es) =>+    WorkflowId -> Eff es Text+rotatingParentWorkflow childWid = do+    seed <- restoreSeed (0 :: Int)+    h <- spawnChild (WorkflowName "ship") childWid shipWorkflow+    result <- awaitChild h+    if seed < 1+        then continueAsNew (seed + 1)+        else pure result++{- | A workflow that records one step, then suspends on an await — so it has a+step row but no completion marker (the unfinished-discovery case).+-}+stepThenAwaitWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Int+stepThenAwaitWorkflow counter = do+    _ <- step (StepName "s1") (liftIO (incrementAndRead counter))+    awaitStep (StepName "awk:wait") (pure ())++-- | A two-step child workflow used in the child-workflow tests.+shipWorkflow :: (Workflow :> es) => Eff es Text+shipWorkflow = do+    a <- step (StepName "pack") (pure ("packed" :: Text))+    b <- step (StepName "label") (pure (a <> "+labelled"))+    pure b++{- | A parent that spawns a @"ship"@ child (id supplied), awaits its result, and+then records a @notify@ step. Parametrised by child id so each test isolates+its own child journal.+-}+parentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Text+parentWorkflow childWid = do+    h <- spawnChild (WorkflowName "ship") childWid shipWorkflow+    result <- awaitChild h+    _ <- step (StepName "notify") (pure ("done:" <> result))+    pure ("done:" <> result)++jsonObjectChildWorkflow :: Eff es Aeson.Value+jsonObjectChildWorkflow =+    pure (object ["cancelled" Aeson..= True])++jsonObjectParentWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowId -> Eff es Aeson.Value+jsonObjectParentWorkflow childWid = do+    h <- spawnChild (WorkflowName "json-child") childWid jsonObjectChildWorkflow+    result <- awaitChild h+    _ <- step (StepName "json-notify") (pure ())+    pure result++selfCancellingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int+selfCancellingWorkflow name wid counter = do+    _ <- step (StepName "one") (liftIO (incrementAndRead counter))+    _ <-+        step (StepName "two") $ do+            now <- liftIO getCurrentTime+            appendJournalEntry name wid (WorkflowCancelled now)+            liftIO (incrementAndRead counter)+    step (StepName "three") (liftIO (incrementAndRead counter))++nominalDays :: Int -> NominalDiffTime+nominalDays n = fromIntegral n * 86400++attrKeyText :: AttributeKey Text -> Text+attrKeyText = unkey++attrKeyTextInt64 :: AttributeKey Int64 -> Text+attrKeyTextInt64 = unkey++textAttr :: Attributes -> Text -> Maybe Text+textAttr attrs name = case lookupAttribute attrs name of+    Just (AttributeValue (TextAttribute t)) -> Just t+    _ -> Nothing++intAttr :: Attributes -> Text -> Maybe Int64+intAttr attrs name = case lookupAttribute attrs name of+    Just (AttributeValue (IntAttribute n)) -> Just n+    _ -> Nothing++{- | A frozen snapshot of an 'ImmutableSpan'. In hs-opentelemetry 1.0 the+mutable span fields (name, attributes, status) live behind the+@spanHot :: IORef SpanHot@ field rather than directly on 'ImmutableSpan',+so the tests read that reference once after the span ends and assert on+this flat record.+-}+data CapturedSpan = CapturedSpan+    { csName :: Text+    , csKind :: SpanKind+    , csAttributes :: Attributes+    , csStatus :: SpanStatus+    , csContext :: SpanContext+    , csParent :: Maybe Span+    }++captureSpan :: ImmutableSpan -> IO CapturedSpan+captureSpan sp = do+    hot <- readIORef (spanHot sp)+    pure+        CapturedSpan+            { csName = hotName hot+            , csKind = spanKind sp+            , csAttributes = hotAttributes hot+            , csStatus = hotStatus hot+            , csContext = spanContext sp+            , csParent = spanParent sp+            }++{- | Tiny in-process \"Kafka topic\": an MVar of consumed records plus an+incrementing offset. The publisher pushes records here; the consumer+drains the MVar. There is no real broker — the goal of the fixture is+to validate that the keiro envelope and outbox/inbox semantics+compose correctly across two isolated PostgreSQL contexts.+-}+newtype KafkaTopic = KafkaTopic (MVar (Int64, [InboxKafka.KafkaInboundRecord]))++newKafkaTopic :: IO KafkaTopic+newKafkaTopic = KafkaTopic <$> newMVar (0, [])++kafkaTopicAccept :: (MonadIO m) => KafkaTopic -> OutboxRow -> m ()+kafkaTopicAccept (KafkaTopic ref) row = liftIO $ do+    let record = OutboxKafka.outboxRowToKafkaRecord row+        headersText =+            [ (TE.decodeUtf8 name, TE.decodeUtf8 value)+            | (name, value) <- record ^. #headers+            ]+    now <- getCurrentTime+    modifyMVar ref $ \(nextOffset, acc) ->+        let inbound =+                InboxKafka.KafkaInboundRecord+                    { topic = record ^. #topic+                    , partition = 0+                    , offset = nextOffset+                    , key = fmap TE.decodeUtf8 (record ^. #key)+                    , payload = record ^. #payload+                    , headers = headersText+                    , receivedAt = now+                    }+         in pure ((nextOffset + 1, inbound : acc), ())++kafkaTopicPublish ::+    forall es.+    (IOE :> es) =>+    KafkaTopic ->+    OutboxRow ->+    Eff es PublishOutcome+kafkaTopicPublish topic row = do+    kafkaTopicAccept topic row+    pure PublishSucceeded++perRow ::+    (OutboxRow -> Eff es PublishOutcome) ->+    [OutboxRow] ->+    Eff es [(OutboxId, PublishOutcome)]+perRow publish rows =+    traverse publishOne rows+  where+    publishOne row = do+        outcome <- publish row+        pure (row ^. #outboxId, outcome)++drainKafkaTopic :: KafkaTopic -> IO [InboxKafka.KafkaInboundRecord]+drainKafkaTopic (KafkaTopic ref) = do+    (_, acc) <- readMVar ref+    pure (reverse acc)++redeliverWithDifferentOffset ::+    InboxKafka.KafkaInboundRecord ->+    InboxKafka.KafkaInboundRecord+redeliverWithDifferentOffset record = record & #offset .~ (record ^. #offset) + 1000++data ConsumeResult a+    = ConsumeDecodeFailed !InboxKafka.KafkaDecodeError+    | ConsumePolicyUnsatisfied !InboxError+    | ConsumeApplied !(InboxResult a)+    deriving stock (Eq, Show)++{- | A worker-shaped consumer: decode the Kafka record into an+IntegrationEvent and run it through the inbox.+-}+consumeAndApply ::+    forall es.+    (IOE :> es, Store :> es) =>+    InboxKafka.KafkaInboundRecord ->+    (IntegrationEvent -> Tx.Transaction ()) ->+    Eff es (ConsumeResult ())+consumeAndApply record handler =+    case InboxKafka.integrationEventFromKafka record of+        Left err -> pure (ConsumeDecodeFailed err)+        Right (event, kafkaRef) -> do+            result <-+                runInboxTransaction Nothing PreferIntegrationMessageId event (Just kafkaRef) handler+            case result of+                Left err -> pure (ConsumePolicyUnsatisfied err)+                Right applied -> pure (ConsumeApplied applied)++billingReactionHandler :: IntegrationEvent -> Tx.Transaction ()+billingReactionHandler event = case decodeJsonIntegrationEvent event of+    Left _ -> Tx.condemn+    Right (OrderSubmittedPayload orderId quantity) ->+        Tx.statement (orderId, fromIntegral quantity :: Int64) insertReceivedOrderStmt++loggingReactionHandler :: Text -> IntegrationEvent -> Tx.Transaction ()+loggingReactionHandler _ event = do+    -- The cross-context test only needs the (eventType, key) pair, not+    -- the decoded payload.+    let key = fromMaybe "" (event ^. #key)+    Tx.statement (event ^. #source, event ^. #eventType, key) appendBillingEventLogStmt++insertReceivedOrderStmt :: Statement (Text, Int64) ()+insertReceivedOrderStmt =+    preparable+        """+        INSERT INTO billing_received_orders (order_id, quantity) VALUES ($1, $2)+        ON CONFLICT (order_id) DO NOTHING+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int8))+        )+        D.noResult++billingReceivedOrdersCountStmt :: Statement () Int+billingReceivedOrdersCountStmt =+    preparable+        "SELECT COUNT(*)::bigint FROM billing_received_orders"+        E.noParams+        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++appendBillingEventLogStmt :: Statement (Text, Text, Text) ()+appendBillingEventLogStmt =+    preparable+        "INSERT INTO billing_event_log (source, event_type, order_id) VALUES ($1, $2, $3)"+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++billingEventLogStmt :: Statement () [(Text, Text)]+billingEventLogStmt =+    preparable+        "SELECT event_type, order_id FROM billing_event_log ORDER BY seq"+        E.noParams+        ( D.rowList+            ( (,)+                <$> D.column (D.nonNullable D.text)+                <*> D.column (D.nonNullable D.text)+            )+        )++orderSubmittedEnvelope :: Text -> Int -> Text -> IntegrationEvent+orderSubmittedEnvelope orderId quantity messageId =+    encodeJsonIntegrationEvent+        ( sampleIntegrationEnvelope+            & #messageId+            .~ messageId+            & #eventType+            .~ "OrderSubmitted"+            & #key+            .~ Just orderId+        )+        (OrderSubmittedPayload orderId quantity)++orderCancelledEnvelope :: Text -> Text -> IntegrationEvent+orderCancelledEnvelope orderId messageId =+    sampleIntegrationEnvelope+        & #messageId+        .~ messageId+        & #eventType+        .~ "OrderCancelled"+        & #key+        .~ Just orderId+        & #payloadBytes+        .~ ("{\"orderId\":\"" <> TE.encodeUtf8 orderId <> "\"}")+        & #contentType+        .~ ApplicationJson++inboxTestCounterInsertStmt :: Statement Text ()+inboxTestCounterInsertStmt =+    preparable+        "INSERT INTO inbox_test_counter (message_id) VALUES ($1)"+        (E.param (E.nonNullable E.text))+        D.noResult++inboxTestCounterCountStmt :: Statement () Int+inboxTestCounterCountStmt =+    preparable+        "SELECT COUNT(*)::bigint FROM inbox_test_counter"+        E.noParams+        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++sampleProducer :: IntegrationProducer ()+sampleProducer =+    IntegrationProducer+        { name = "ordering-integration-producer"+        , source = "ordering"+        , messageIdPrefix = "msg"+        , mapEvent = \_recorded () -> Just sampleDraft+        }++sampleDraft :: IntegrationEventDraft+sampleDraft =+    IntegrationEventDraft+        { destination = "billing.orders.v1"+        , key = Just "order-123"+        , eventType = "OrderSubmitted"+        , schemaVersion = 1+        , contentType = ApplicationJson+        , schemaReference = Nothing+        , sourceEventId = Nothing+        , sourceGlobalPosition = Nothing+        , payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}"+        , occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)+        , causationId = Nothing+        , correlationId = Nothing+        , traceContext = Nothing+        , attributes = Just (object ["source" Aeson..= ("test-suite" :: Text)])+        }++sampleOutboxRow :: IntegrationEvent -> OutboxRow+sampleOutboxRow event =+    OutboxRow+        { outboxId = OutboxId outboxUuid1+        , event+        , status = OutboxPending+        , attemptCount = 0+        , nextAttemptAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)+        , lastError = Nothing+        , publishedAt = Nothing+        , createdAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)+        , updatedAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)+        }++backdateOutboxUpdatedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es ()+backdateOutboxUpdatedAt oid timestamp =+    Store.runTransaction $+        Tx.statement (unOutboxId oid, timestamp) backdateOutboxUpdatedAtStmt++backdateOutboxUpdatedAtStmt :: Statement (UUID, UTCTime) ()+backdateOutboxUpdatedAtStmt =+    preparable+        "UPDATE keiro.keiro_outbox SET updated_at = $2 WHERE outbox_id = $1"+        ( contrazip2+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.timestamptz))+        )+        D.noResult++backdateOutboxPublishedAt :: (Store :> es) => OutboxId -> UTCTime -> Eff es ()+backdateOutboxPublishedAt oid timestamp =+    Store.runTransaction $+        Tx.statement (unOutboxId oid, timestamp) backdateOutboxPublishedAtStmt++backdateOutboxPublishedAtStmt :: Statement (UUID, UTCTime) ()+backdateOutboxPublishedAtStmt =+    preparable+        "UPDATE keiro.keiro_outbox SET published_at = $2 WHERE outbox_id = $1"+        ( contrazip2+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.timestamptz))+        )+        D.noResult++outboxUuid1, outboxUuid2, outboxUuid3, outboxUuid4 :: UUID+outboxUuid1 = case fromString "018f0f18-0000-7000-8000-000000000a01" of+    Just uuid -> uuid+    Nothing -> error "invalid outbox uuid 1"+outboxUuid2 = case fromString "018f0f18-0000-7000-8000-000000000a02" of+    Just uuid -> uuid+    Nothing -> error "invalid outbox uuid 2"+outboxUuid3 = case fromString "018f0f18-0000-7000-8000-000000000a03" of+    Just uuid -> uuid+    Nothing -> error "invalid outbox uuid 3"+outboxUuid4 = case fromString "018f0f18-0000-7000-8000-000000000a04" of+    Just uuid -> uuid+    Nothing -> error "invalid outbox uuid 4"++outboxIdFromOrdinal :: Word64 -> OutboxId+outboxIdFromOrdinal n =+    OutboxId (fromWords64 0x018f0f1800007000 (0x8000000000000000 + n))++uniqueIds :: (Eq a) => [a] -> [a]+uniqueIds = foldr (\x xs -> if x `elem` xs then xs else x : xs) []++data OrderSubmittedPayload = OrderSubmittedPayload+    { orderId :: !Text+    , quantity :: !Int+    }+    deriving stock (Generic, Eq, Show)++instance ToJSON OrderSubmittedPayload where+    toJSON = genericToJSON (aesonPrefix camelCase)+    toEncoding = genericToEncoding (aesonPrefix camelCase)++instance FromJSON OrderSubmittedPayload where+    parseJSON = genericParseJSON (aesonPrefix camelCase)++sampleIntegrationEnvelope :: IntegrationEvent+sampleIntegrationEnvelope =+    IntegrationEvent+        { messageId = "018f0f18-17aa-7000-8000-0000000000aa"+        , source = "ordering"+        , destination = "billing.orders.v1"+        , key = Just "order-123"+        , eventType = "OrderSubmitted"+        , schemaVersion = 1+        , contentType = ApplicationJson+        , schemaReference =+            Just+                SchemaReference+                    { registry = Just "https://schemas.example/registry"+                    , subject = Just "billing.orders.v1.OrderSubmitted"+                    , version = Just 1+                    , schemaId = Just 42+                    , fingerprint = Just "sha256:abc123"+                    }+        , sourceEventId = Just (EventId integrationSourceEventUuid)+        , sourceGlobalPosition = Just (GlobalPosition 42)+        , payloadBytes = "{\"orderId\":\"order-123\",\"quantity\":5}"+        , occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)+        , causationId = Just (EventId integrationCausationUuid)+        , correlationId = Just (EventId integrationCorrelationUuid)+        , traceContext =+            Just+                TraceContext+                    { traceparent = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+                    , tracestate = Just "rojo=00f067aa0ba902b7"+                    }+        , attributes = Nothing+        }++integrationSourceEventUuid :: UUID+integrationSourceEventUuid =+    case fromString "018f0f18-17aa-7000-8000-000000000003" of+        Just uuid -> uuid+        Nothing -> error "invalid integration source event UUID"++integrationCausationUuid :: UUID+integrationCausationUuid =+    case fromString "018f0f18-17aa-7000-8000-000000000004" of+        Just uuid -> uuid+        Nothing -> error "invalid integration causation UUID"++integrationCorrelationUuid :: UUID+integrationCorrelationUuid =+    case fromString "018f0f18-17aa-7000-8000-000000000005" of+        Just uuid -> uuid+        Nothing -> error "invalid integration correlation UUID"++data OrderStream++data OrderEvent+    = OrderPlaced !Text !Int+    deriving stock (Generic, Eq, Show)++data OrderState+    = Idle+    deriving stock (Generic, Eq, Show)++data OrderCommand+    = PlaceOrder+    deriving stock (Generic, Eq, Show)++orderCodec :: Codec OrderEvent+orderCodec =+    Codec+        { eventTypes = EventType "OrderPlaced" :| []+        , eventType = \case+            OrderPlaced{} -> EventType "OrderPlaced"+        , schemaVersion = 2+        , encode = \case+            OrderPlaced orderId quantity ->+                object ["orderId" Aeson..= orderId, "quantity" Aeson..= quantity]+        , decode = parseOrderPlaced+        , upcasters = [(1, const upcastOrderPlacedV1)]+        }++gappyCodec :: Codec OrderEvent+gappyCodec =+    Codec+        { eventTypes = orderCodec ^. #eventTypes+        , eventType = orderCodec ^. #eventType+        , schemaVersion = 4+        , encode = orderCodec ^. #encode+        , decode = orderCodec ^. #decode+        , upcasters = [(1, const upcastOrderPlacedV1), (3, const Right)]+        }++parseOrderPlaced :: EventType -> Value -> Either Text OrderEvent+parseOrderPlaced _ value =+    case parseEither parser value of+        Right event -> Right event+        Left message -> Left (fromStringLiteral message)+  where+    parser = withObject "OrderPlaced" $ \objectValue ->+        OrderPlaced+            <$> objectValue .: "orderId"+            <*> objectValue .: "quantity"++upcastOrderPlacedV1 :: Value -> Either Text Value+upcastOrderPlacedV1 value =+    case parseEither parser value of+        Right migrated -> Right migrated+        Left message -> Left (fromStringLiteral message)+  where+    parser = withObject "OrderPlacedV1" $ \objectValue -> do+        orderId <- objectValue .: "orderId"+        quantity <- objectValue .: "qty"+        pure (object ["orderId" Aeson..= (orderId :: Text), "quantity" Aeson..= (quantity :: Int)])++metadataForOrDie :: Int -> Maybe Value -> Value+metadataForOrDie version existing =+    either (error . show) id (metadataFor version existing)++emptyTransducer :: SymTransducer () '[] OrderState OrderCommand OrderEvent+emptyTransducer =+    SymTransducer+        { edgesOut = \_ -> []+        , initial = Idle+        , initialRegs = RNil+        , isFinal = \_ -> True+        }++type CounterEventStream = EventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent++type ValidatedCounterEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent++type SnapshotCounterRegs = '[ '("lastAmount", Int)]++type UninitializedSnapshotRegs = '[ '("initialized", Int), '("neverWritten", Int)]++type SnapshotCounterEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent++type PartialSnapshotEventStream = EventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent++type ValidatedSnapshotCounterEventStream = ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent++type UninitializedSnapshotEventStream = EventStream (HsPred UninitializedSnapshotRegs CounterCommand) UninitializedSnapshotRegs CounterState CounterCommand CounterEvent++data CounterCommand+    = Add !Int+    deriving stock (Generic, Eq, Show)++data SkipCommand+    = SAdd !Int+    | SSkip+    deriving stock (Generic, Eq, Show)++data CounterEvent+    = CounterAdded !Int+    | CounterAudited !Int+    deriving stock (Generic, Eq, Show)++data CounterState+    = Counting+    deriving stock (Generic, Eq, Show, Enum, Bounded, Ord)+    deriving anyclass (FromJSON, ToJSON)++data DrainState+    = Draining+    | Drained+    deriving stock (Generic, Eq, Show, Enum, Bounded, Ord)++data PartialSnapshotState+    = SnapshotEncodable+    | SnapshotEncodeBomb+    deriving stock (Generic, Eq, Show, Enum, Bounded, Ord)++instance ToJSON PartialSnapshotState where+    toJSON SnapshotEncodable = Aeson.String "encodable"+    toJSON SnapshotEncodeBomb = error "snapshot state encoder exploded"++instance FromJSON PartialSnapshotState where+    parseJSON = Aeson.withText "PartialSnapshotState" $ \case+        "encodable" -> pure SnapshotEncodable+        "bomb" -> pure SnapshotEncodeBomb+        other -> fail ("unknown partial snapshot state: " <> Text.unpack other)++counterEventStreamDef :: CounterEventStream+counterEventStreamDef =+    EventStream+        { transducer = counterTransducer+        , initialState = Counting+        , initialRegisters = RNil+        , eventCodec = counterCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++counterEventStream :: ValidatedCounterEventStream+counterEventStream = mkEventStreamOrThrow "counter" counterEventStreamDef++noOpCounterEventStreamDef :: CounterEventStream+noOpCounterEventStreamDef =+    counterEventStreamDef & #transducer .~ noOpCounterTransducer++noOpCounterEventStream :: ValidatedCounterEventStream+noOpCounterEventStream = mkEventStreamOrThrow "counter-no-op" noOpCounterEventStreamDef++counterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+counterTransducer =+    SymTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard = matchInCtor addCtor+                    , update = UKeep+                    , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)]+                    , target = Counting+                    }+                ]+        , initial = Counting+        , initialRegs = RNil+        , isFinal = \_ -> False+        }++noOpCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+noOpCounterTransducer =+    SymTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard = matchInCtor addCtor+                    , update = UKeep+                    , output = []+                    , target = Counting+                    }+                ]+        , initial = Counting+        , initialRegs = RNil+        , isFinal = \_ -> False+        }++multiCounterEventStreamDef :: CounterEventStream+multiCounterEventStreamDef =+    counterEventStreamDef & #transducer .~ multiCounterTransducer++multiCounterEventStream :: ValidatedCounterEventStream+multiCounterEventStream = mkEventStreamOrThrow "counter-multi" multiCounterEventStreamDef++multiCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+multiCounterTransducer =+    SymTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard = matchInCtor addCtor+                    , update = UKeep+                    , output =+                        [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)+                        , pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)+                        ]+                    , target = Counting+                    }+                ]+        , initial = Counting+        , initialRegs = RNil+        , isFinal = \_ -> False+        }++{- | Both guards match at runtime but remain outside keiki's conservative pure+overlap fragment. Distinct head event constructors keep inversion unambiguous,+so this is a validated stream that exercises the runtime step witness.+-}+ambiguousCounterEventStreamDef :: CounterEventStream+ambiguousCounterEventStreamDef =+    counterEventStreamDef & #transducer .~ ambiguousCounterTransducer++ambiguousCounterEventStream :: ValidatedCounterEventStream+ambiguousCounterEventStream =+    mkEventStreamOrThrow "counter-ambiguous" ambiguousCounterEventStreamDef++ambiguousCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+ambiguousCounterTransducer =+    counterTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard = ambiguousGuard+                    , update = UKeep+                    , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)]+                    , target = Counting+                    }+                , Edge+                    { guard = ambiguousGuard+                    , update = UKeep+                    , output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)]+                    , target = Counting+                    }+                ]+        }+  where+    ambiguousGuard = PAnd (matchInCtor addCtor) (PNot PBot)++snapshotCounterEventStreamDef :: SnapshotCounterEventStream+snapshotCounterEventStreamDef =+    EventStream+        { transducer = snapshotCounterTransducer+        , initialState = Counting+        , initialRegisters = RCons (Proxy @"lastAmount") 0 RNil+        , eventCodec = counterCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Every 2+        , stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @CounterState 1)+        }++partialSnapshotEventStream :: ValidatedEventStream (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs PartialSnapshotState CounterCommand CounterEvent+partialSnapshotEventStream = mkEventStreamOrThrow "partial-snapshot" partialSnapshotEventStreamDef++partialSnapshotEventStreamDef :: PartialSnapshotEventStream+partialSnapshotEventStreamDef =+    EventStream+        { transducer =+            SymTransducer+                { edgesOut = \_ ->+                    [ Edge+                        { guard = matchInCtor addCtor+                        , update =+                            USet+                                (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int)+                                (inpCtor addCtor #amount)+                        , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)]+                        , target = SnapshotEncodeBomb+                        }+                    ]+                , initial = SnapshotEncodable+                , initialRegs = RCons (Proxy @"lastAmount") 0 RNil+                , isFinal = \_ -> False+                }+        , initialState = SnapshotEncodable+        , initialRegisters = RCons (Proxy @"lastAmount") 0 RNil+        , eventCodec = counterCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Every 1+        , stateCodec = Just (defaultStateCodec @SnapshotCounterRegs @PartialSnapshotState 1)+        }++uninitializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream+uninitializedSnapshotEventStreamDef =+    initializedSnapshotEventStreamDef+        & #initialRegisters+        .~ RCons (Proxy @"initialized") 0 (emptyRegFile @'[ '("neverWritten", Int)])++initializedSnapshotEventStreamDef :: UninitializedSnapshotEventStream+initializedSnapshotEventStreamDef =+    EventStream+        { transducer =+            SymTransducer+                { edgesOut = \case Counting -> []+                , initial = Counting+                , initialRegs = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil)+                , isFinal = \_ -> False+                }+        , initialState = Counting+        , initialRegisters = RCons (Proxy @"initialized") 0 (RCons (Proxy @"neverWritten") 0 RNil)+        , eventCodec = counterCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Every 2+        , stateCodec = Just (defaultStateCodec @UninitializedSnapshotRegs @CounterState 1)+        }++snapshotCounterEventStream :: ValidatedSnapshotCounterEventStream+snapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter" snapshotCounterEventStreamDef++snapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent+snapshotCounterTransducer =+    SymTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard = matchInCtor addCtor+                    , update =+                        USet+                            (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int)+                            (inpCtor addCtor #amount)+                    , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)]+                    , target = Counting+                    }+                ]+        , initial = Counting+        , initialRegs = RCons (Proxy @"lastAmount") 0 RNil+        , isFinal = \_ -> False+        }++multiSnapshotCounterEventStreamDef :: SnapshotCounterEventStream+multiSnapshotCounterEventStreamDef =+    snapshotCounterEventStreamDef+        & #transducer+        .~ multiSnapshotCounterTransducer+        & #snapshotPolicy+        .~ Every 1++multiSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream+multiSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-multi" multiSnapshotCounterEventStreamDef++multiSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent+multiSnapshotCounterTransducer =+    SymTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard = matchInCtor addCtor+                    , update =+                        USet+                            (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int)+                            (inpCtor addCtor #amount)+                    , output =+                        [ pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)+                        , pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)+                        ]+                    , target = Counting+                    }+                ]+        , initial = Counting+        , initialRegs = RCons (Proxy @"lastAmount") 0 RNil+        , isFinal = \_ -> False+        }++guardedSnapshotCounterEventStreamDef :: SnapshotCounterEventStream+guardedSnapshotCounterEventStreamDef =+    snapshotCounterEventStreamDef & #transducer .~ guardedSnapshotCounterTransducer++guardedSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream+guardedSnapshotCounterEventStream = mkEventStreamOrThrow "snapshot-counter-guarded" guardedSnapshotCounterEventStreamDef++guardedSnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent+guardedSnapshotCounterTransducer =+    SymTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard =+                        PAnd+                            (matchInCtor addCtor)+                            (inpCtor addCtor #amount .== proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int))+                    , update =+                        USet+                            (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int)+                            (inpCtor addCtor #amount)+                    , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)]+                    , target = Counting+                    }+                ]+        , initial = Counting+        , initialRegs = RCons (Proxy @"lastAmount") 0 RNil+        , isFinal = \_ -> False+        }++{- | A deliberately replay-unsafe stream: its single edge is an ε-edge+(empty @output@) whose @update@ reads the command's @amount@. Because+the edge emits no event, that command field cannot be recovered on+replay, so keiki's hidden-input check flags it. Used to prove+'validateEventStream' / 'mkEventStream' reject an unsafe stream.+-}+brokenHiddenInputEventStream :: SnapshotCounterEventStream+brokenHiddenInputEventStream =+    snapshotCounterEventStreamDef & #transducer .~ brokenHiddenInputTransducer++brokenHiddenInputTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent+brokenHiddenInputTransducer =+    SymTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard = matchInCtor addCtor+                    , update =+                        USet+                            (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int)+                            (inpCtor addCtor #amount)+                    , output = []+                    , target = Counting+                    }+                ]+        , initial = Counting+        , initialRegs = RCons (Proxy @"lastAmount") 0 RNil+        , isFinal = \_ -> False+        }++{- | A multi-event edge whose tail carries the command field omitted from its+head. The union of the outputs covers @amount@, but replay commits to an edge+by inverting only the head, so the stored chain cannot reconstruct @Add@.+-}+headUnrecoverableEventStreamDef :: CounterEventStream+headUnrecoverableEventStreamDef =+    counterEventStreamDef & #transducer .~ headUnrecoverableTransducer++headUnrecoverableEventStream :: ValidatedCounterEventStream+headUnrecoverableEventStream = mkEventStreamUnchecked headUnrecoverableEventStreamDef++headUnrecoverableTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+headUnrecoverableTransducer =+    counterTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard = matchInCtor addCtor+                    , update = UKeep+                    , output =+                        [ pack addCtor counterAddedCtor (Keiki.lit 0 *: oNil)+                        , pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)+                        ]+                    , target = Counting+                    }+                ]+        }++{- | Two edges share a head wire constructor, so one stored event can invert+through both. The double-negated guard is true at runtime but deliberately+outside keiki's pure overlap fragment, isolating the inversion warning from+the separate conservative determinism check.+-}+inversionAmbiguousEventStreamDef :: CounterEventStream+inversionAmbiguousEventStreamDef =+    counterEventStreamDef & #transducer .~ inversionAmbiguousTransducer++inversionAmbiguousEventStream :: ValidatedCounterEventStream+inversionAmbiguousEventStream =+    case mkEventStreamWith+        Keiki.defaultValidationOptions{Keiki.checkInversionAmbiguity = False}+        "counter-inversion-ambiguous"+        inversionAmbiguousEventStreamDef of+        Right validated -> validated+        Left warnings -> error ("expected inversion-ambiguity override to validate: " <> show warnings)++inversionAmbiguousTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+inversionAmbiguousTransducer =+    counterTransducer+        { edgesOut = \case+            Counting ->+                [ ambiguousEdge+                , ambiguousEdge+                ]+        }+  where+    ambiguousEdge =+        Edge+            { guard = PAnd (matchInCtor addCtor) (PNot PBot)+            , update = UKeep+            , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)]+            , target = Counting+            }++{- | This edge reads @Add.amount@ while guarded only by @PTop@. A different+command constructor would reach the partial projection and crash instead of+being rejected.+-}+unguardedInputReadEventStreamDef :: CounterEventStream+unguardedInputReadEventStreamDef =+    counterEventStreamDef & #transducer .~ unguardedInputReadTransducer++unguardedInputReadTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+unguardedInputReadTransducer =+    counterTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard = PTop+                    , update = UKeep+                    , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)]+                    , target = Counting+                    }+                ]+        }++{- | A silent self-loop that writes a register. With no emitted event the+write cannot be reconstructed from the durable log.+-}+stateChangingEpsilonEventStreamDef :: SnapshotCounterEventStream+stateChangingEpsilonEventStreamDef =+    snapshotCounterEventStreamDef & #transducer .~ stateChangingEpsilonTransducer++stateChangingEpsilonTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent+stateChangingEpsilonTransducer =+    snapshotCounterTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard = matchInCtor addCtor+                    , update =+                        USet+                            (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int)+                            (Keiki.lit 0)+                    , output = []+                    , target = Counting+                    }+                ]+        }++type SilentMoveEventStream = EventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent++silentMoveEventStreamDef :: SilentMoveEventStream+silentMoveEventStreamDef =+    EventStream+        { transducer = silentMoveTransducer+        , initialState = Draining+        , initialRegisters = RNil+        , eventCodec = counterCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++silentMoveTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent+silentMoveTransducer =+    SymTransducer+        { edgesOut = \case+            Draining ->+                [ Edge+                    { guard = matchInCtor addCtor+                    , update = UKeep+                    , output = []+                    , target = Drained+                    }+                ]+            Drained -> []+        , initial = Draining+        , initialRegs = RNil+        , isFinal = (== Drained)+        }++isStateChangingEpsilon :: Keiki.TransducerValidationWarning s -> Bool+isStateChangingEpsilon = \case+    Keiki.StateChangingEpsilon{} -> True+    _ -> False++expectValidationWarning ::+    (Bounded s, Enum s, Ord s, Show s) =>+    Text ->+    Text ->+    EventStream (HsPred rs ci) rs s ci co ->+    Expectation+expectValidationWarning label prefix eventStream =+    case mkEventStream label eventStream of+        Left warnings -> do+            map eswStreamLabel warnings `shouldSatisfy` all (== label)+            map eswReason warnings `shouldSatisfy` any (Text.isInfixOf prefix)+        Right _ ->+            expectationFailure+                ( "expected mkEventStream to reject "+                    <> Text.unpack label+                    <> " with warning prefix "+                    <> Text.unpack prefix+                )++type AddFields = '[ '("amount", Int)]++type SkipEventStream = EventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent++type ValidatedSkipEventStream = ValidatedEventStream (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent++skipEventStream :: ValidatedSkipEventStream+skipEventStream = mkEventStreamOrThrow "skip-command" skipEventStreamDef++skipEventStreamDef :: SkipEventStream+skipEventStreamDef =+    EventStream+        { transducer = skipTransducer+        , initialState = Counting+        , initialRegisters = RNil+        , eventCodec = counterCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++skipTransducer :: SymTransducer (HsPred '[] SkipCommand) '[] CounterState SkipCommand CounterEvent+skipTransducer =+    SymTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard = matchInCtor sAddCtor+                    , update = UKeep+                    , output = [pack sAddCtor counterAddedCtor (inpCtor sAddCtor #amount *: oNil)]+                    , target = Counting+                    }+                , Edge+                    { guard = matchInCtor sSkipCtor+                    , update = UKeep+                    , output = []+                    , target = Counting+                    }+                ]+        , initial = Counting+        , initialRegs = RNil+        , isFinal = \_ -> False+        }++sAddCtor :: InCtor SkipCommand AddFields+sAddCtor =+    InCtor+        { icName = "SAdd"+        , icMatch = \case+            SAdd amount -> Just (RCons Proxy amount RNil)+            SSkip -> Nothing+        , icBuild = \case+            RCons _ amount RNil -> SAdd amount+        }++sSkipCtor :: InCtor SkipCommand '[]+sSkipCtor =+    InCtor+        { icName = "SSkip"+        , icMatch = \case+            SAdd{} -> Nothing+            SSkip -> Just RNil+        , icBuild = \case+            RNil -> SSkip+        }++addCtor :: InCtor CounterCommand AddFields+addCtor =+    InCtor+        { icName = "Add"+        , icMatch = \case+            Add amount -> Just (RCons Proxy amount RNil)+        , icBuild = \case+            RCons _ amount RNil -> Add amount+        }++counterAddedCtor :: WireCtor CounterEvent (Int, ())+counterAddedCtor =+    WireCtor+        { wcName = "CounterAdded"+        , wcMatch = \case+            CounterAdded amount -> Just (amount, ())+            CounterAudited{} -> Nothing+        , wcBuild = \case+            (amount, ()) -> CounterAdded amount+        }++counterAuditedCtor :: WireCtor CounterEvent (Int, ())+counterAuditedCtor =+    WireCtor+        { wcName = "CounterAudited"+        , wcMatch = \case+            CounterAudited amount -> Just (amount, ())+            CounterAdded{} -> Nothing+        , wcBuild = \case+            (amount, ()) -> CounterAudited amount+        }++counterCodec :: Codec CounterEvent+counterCodec =+    Codec+        { eventTypes = EventType "CounterAdded" :| [EventType "CounterAudited"]+        , eventType = \case+            CounterAdded{} -> EventType "CounterAdded"+            CounterAudited{} -> EventType "CounterAudited"+        , schemaVersion = 1+        , encode = \case+            CounterAdded amount -> object ["amount" Aeson..= amount]+            CounterAudited amount -> object ["amount" Aeson..= amount, "audited" Aeson..= True]+        , decode = parseCounterEvent+        , upcasters = []+        }++parseCounterEvent :: EventType -> Value -> Either Text CounterEvent+parseCounterEvent (EventType tag) value =+    case parseEither parser value of+        Right event -> Right event+        Left message -> Left (fromStringLiteral message)+  where+    parser = withObject "CounterEvent" $ \objectValue -> do+        amount <- objectValue .: "amount"+        case tag of+            "CounterAdded" -> pure (CounterAdded amount)+            "CounterAudited" -> pure (CounterAudited amount)+            _ -> fail "unknown counter event type"++counterProcessManager ::+    ProcessManager+        CounterEvent+        (HsPred '[] CounterCommand)+        '[]+        CounterState+        CounterCommand+        CounterEvent+        (HsPred '[] CounterCommand)+        '[]+        CounterState+        CounterCommand+        CounterEvent+counterProcessManager =+    ProcessManager+        { name = "counter-pm"+        , correlate = \_ -> "order-1"+        , eventStream = counterEventStream+        , streamFor = \correlationId -> stream ("pm:counter-" <> correlationId)+        , targetEventStream = counterEventStream+        , targetProjections = const []+        , handle = \case+            CounterAdded amount ->+                ProcessManagerAction+                    { command = Add amount+                    , commands =+                        [ PMCommand+                            { target = stream "counter-target-order-1"+                            , command = Add amount+                            }+                        ]+                    , timers = [counterTimerRequest]+                    }+            CounterAudited amount ->+                ProcessManagerAction+                    { command = Add amount+                    , commands = []+                    , timers = []+                    }+        }++timerOnlyProcessManager ::+    ProcessManager+        CounterEvent+        (HsPred '[] CounterCommand)+        '[]+        CounterState+        CounterCommand+        CounterEvent+        (HsPred '[] CounterCommand)+        '[]+        CounterState+        CounterCommand+        CounterEvent+timerOnlyProcessManager =+    ProcessManager+        { name = "timer-only-pm"+        , correlate = \_ -> "order-1"+        , eventStream = noOpCounterEventStream+        , streamFor = \correlationId -> stream ("pm:timer-only-" <> correlationId)+        , targetEventStream = counterEventStream+        , targetProjections = const []+        , handle = \case+            CounterAdded amount ->+                ProcessManagerAction+                    { command = Add amount+                    , commands = []+                    , timers =+                        [ counterTimerRequest+                            & #processManagerName+                            .~ "timer-only-pm"+                        ]+                    }+            CounterAudited amount ->+                ProcessManagerAction+                    { command = Add amount+                    , commands = []+                    , timers = []+                    }+        }++-- A process manager whose OWN state stream snapshots under Every 2.+-- This is the first PM fixture to exercise a state-stream snapshot: the only+-- difference from counterProcessManager is that its eventStream carries a+-- snapshotPolicy + stateCodec (it reuses snapshotCounterEventStream), so+-- runProcessManagerOnce's manager-state append (which goes through+-- runCommandWithSql) writes and reuses snapshots. The manager registers are+-- SnapshotCounterRegs because the eventStream is a SnapshotCounterEventStream;+-- the target side stays '[]/counterEventStream exactly as counterProcessManager.+pmSnapshotCounterEventStreamDef :: SnapshotCounterEventStream+pmSnapshotCounterEventStreamDef = snapshotCounterEventStreamDef++pmSnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream+pmSnapshotCounterEventStream = mkEventStreamOrThrow "pm-snapshot-counter" pmSnapshotCounterEventStreamDef++pmSnapshotProcessManager ::+    ProcessManager+        CounterEvent+        (HsPred SnapshotCounterRegs CounterCommand)+        SnapshotCounterRegs+        CounterState+        CounterCommand+        CounterEvent+        (HsPred '[] CounterCommand)+        '[]+        CounterState+        CounterCommand+        CounterEvent+pmSnapshotProcessManager =+    ProcessManager+        { name = "counter-snap-pm"+        , correlate = \_ -> "order-1"+        , eventStream = pmSnapshotCounterEventStream+        , streamFor = \correlationId -> stream ("pm:counter-snap-" <> correlationId)+        , targetEventStream = counterEventStream+        , targetProjections = const []+        , handle = \case+            CounterAdded amount ->+                ProcessManagerAction+                    { command = Add amount+                    , commands = [] -- keep the test focused on the manager state stream+                    , timers = []+                    }+            CounterAudited amount ->+                ProcessManagerAction+                    { command = Add amount+                    , commands = []+                    , timers = []+                    }+        }++workflowProcessManager ::+    Text ->+    Text ->+    Text ->+    ProcessManager+        CounterEvent+        (HsPred '[] CounterCommand)+        '[]+        CounterState+        CounterCommand+        CounterEvent+        (HsPred '[] CounterCommand)+        '[]+        CounterState+        CounterCommand+        CounterEvent+workflowProcessManager managerName managerCategory targetStreamName =+    counterProcessManager+        { name = managerName+        , streamFor = \correlationId -> stream (managerCategory <> "-" <> correlationId)+        , handle = \case+            CounterAdded amount ->+                ProcessManagerAction+                    { command = Add amount+                    , commands =+                        [ PMCommand+                            { target = stream targetStreamName+                            , command = Add amount+                            }+                        ]+                    , timers = []+                    }+            CounterAudited amount ->+                ProcessManagerAction+                    { command = Add amount+                    , commands = []+                    , timers = []+                    }+        }++assertWorkflowProcessManagerAppended ::+    Either+        Store.StoreError+        ( Either+            CommandError+            (ProcessManagerResult CounterEventStream CounterEventStream)+        ) ->+    Expectation+assertWorkflowProcessManagerAppended = \case+    Right (Right pmResult) -> do+        pmResult ^. #managerResult `shouldSatisfy` \case+            PMStateAppended{} -> True+            _ -> False+        pmResult ^. #commandResults `shouldSatisfy` \case+            [PMCommandAppended{}] -> True+            _ -> False+    other -> expectationFailure ("expected workflow process-manager success, got " <> show other)++counterTimerRequest :: TimerRequest+counterTimerRequest =+    TimerRequest+        { timerId = TimerId sampleUuid+        , processManagerName = "counter-pm"+        , correlationId = "order-1"+        , fireAt = dueTimerTime+        , payload = object ["kind" Aeson..= ("counter-timeout" :: Text)]+        }++dueTimerTime :: UTCTime+dueTimerTime = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0)++timerStatusAndErrorStmt :: Statement UUID (Maybe (Text, Maybe Text))+timerStatusAndErrorStmt =+    preparable+        """+        SELECT status, last_error+        FROM keiro.keiro_timers+        WHERE timer_id = $1+        """+        (E.param (E.nonNullable E.uuid))+        (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nullable D.text)))++-- | Read a timer's status and JSON payload by id (for the workflow-sleep tests).+sleepTimerStatusStmt :: Statement UUID (Maybe (Text, Value))+sleepTimerStatusStmt =+    preparable+        """+        SELECT status, payload+        FROM keiro.keiro_timers+        WHERE timer_id = $1+        """+        (E.param (E.nonNullable E.uuid))+        (D.rowMaybe ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.jsonb)))++-- | Read a timer's fire time by id (for workflow-sleep re-arm tests).+sleepTimerFireAtStmt :: Statement UUID (Maybe UTCTime)+sleepTimerFireAtStmt =+    preparable+        """+        SELECT fire_at+        FROM keiro.keiro_timers+        WHERE timer_id = $1+        """+        (E.param (E.nonNullable E.uuid))+        (D.rowMaybe (D.column (D.nonNullable D.timestamptz)))++recordedFrom :: EventData -> RecordedEvent+recordedFrom event =+    RecordedEvent+        { eventId = EventId sampleUuid+        , eventType = event ^. #eventType+        , streamVersion = StreamVersion 1+        , globalPosition = GlobalPosition 1+        , originalStreamId = StreamId 1+        , originalVersion = StreamVersion 1+        , payload = event ^. #payload+        , metadata = event ^. #metadata+        , causationId = Nothing+        , correlationId = Nothing+        , createdAt = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)+        }++recordedFromEventId :: EventId -> CounterEvent -> RecordedEvent+recordedFromEventId eventId event =+    case encodeForAppend counterCodec event of+        Right encoded -> recordedFrom encoded & #eventId .~ eventId+        Left err -> error ("test fixture failed to encode counter event: " <> show err)++appendCounterEventWithId :: Store.KirokuStore -> StreamName -> EventId -> CounterEvent -> IO ()+appendCounterEventWithId storeHandle streamName eventId event = do+    encoded <- shouldBeRight (encodeForAppend counterCodec event)+    outcome <-+        Store.runStoreIO storeHandle $+            Store.appendToStream streamName NoStream [encoded & #eventId ?~ eventId]+    case outcome of+        Right _ -> pure ()+        Left err -> expectationFailure ("failed to insert concurrent duplicate event: " <> show err)++appendCounterEvents :: Store.KirokuStore -> StreamName -> [CounterEvent] -> IO ()+appendCounterEvents storeHandle destinationStreamName events = do+    encoded <- traverse (shouldBeRight . encodeForAppend counterCodec) events+    outcome <-+        Store.runStoreIO storeHandle $+            Store.appendToStream destinationStreamName NoStream encoded+    case outcome of+        Right _ -> pure ()+        Left err -> expectationFailure ("failed to insert counter events: " <> show err)++-- Insert a real source event and drive Kiroku's acknowledgement bridge to park+-- it in kiroku.dead_letters. A second event lets the test observe that the+-- checkpoint advanced after the dead letter before stopping the subscription.+deadLetterCounterSource :: Store.KirokuStore -> SubscriptionName -> CounterEvent -> IO RecordedEvent+deadLetterCounterSource storeHandle subName sourceEvent = do+    appendCounterEvents+        storeHandle+        (StreamName "counter-replay-source")+        [sourceEvent, CounterAdded 0]+    let subConfig =+            ( KirokuSub.defaultSubscriptionConfig+                subName+                AllStreams+                (\_ -> pure KirokuSub.Continue)+            )+                { KirokuSub.retryPolicy = KirokuSub.RetryPolicy 1+                }+        pull label source = do+            result <- timeout 5_000_000 (Streamly.uncons source)+            case result of+                Just (Just itemAndRest) -> pure itemAndRest+                Just Nothing -> fail (label <> ": subscription ended early")+                Nothing -> fail (label <> ": timed out waiting for delivery")+    (stream0, cancelStream) <- subscriptionAckStream storeHandle subConfig 4+    ( do+            (first, stream1) <- pull "source delivery" stream0+            atomically $+                putTMVar+                    (ackReply first)+                    (KirokuSub.Retry (KirokuSub.RetryDelay 0))+            (next, stream2) <- pull "event after source dead letter" stream1+            ackEvent next ^. #eventId `shouldNotBe` ackEvent first ^. #eventId+            atomically (putTMVar (ackReply next) KirokuSub.Stop)+            ended <- timeout 5_000_000 (Streamly.uncons stream2)+            case ended of+                Just Nothing -> pure ()+                Just (Just _) -> expectationFailure "replay fixture delivered after Stop"+                Nothing -> expectationFailure "replay fixture did not stop"+            pure (ackEvent first)+        )+        `finally` cancelStream++classifyProcessManagerReplay :: ProcessManagerResult managerTarget commandTarget -> ReplayResult+classifyProcessManagerReplay result =+    case result ^. #managerResult of+        PMStateDuplicate{}+            | Prelude.all commandIsDuplicate (result ^. #commandResults) -> ReplayedDuplicate+        _ -> ReplayedFresh+  where+    commandIsDuplicate = \case+        PMCommandDuplicate{} -> True+        _ -> False++processManagerReplayCounts :: Store.KirokuStore -> IO (Int, Int)+processManagerReplayCounts storeHandle = do+    Right managerEvents <-+        Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "pm:counter-order-1") (StreamVersion 0) 10+    Right targetEvents <-+        Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "counter-target-order-1") (StreamVersion 0) 10+    pure (Vector.length managerEvents, Vector.length targetEvents)++sampleUuid :: UUID+sampleUuid =+    case fromString "018f0f18-17aa-7000-8000-000000000001" of+        Just uuid -> uuid+        Nothing -> error "invalid test UUID"++sampleUuid2 :: UUID+sampleUuid2 =+    case fromString "018f0f18-17aa-7000-8000-000000000002" of+        Just uuid -> uuid+        Nothing -> error "invalid test UUID"++sampleUuid3 :: UUID+sampleUuid3 =+    case fromString "018f0f18-17aa-7000-8000-000000000003" of+        Just uuid -> uuid+        Nothing -> error "invalid test UUID"++shouldBeRight :: (HasCallStack, Show e) => Either e a -> IO a+shouldBeRight = \case+    Right value -> pure value+    Left err -> expectationFailure ("expected Right, got Left " <> show err) *> error "unreachable"++shouldBeRight_ :: (HasCallStack, Show e) => Either e a -> Expectation+shouldBeRight_ = \case+    Right _ -> pure ()+    Left err -> expectationFailure ("expected Right, got Left " <> show err)++shouldBeLeft :: (HasCallStack, Eq e, Show e) => Either e a -> e -> Expectation+shouldBeLeft actual expected =+    case actual of+        Left err -> err `shouldBe` expected+        Right _ -> expectationFailure ("expected Left " <> show expected <> ", got Right")++fromStringLiteral :: String -> Text+fromStringLiteral = Text.pack++snapshotVersionForStreamStmt :: Statement Text (Maybe StreamVersion)+snapshotVersionForStreamStmt =+    preparable+        """+        SELECT ks.stream_version+        FROM keiro.keiro_snapshots ks+        JOIN streams s ON s.stream_id = ks.stream_id+        WHERE s.stream_name = $1+        """+        (E.param (E.nonNullable E.text))+        (D.rowMaybe (StreamVersion <$> D.column (D.nonNullable D.int8)))++corruptSnapshotStateStmt :: Statement (Text, Value) ()+corruptSnapshotStateStmt =+    preparable+        """+        UPDATE keiro.keiro_snapshots ks+        SET state = $2+        FROM streams s+        WHERE s.stream_id = ks.stream_id+          AND s.stream_name = $1+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.jsonb))+        )+        D.noResult++corruptSnapshotShapeStmt :: Statement (Text, Text) ()+corruptSnapshotShapeStmt =+    preparable+        """+        UPDATE keiro.keiro_snapshots ks+        SET regfile_shape_hash = $2+        FROM streams s+        WHERE s.stream_id = ks.stream_id+          AND s.stream_name = $1+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++counterReadModel :: ReadModel Text Int+counterReadModel =+    ReadModel+        { name = "counter-read-model"+        , tableName = "counter_read_model"+        , schema = "kiroku"+        , subscriptionName = "counter-read-model-sub"+        , version = 1+        , shapeHash = "counter-read-model-v1"+        , defaultConsistency = Eventual+        , strongScope = EntireLog+        , query = \modelId -> Tx.statement modelId selectCounterReadModelStmt+        }++counterCategoryReadModel :: ReadModel Text Int+counterCategoryReadModel =+    counterReadModel & #strongScope .~ CategoryHead "counter"++registerReadModelDefinition :: (Store :> es) => ReadModel q r -> Eff es ()+registerReadModelDefinition readModel =+    void $+        registerReadModel+            (readModel ^. #name)+            (readModel ^. #version)+            (readModel ^. #shapeHash)++initializeRegisteredReadModel ::+    (Store :> es) =>+    ReadModel q r ->+    Tx.Transaction () ->+    Eff es ()+initializeRegisteredReadModel readModel initializeTable = do+    Store.runTransaction initializeTable+    registerReadModelDefinition readModel++counterInlineProjection :: InlineProjection CounterEvent+counterInlineProjection =+    InlineProjection+        { name = "counter-inline-projection"+        , apply = \event recorded ->+            case event of+                CounterAdded amount ->+                    Tx.statement+                        ( "inline"+                        , Prelude.fromIntegral amount+                        , globalPositionToInt (recorded ^. #globalPosition)+                        , Just (eventIdToUuid (recorded ^. #eventId))+                        , metadataActor recorded+                        )+                        upsertCounterReadModelStmt+                CounterAudited{} -> pure ()+        }++counterAsyncProjection :: AsyncProjection+counterAsyncProjection =+    AsyncProjection+        { name = "counter-async-projection"+        , readModelName = "counter-read-model"+        , subscriptionName = "counter-read-model-sub"+        , applyRecorded = \recorded ->+            case decodeRecorded counterCodec recorded of+                Right (CounterAdded amount) ->+                    Tx.statement+                        ( "async-idempotent"+                        , Prelude.fromIntegral amount+                        , globalPositionToInt (recorded ^. #globalPosition)+                        , Just (eventIdToUuid (recorded ^. #eventId))+                        , Nothing+                        )+                        upsertCounterReadModelStmt+                Right CounterAudited{} -> pure ()+                Left _ -> pure ()+        , idempotencyKey = \recorded -> recorded ^. #eventId+        }++fastWaitOptions :: PositionWaitOptions+fastWaitOptions =+    PositionWaitOptions+        { target = Nothing+        , timeoutMicros = 50000+        , pollMicros = 5000+        }++initializeCounterReadModelTable :: Tx.Transaction ()+initializeCounterReadModelTable =+    Tx.sql+        """+        CREATE TABLE IF NOT EXISTS counter_read_model (+          model_id TEXT PRIMARY KEY,+          amount BIGINT NOT NULL,+          last_seen BIGINT NOT NULL,+          source_event_id UUID UNIQUE,+          actor TEXT+        )+        """++-- A read model whose data table lives in an application-configured schema+-- (@app_reads@), demonstrating EP-4's configurable projection schema. Its SQL is+-- fully qualified via 'placedTable'; Keiro's own metadata stays in @keiro@.+placedTable :: Text+placedTable = qualifyTable "app_reads" "placed_counter"++placedReadModel :: ReadModel Text Int+placedReadModel =+    ReadModel+        { name = "placed-counter-read-model"+        , tableName = "placed_counter"+        , schema = "app_reads"+        , subscriptionName = "placed-counter-sub"+        , version = 1+        , shapeHash = "placed-counter-v1"+        , defaultConsistency = Eventual+        , strongScope = EntireLog+        , query = \modelId -> Tx.statement modelId selectPlacedStmt+        }++placedInlineProjection :: InlineProjection CounterEvent+placedInlineProjection =+    InlineProjection+        { name = "placed-inline-projection"+        , apply = \event recorded ->+            case event of+                CounterAdded amount ->+                    Tx.statement+                        ( "placed"+                        , Prelude.fromIntegral amount+                        , globalPositionToInt (recorded ^. #globalPosition)+                        )+                        upsertPlacedStmt+                CounterAudited{} -> pure ()+        }++initializePlacedTable :: Tx.Transaction ()+initializePlacedTable =+    Tx.sql $+        TE.encodeUtf8 $+            "CREATE TABLE IF NOT EXISTS "+                <> placedTable+                <> " (\n"+                <> "  model_id TEXT PRIMARY KEY,\n"+                <> "  amount BIGINT NOT NULL,\n"+                <> "  last_seen BIGINT NOT NULL\n"+                <> ")"++upsertPlacedStmt :: Statement (Text, Int64, Int64) ()+upsertPlacedStmt =+    preparable+        ( "INSERT INTO "+            <> placedTable+            <> " (model_id, amount, last_seen)\n"+            <> "VALUES ($1, $2, $3)\n"+            <> "ON CONFLICT (model_id) DO UPDATE\n"+            <> "  SET amount = EXCLUDED.amount, last_seen = EXCLUDED.last_seen"+        )+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.int8))+        )+        D.noResult++selectPlacedStmt :: Statement Text Int+selectPlacedStmt =+    preparable+        ("SELECT COALESCE((SELECT amount FROM " <> placedTable <> " WHERE model_id = $1), 0)")+        (E.param (E.nonNullable E.text))+        (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)))++-- Count matching base tables in a given schema; proves table placement.+pgTableCountStmt :: Statement (Text, Text) Int+pgTableCountStmt =+    preparable+        "SELECT count(*)::int FROM pg_tables WHERE schemaname = $1 AND tablename = $2"+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int4)))++initializeProjectionDedupCounterTable :: Tx.Transaction ()+initializeProjectionDedupCounterTable =+    Tx.sql+        """+        CREATE TABLE IF NOT EXISTS projection_dedup_counter (+          id BOOLEAN PRIMARY KEY DEFAULT TRUE,+          amount BIGINT NOT NULL+        );++        INSERT INTO projection_dedup_counter (id, amount)+        VALUES (TRUE, 0)+        ON CONFLICT (id) DO NOTHING;+        """++upsertCounterReadModelStmt :: Statement (Text, Int64, Int64, Maybe UUID, Maybe Text) ()+upsertCounterReadModelStmt =+    preparable+        """+        INSERT INTO counter_read_model (model_id, amount, last_seen, source_event_id, actor)+        VALUES ($1, $2, $3, $4, $5)+        ON CONFLICT (source_event_id) DO NOTHING+        """+        ( contrazip5+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int8))+            (E.param (E.nonNullable E.int8))+            (E.param (E.nullable E.uuid))+            (E.param (E.nullable E.text))+        )+        D.noResult++incrementProjectionDedupCounterStmt :: Statement () ()+incrementProjectionDedupCounterStmt =+    preparable+        """+        UPDATE projection_dedup_counter+        SET amount = amount + 1+        WHERE id = TRUE+        """+        E.noParams+        D.noResult++selectProjectionDedupCounterStmt :: Statement () Int+selectProjectionDedupCounterStmt =+    preparable+        """+        SELECT amount+        FROM projection_dedup_counter+        WHERE id = TRUE+        """+        E.noParams+        (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)))++projectionDedupCountStmt :: Statement Text Int64+projectionDedupCountStmt =+    preparable+        """+        SELECT count(*)+        FROM keiro.keiro_projection_dedup+        WHERE projection_name = $1+        """+        (E.param (E.nonNullable E.text))+        (D.singleRow (D.column (D.nonNullable D.int8)))++selectCounterMetaStmt :: Statement Text (Int64, Maybe Text, Maybe UUID)+selectCounterMetaStmt =+    preparable+        """+        SELECT amount, actor, source_event_id+        FROM counter_read_model+        WHERE model_id = $1+        """+        (E.param (E.nonNullable E.text))+        ( D.singleRow+            ( (,,)+                <$> D.column (D.nonNullable D.int8)+                <*> D.column (D.nullable D.text)+                <*> D.column (D.nullable D.uuid)+            )+        )++selectCounterReadModelStmt :: Statement Text Int+selectCounterReadModelStmt =+    preparable+        """+        SELECT COALESCE((SELECT amount FROM counter_read_model WHERE model_id = $1), 0)+        """+        (E.param (E.nonNullable E.text))+        (D.singleRow (Prelude.fromIntegral <$> D.column (D.nonNullable D.int8)))++upsertSubscriptionCursorStmt :: Statement (Text, Int64) ()+upsertSubscriptionCursorStmt =+    preparable+        """+        INSERT INTO subscriptions (subscription_name, stream_name, last_seen)+        VALUES ($1, '$all', $2)+        ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE+          SET last_seen = EXCLUDED.last_seen,+              updated_at = now()+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int8))+        )+        D.noResult++upsertSubscriptionCursorMemberStmt :: Statement (Text, Int32, Int64) ()+upsertSubscriptionCursorMemberStmt =+    preparable+        """+        INSERT INTO subscriptions (subscription_name, stream_name, consumer_group_member, consumer_group_size, last_seen)+        VALUES ($1, '$all', $2, 2, $3)+        ON CONFLICT (subscription_name, consumer_group_member) DO UPDATE+          SET last_seen = EXCLUDED.last_seen,+              updated_at = now()+        """+        ( contrazip3+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int4))+            (E.param (E.nonNullable E.int8))+        )+        D.noResult++updateReadModelVersionStmt :: Statement (Text, Int64) ()+updateReadModelVersionStmt =+    preparable+        """+        UPDATE keiro.keiro_read_models+        SET version = $2+        WHERE name = $1+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.int8))+        )+        D.noResult++updateReadModelStatusStmt :: Statement (Text, Text) ()+updateReadModelStatusStmt =+    preparable+        """+        UPDATE keiro.keiro_read_models+        SET status = $2+        WHERE name = $1+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++readModelXminStmt :: Statement Text Text+readModelXminStmt =+    preparable+        """+        SELECT xmin::text+        FROM keiro.keiro_read_models+        WHERE name = $1+        """+        (E.param (E.nonNullable E.text))+        (D.singleRow (D.column (D.nonNullable D.text)))++globalPositionToInt :: GlobalPosition -> Int64+globalPositionToInt (GlobalPosition value) = value++eventIdToUuid :: EventId -> UUID+eventIdToUuid (EventId value) = value++metadataActor :: RecordedEvent -> Maybe Text+metadataActor recorded = do+    Aeson.Object o <- recorded ^. #metadata+    Aeson.String s <- KeyMap.lookup "actor" o+    pure s++-- Router test fixtures: an effectful, data-dependent fan-out whose target set+-- is stored in a read-model table (router_targets) rather than computed purely.++newtype RouteGroup = RouteGroup Text+    deriving stock (Generic, Eq, Show)++{- | Maps a routing group to the list of target counter stream identifiers seeded+for it. The query is genuinely effectful: 'demoRouter' calls it via 'runQuery'.+-}+routerTargetsReadModel :: ReadModel Text [Text]+routerTargetsReadModel =+    ReadModel+        { name = "router-targets-read-model"+        , tableName = "router_targets"+        , schema = "kiroku"+        , subscriptionName = "router-targets-sub"+        , version = 1+        , shapeHash = "router-targets-v1"+        , defaultConsistency = Eventual+        , strongScope = EntireLog+        , query = \groupId -> Tx.statement groupId selectRouterTargetsStmt+        }++demoRouter ::+    (IOE :> es, Store :> es) =>+    Router+        RouteGroup+        (HsPred '[] CounterCommand)+        '[]+        CounterState+        CounterCommand+        CounterEvent+        es+demoRouter =+    Router+        { name = "demo-router"+        , key = \(RouteGroup g) -> g+        , resolve = \(RouteGroup g) -> do+            result <- runQuery Nothing routerTargetsReadModel g+            pure $ case result of+                Right targetIds ->+                    [ PMCommand{target = stream targetId, command = Add 1}+                    | targetId <- targetIds+                    ]+                Left _ -> []+        , targetEventStream = counterEventStream+        , targetProjections = const []+        }++unstableRouter ::+    (IOE :> es) =>+    IORef Int ->+    (Int -> [Text]) ->+    Router+        RouteGroup+        (HsPred '[] CounterCommand)+        '[]+        CounterState+        CounterCommand+        CounterEvent+        es+unstableRouter attemptsRef targetsFor =+    Router+        { name = "unstable-router"+        , key = \(RouteGroup g) -> g+        , resolve = \_ -> do+            attempt <- liftIO (atomicModifyIORef' attemptsRef (\n -> (n + 1, n)))+            pure+                [ PMCommand{target = stream targetId, command = Add 1}+                | targetId <- targetsFor attempt+                ]+        , targetEventStream = counterEventStream+        , targetProjections = const []+        }++isAppended :: PMCommandResult target -> Bool+isAppended = \case+    PMCommandAppended{} -> True+    _ -> False++isDuplicate :: PMCommandResult target -> Bool+isDuplicate = \case+    PMCommandDuplicate{} -> True+    _ -> False++initializeRouterTargetsTable :: Tx.Transaction ()+initializeRouterTargetsTable =+    Tx.sql+        """+        CREATE TABLE IF NOT EXISTS router_targets (+          group_id TEXT NOT NULL,+          target_id TEXT NOT NULL+        )+        """++insertRouterTargetStmt :: Statement (Text, Text) ()+insertRouterTargetStmt =+    preparable+        """+        INSERT INTO router_targets (group_id, target_id)+        VALUES ($1, $2)+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++selectRouterTargetsStmt :: Statement Text [Text]+selectRouterTargetsStmt =+    preparable+        """+        SELECT target_id+        FROM router_targets+        WHERE group_id = $1+        ORDER BY target_id+        """+        (E.param (E.nonNullable E.text))+        (D.rowList (D.column (D.nonNullable D.text)))++-- Router worker fixtures: an in-memory Shibuya adapter that records every+-- finalized AckDecision, plus a router whose dispatch always fails.++inMemoryAdapter ::+    (IOE :> es) =>+    IORef [AckDecision] ->+    [msg] ->+    Adapter es msg+inMemoryAdapter decisionsRef messages =+    Adapter+        { adapterName = "router-test-adapter"+        , source = Streamly.fromList (fmap ingest messages)+        , shutdown = pure ()+        }+  where+    ingest message =+        Ingested+            { envelope = routerTestEnvelope message+            , ack = AckHandle (\decision -> liftIO (modifyIORef' decisionsRef (<> [decision])))+            , lease = Nothing+            }++routerTestEnvelope :: msg -> Envelope msg+routerTestEnvelope message =+    Envelope+        { messageId = "router-test-message"+        , cursor = Nothing+        , partition = Nothing+        , enqueuedAt = Nothing+        , traceContext = Nothing+        , headers = Nothing+        , attempt = Nothing+        , attributes = mempty+        , payload = message+        }++{- | A target aggregate with no outgoing edges: every command is rejected+(CommandRejected), so a dispatch through it surfaces as PMCommandFailed,+driving the worker's AckHalt branch.+-}+rejectingEventStreamDef :: CounterEventStream+rejectingEventStreamDef =+    counterEventStreamDef & #transducer .~ rejectingTransducer++rejectingEventStream :: ValidatedCounterEventStream+rejectingEventStream = mkEventStreamOrThrow "rejecting-counter" rejectingEventStreamDef++{- | Accept every Add command except amount 9, which exercises a worker that+dead-letters one rejected dispatch and then successfully processes the next.+-}+rejectNineEventStream :: ValidatedCounterEventStream+rejectNineEventStream = mkEventStreamOrThrow "reject-nine-counter" rejectNineEventStreamDef++rejectNineEventStreamDef :: CounterEventStream+rejectNineEventStreamDef =+    counterEventStreamDef & #transducer .~ rejectNineTransducer++rejectNineTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+rejectNineTransducer =+    SymTransducer+        { edgesOut = \case+            Counting ->+                [ Edge+                    { guard =+                        PAnd+                            (matchInCtor addCtor)+                            (PNot (inpCtor addCtor #amount .== Keiki.lit 9))+                    , update = UKeep+                    , output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)]+                    , target = Counting+                    }+                ]+        , initial = Counting+        , initialRegs = RNil+        , isFinal = \_ -> False+        }++rejectingTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+rejectingTransducer =+    SymTransducer+        { edgesOut = \case+            Counting -> []+        , initial = Counting+        , initialRegs = RNil+        , isFinal = \_ -> False+        }++failingRouter ::+    Router+        RouteGroup+        (HsPred '[] CounterCommand)+        '[]+        CounterState+        CounterCommand+        CounterEvent+        es+failingRouter =+    Router+        { name = "failing-router"+        , key = \(RouteGroup g) -> g+        , resolve = \_ -> pure [PMCommand{target = stream "failing-target", command = Add 1}]+        , targetEventStream = rejectingEventStream+        , targetProjections = const []+        }++-- Flatten exported counter/gauge points to (instrument name, value).+flattenScalarPoints :: [ResourceMetricsExport] -> [(Text, NumberValue)]+flattenScalarPoints rmes =+    [ (name, val)+    | rme <- rmes+    , scope <- Vector.toList (resourceMetricsScopes rme)+    , export <- Vector.toList (scopeMetricsExports scope)+    , (name, val) <- pointsOf export+    ]+  where+    pointsOf (MetricExportSum n _ _ _ _ _ _ pts) =+        [(n, sumDataPointValue p) | p <- Vector.toList pts]+    pointsOf (MetricExportGauge n _ _ _ _ pts) =+        [(n, gaugeDataPointValue p) | p <- Vector.toList pts]+    pointsOf _ = []++-- Flatten exported histogram points to (instrument name, count, sum).+flattenHistogramPoints :: [ResourceMetricsExport] -> [(Text, Word64, Double)]+flattenHistogramPoints rmes =+    [ (n, histogramDataPointCount p, histogramDataPointSum p)+    | rme <- rmes+    , scope <- Vector.toList (resourceMetricsScopes rme)+    , export <- Vector.toList (scopeMetricsExports scope)+    , MetricExportHistogram n _ _ _ _ pts <- [export]+    , p <- Vector.toList pts+    ]++-- ===========================================================================+-- EP-51 sharded-subscription test helpers+-- ===========================================================================++-- A test sink the sharded handlers write to: one row per processed event,+-- idempotent on event_id (an at-least-once handler may redeliver during a+-- rebalance). worker_tag identifies which worker process handled it; stream_id+-- is the originating stream (the partition key kiroku hashes on).+createShardSinkSql :: ByteString+createShardSinkSql =+    "CREATE TABLE IF NOT EXISTS shard_sink \+    \(event_id uuid PRIMARY KEY, worker_tag int NOT NULL, stream_id bigint NOT NULL)"++-- Seed @nStreams@ category-@orders@ streams with @perStream@ events each+-- (upsert append, so it is safe to call twice in one test). Returns the total+-- number of events appended.+seedOrders :: Store.KirokuStore -> Int -> Int -> IO Int+seedOrders store nStreams perStream = do+    for_ [0 .. nStreams - 1] $ \i -> do+        let sname = StreamName ("orders-" <> Text.pack (show i))+            evs =+                [ EventData+                    { eventId = Nothing+                    , eventType = EventType "OrderPlaced"+                    , payload = object ["n" Aeson..= (j :: Int)]+                    , metadata = Nothing+                    , causationId = Nothing+                    , correlationId = Nothing+                    }+                | j <- [0 .. perStream - 1]+                ]+        Right _ <- Store.runStoreIO store $ Store.appendToStream sname AnyVersion evs+        pure ()+    pure (nStreams * perStream)++-- A handler for worker @tag@: idempotently record (event_id, tag, stream_id).+sinkHandler :: Store.KirokuStore -> Int32 -> RecordedEvent -> IO ()+sinkHandler store tag ev =+    void $+        Store.runStoreIO store $+            Store.runTransaction $+                Tx.statement (eventUuid (ev ^. #eventId), tag, streamIdInt (ev ^. #originalStreamId)) insertShardSinkStmt+  where+    eventUuid (EventId u) = u+    streamIdInt (StreamId s) = s++insertShardSinkStmt :: Statement (UUID, Int32, Int64) ()+insertShardSinkStmt =+    preparable+        "INSERT INTO shard_sink (event_id, worker_tag, stream_id) VALUES ($1, $2, $3) ON CONFLICT (event_id) DO NOTHING"+        ( contrazip3+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.int4))+            (E.param (E.nonNullable E.int8))+        )+        D.noResult++shardSinkCount :: Store.KirokuStore -> IO Int+shardSinkCount store =+    either (const 0) id+        <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () countShardSinkStmt))++countShardSinkStmt :: Statement () Int+countShardSinkStmt =+    preparable+        "SELECT count(*) FROM shard_sink"+        E.noParams+        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++shardDeadLetterDetails :: Store.KirokuStore -> Text -> IO (Int, Maybe Text, Maybe Int)+shardDeadLetterDetails store subscription =+    either (const (0, Nothing, Nothing)) id+        <$> Store.runStoreIO store (Store.runTransaction (Tx.statement subscription shardDeadLetterDetailsStmt))++shardDeadLetterDetailsStmt :: Statement Text (Int, Maybe Text, Maybe Int)+shardDeadLetterDetailsStmt =+    preparable+        "SELECT count(*)::bigint, max(reason_summary), max(attempt_count) \+        \FROM kiroku.dead_letters \+        \WHERE subscription_name = $1 AND consumer_group_member = 0"+        (E.param (E.nonNullable E.text))+        ( D.singleRow $+            (,,)+                <$> (fromIntegral <$> D.column (D.nonNullable D.int8))+                <*> D.column (D.nullable D.text)+                <*> (fmap fromIntegral <$> D.column (D.nullable D.int4))+        )++-- The largest number of distinct workers that processed any single stream. 1+-- means perfectly disjoint ownership (no stream split across workers).+maxWorkersPerStream :: Store.KirokuStore -> IO Int+maxWorkersPerStream store =+    either (const 0) id+        <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () maxWorkersPerStreamStmt))++maxWorkersPerStreamStmt :: Statement () Int+maxWorkersPerStreamStmt =+    preparable+        "SELECT COALESCE(MAX(c), 0) FROM \+        \(SELECT count(DISTINCT worker_tag) AS c FROM shard_sink GROUP BY stream_id) s"+        E.noParams+        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++-- How many distinct workers processed at least one event (proves the work+-- spread across the pool rather than monopolised by one worker).+distinctWorkers :: Store.KirokuStore -> IO Int+distinctWorkers store =+    either (const 0) id+        <$> Store.runStoreIO store (Store.runTransaction (Tx.statement () distinctWorkersStmt))++distinctWorkersStmt :: Statement () Int+distinctWorkersStmt =+    preparable+        "SELECT count(DISTINCT worker_tag) FROM shard_sink"+        E.noParams+        (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))++-- Poll the sink count until it reaches @target@ or the timeout elapses.+waitUntilSinkCount :: Store.KirokuStore -> Int -> Int -> IO Bool+waitUntilSinkCount store target timeoutMicros = go (max 1 (timeoutMicros `div` step))+  where+    step = 100_000+    go :: Int -> IO Bool+    go 0 = (>= target) <$> shardSinkCount store+    go n = do+        c <- shardSinkCount store+        if c >= target+            then pure True+            else threadDelay step >> go (n - 1)++-- Poll until at least @target@ shard rows have a live owner. Tests use this to+-- join a second worker at a precise point in the one-bucket-per-pass ramp-up.+waitUntilOwnedShardCount :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool+waitUntilOwnedShardCount store sub target timeoutMicros = go (max 1 (timeoutMicros `div` step))+  where+    step = 50_000+    go 0 = hasTarget+    go n = do+        reached <- hasTarget+        if reached then pure True else threadDelay step >> go (n - 1)+    hasTarget = do+        rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub))+        pure (length [() | (_, Just _, _) <- rows] >= target)++-- Poll the lease table until cooperative ownership has converged: every bucket+-- owned, at least @minWorkers@ distinct owners, and no owner holding more than+-- its fair share. This is the "balanced on the empty category" gate the+-- failover test waits on before seeding, so the drain runs under stable+-- membership.+waitShardsBalanced :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> Int -> IO Bool+waitShardsBalanced store sub n minWorkers timeoutMicros = go (max 1 (timeoutMicros `div` step))+  where+    step = 200_000+    go :: Int -> IO Bool+    go 0 = isBalanced+    go k = do+        ok <- isBalanced+        if ok then pure True else threadDelay step >> go (k - 1)+    isBalanced :: IO Bool+    isBalanced = do+        rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub))+        let owners = [w | (_, Just w, _) <- rows]+            distinct = length (nubOrd owners)+            perOwner = [length g | g <- groupByOwner owners]+            fairShare = (n + max 1 distinct - 1) `div` max 1 distinct+        pure (length rows == n && length owners == n && distinct >= minWorkers && all (<= fairShare) perOwner)+    groupByOwner ws = [filter (== w) ws | w <- nubOrd ws]+    nubOrd = Set.toList . Set.fromList++waitShardsUnowned :: Store.KirokuStore -> SubscriptionName -> Int -> Int -> IO Bool+waitShardsUnowned store sub n timeoutMicros = go (max 1 (timeoutMicros `div` step))+  where+    step = 100_000+    go 0 = isUnowned+    go k = do+        ok <- isUnowned+        if ok then pure True else threadDelay step >> go (k - 1)+    isUnowned = do+        rows <- either (const []) id <$> Store.runStoreIO store (Store.runTransaction (listShardOwnership sub))+        pure (length rows == n && all (\(_, owner, _) -> isNothing owner) rows)++workflowOwnedRowCounts :: (Store :> es) => Text -> Text -> Eff es (Int64, Int64, Int64, Int64, Int64, Int64)+workflowOwnedRowCounts name wid =+    Store.runTransaction (Tx.statement (wid, name) workflowOwnedRowCountsStmt)++workflowOwnedChildCount :: (Store :> es) => Text -> Text -> Eff es Int64+workflowOwnedChildCount name wid =+    Store.runTransaction (Tx.statement (wid, name, wid, name) workflowOwnedChildCountStmt)++workflowWakeAfter :: (Store :> es) => WorkflowName -> WorkflowId -> Eff es (Maybe UTCTime)+workflowWakeAfter (WorkflowName name) (WorkflowId wid) =+    Store.runTransaction (Tx.statement (wid, name) workflowWakeAfterStmt)++insertGcTimerStmt :: Statement (UUID, Text, Text, UTCTime, Value, Text) ()+insertGcTimerStmt =+    preparable+        """+        INSERT INTO keiro.keiro_timers+          (timer_id, process_manager_name, correlation_id, fire_at, payload, status)+        VALUES ($1, $2, $3, $4, $5, $6)+        """+        ( contrazip6+            (E.param (E.nonNullable E.uuid))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.timestamptz))+            (E.param (E.nonNullable E.jsonb))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++deleteGcStepsStmt :: Statement (Text, Text) ()+deleteGcStepsStmt =+    preparable+        """+        DELETE FROM keiro.keiro_workflow_steps+        WHERE workflow_id = $1 AND workflow_name = $2+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++deleteWorkflowInstanceStmt :: Statement (Text, Text) ()+deleteWorkflowInstanceStmt =+    preparable+        """+        DELETE FROM keiro.keiro_workflows+        WHERE workflow_id = $1 AND workflow_name = $2+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        D.noResult++workflowWakeAfterStmt :: Statement (Text, Text) (Maybe UTCTime)+workflowWakeAfterStmt =+    preparable+        """+        SELECT wake_after+        FROM keiro.keiro_workflows+        WHERE workflow_id = $1 AND workflow_name = $2+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        (maybe Nothing id <$> D.rowMaybe (D.column (D.nullable D.timestamptz)))++workflowOwnedRowCountsStmt :: Statement (Text, Text) (Int64, Int64, Int64, Int64, Int64, Int64)+workflowOwnedRowCountsStmt =+    preparable+        """+        SELECT+          (SELECT count(*) FROM keiro.keiro_workflows WHERE workflow_id = $1 AND workflow_name = $2),+          (SELECT count(*) FROM keiro.keiro_workflow_steps WHERE workflow_id = $1 AND workflow_name = $2),+          (SELECT count(*) FROM keiro.keiro_awakeables WHERE owner_workflow_id = $1 AND owner_workflow_name = $2),+          (SELECT count(*) FROM keiro.keiro_workflow_children+            WHERE (parent_id = $1 AND parent_name = $2) OR (child_id = $1 AND child_name = $2)),+          (SELECT count(*) FROM keiro.keiro_timers+            WHERE correlation_id = $1 AND process_manager_name = $2 AND payload->>'kind' = 'keiro.workflow.sleep'),+          (SELECT count(*)+             FROM keiro.keiro_snapshots s+             JOIN streams st ON st.stream_id = s.stream_id+            WHERE st.stream_name = 'wf:' || $2 || '-' || $1)+        """+        ( contrazip2+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        ( D.singleRow $+            (,,,,,)+                <$> D.column (D.nonNullable D.int8)+                <*> D.column (D.nonNullable D.int8)+                <*> D.column (D.nonNullable D.int8)+                <*> D.column (D.nonNullable D.int8)+                <*> D.column (D.nonNullable D.int8)+                <*> D.column (D.nonNullable D.int8)+        )++workflowOwnedChildCountStmt :: Statement (Text, Text, Text, Text) Int64+workflowOwnedChildCountStmt =+    preparable+        """+        SELECT count(*)+        FROM keiro.keiro_workflow_children+        WHERE (parent_id = $1 AND parent_name = $2)+           OR (child_id = $3 AND child_name = $4)+        """+        ( contrazip4+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+            (E.param (E.nonNullable E.text))+        )+        (D.singleRow (D.column (D.nonNullable D.int8)))