keiro 0.16.0.0 → 0.17.0.0

raw patch · 20 files changed

+19611/−15480 lines, 20 filesdep +directorydep +filepathdep ~keiro-coredep ~keiro-test-supportPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, filepath

Dependency ranges changed: keiro-core, keiro-test-support

API changes (from Hackage documentation)

Files

• CHANGELOG.md +72/−0
• bench/InboxDelegatedBench.hs +497/−0
• bench/Main.hs +9/−4
• bench/ProducerIdentityBench.hs +115/−0
• keiro.cabal +151/−118
• src/Keiro/Command.hs +33/−0
• src/Keiro/Inbox.hs +115/−0
• src/Keiro/Inbox/Delegated.hs +122/−0
• src/Keiro/Inbox/Types.hs +56/−2
• src/Keiro/Outbox.hs +64/−48
• src/Keiro/Outbox/Identity.hs +139/−0
• src/Keiro/Outbox/Schema.hs +68/−36
• src/Keiro/ProcessManager.hs +4/−2
• src/Keiro/ProcessManager/Reaction.hs +713/−0
• src/Keiro/ReadModel.hs +15/−13
• src/Keiro/Telemetry.hs +12/−0
• src/Keiro/Timer.hs +1/−0
• src/Keiro/Timer/Schema.hs +10/−3
• test/Main.hs +17045/−15254
• test/ReactionExample.hs +370/−0

@@ -6,6 +6,78 @@  ## [Unreleased] +## 0.17.0.0 — 2026-09-17++### Breaking Changes++- `Keiro.Outbox.enqueueProducerEventTx` now takes the source `RecordedEvent` and+  a `Word32` emission index instead of a caller-supplied `OutboxId`, and is a pure+  `Tx.Transaction ProducerEnqueueOutcome` rather than an `Eff` action producing a+  transaction. It derives a deterministic UUIDv8 `OutboxId` and an opaque+  `<namespace>_v1_<sha256-hex>` message ID from producer source/name and the+  source-event coordinates, and returns `ProducerInserted`,+  `ProducerDuplicateIdentical`, or `ProducerIdentityConflict` with the differing+  field classes (never payload values). Missing `sourceEventId` /+  `sourceGlobalPosition` default from the recorded event, and `occurredAt` is+  normalized to microseconds. Replays leave retained publication/audit state+  untouched. Canonical producer message IDs are no longer TypeIDs; historical+  random IDs need a drained checkpoint cutover or an application-owned mapping+  before old events are replayed (see ADR-42 and `docs/user/outbox.md`). No schema+  migration is required.+- `mkIntegrationProducer` now rejects an empty `messageIdPrefix`.+- `KeiroMetrics` gains an `outboxIdentityConflict` field; code that constructs+  the record directly rather than through `newKeiroMetrics` must supply it.++### New Features++- Add no-Store delegated inbox single, retry, and sequential batch wrappers for+  consumers whose downstream operation owns a durable idempotence receipt.+- Add frozen `delegatedEventId`, safe aggregate-command dispatch, and typed+  process-manager result adaptation. Command failures, no-event successes, and+  unconfirmed event-ID collisions are never acknowledged as duplicates.+- Add `Keiro.ProcessManager.Reaction`, an additive typed process-manager API+  with explicit no-advance and accepted-only follow-ups, atomic saga/timer+  mutation, target-keyed dispatch identity, exact accepted-witness recovery,+  detailed one-shot results, and strict worker integration.+- Add `Keiro.Timer.cancelTimerTx`, the transaction-level form of guarded timer+  cancellation, so callers can compose cancellation with an event append and+  other timer mutations.+- Add `Keiro.Outbox.Identity` (`ProducerEventKey`, `ProducerIdentity`,+  `ProducerEnqueueOutcome`, `ConflictField`, `deriveIdentity`,+  `producerIdentityBytes`, `producerContentDigest`, `differingContentFields`,+  `normalizeProducerEvent`), re-exported from `Keiro.Outbox` together with+  `deriveProducerIdentity`, `recordProducerEnqueueOutcome`, and+  `freshIntegrationEvent`. `Keiro.Outbox.Schema` adds `enqueueProducerOutboxTx`.+- Add the `keiro.outbox.identity.conflict` counter+  (`keiroOutboxIdentityConflictName`, `recordOutboxIdentityConflict`), recorded+  once after the transaction runner returns.++### Other Changes++- Reactions with no schedule or cancel follow-ups skip the empty timer+  transaction while preserving dispatch behavior and zero timer effects.+- Read-model compatibility deprecations now name retirement of the frozen+  Language 4 generator as their removal boundary instead of an expired version.+- Add matched table/delegated inbox benchmarks for fresh, repeated, duplicate,+  chunked, metrics, and long-history receipt-probe workloads.+- Deprecate `mintIntegrationEvent` in favor of `freshIntegrationEvent`, which+  names its fresh-envelope behavior explicitly; use `enqueueProducerEventTx` for+  replay-safe producer identity. Caller-owned `enqueueOutboxTx` is unchanged.+- The `ProcessManagerAction` documentation now states the real atomicity+  boundary: manager-state append and timer writes share one transaction, while+  each target command commits in its own.+- Add a producer identity benchmark with retained baseline results.++- Existing process-manager APIs and positional deterministic identities remain+  unchanged. Switching an existing manager name to the reaction runner is an+  identity migration: drain source redelivery, partial fan-out, pending timers,+  and permitted historical replay first. The reaction family has no automatic+  legacy or router identity fallback.+- Outbox reads now preserve non-canonical stored `content_type` text. A retained+  row containing, for example, `application/json; charset=utf-8` publishes that+  exact `content-type` header instead of normalizing it to `application/json`;+  inbox decoding continues to normalize either representation.+ ## 0.16.0.0 — 2026-09-07  ### Breaking Changes

@@ -0,0 +1,497 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE OverloadedRecordDot #-}++module InboxDelegatedBench+  ( prepareInboxDelegatedBenchmarks,+    runInboxDelegatedExplainIfRequested,+  )+where++import Control.DeepSeq (NFData (..))+import Data.Aeson qualified as Aeson+import Data.Bifunctor (first)+import Data.ByteString qualified as ByteString+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text qualified as Text+import Data.Text.IO qualified as Text.IO+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 Hasql.Decoders qualified as Decoders+import Hasql.Encoders qualified as Encoders+import Hasql.Statement (preparable)+import Hasql.Statement qualified+import Keiro.Command (CommandError (..), CommandResult (..), defaultRunCommandOptions)+import Keiro.Inbox+  ( DelegatedOutcome,+    InboxDedupePolicy (PreferIntegrationMessageId),+    InboxResult (..),+    KafkaDeliveryRef (..),+    runInboxDelegated,+    runInboxDelegatedBatch,+    runInboxTransactionBatch,+    runInboxTransactionWith,+  )+import Keiro.Inbox.Delegated (delegatedCommand, delegatedEventId)+import Keiro.Inbox.Types (InboxPersistence (PersistFullEnvelope))+import Keiro.Integration.Event (IntegrationContentType (ApplicationJson), IntegrationEvent (..))+import Keiro.Prelude+import Keiro.Stream (Stream, stream)+import Keiro.Telemetry (KeiroMetrics)+import Kiroku.Store qualified as Store+import Kiroku.Store.Effect (PreparedEvent, Store)+import Kiroku.Store.SQL qualified as StoreSQL+import Kiroku.Store.Transaction qualified as StoreTransaction+import Kiroku.Store.Types+  ( AppendResult,+    EventData (..),+    EventId (..),+    EventType (..),+    ExpectedVersion (NoStream),+    StreamName (..),+  )+import System.Directory (createDirectoryIfMissing)+import System.Environment (lookupEnv)+import System.FilePath (takeDirectory)+import Test.Tasty.Bench (Benchmark, bench, bgroup, env, nfIO)+import "hasql-transaction" Hasql.Transaction qualified as Tx+import Prelude++deliveryCount :: Int+deliveryCount = 2000++payloadSize :: Int+payloadSize = 1024++fixedOccurredAt :: UTCTime+fixedOccurredAt = UTCTime (ModifiedJulianDay 61000) (secondsToDiffTime 0)++data IntakeMode = TableMode | DelegatedMode | DirectDelegatedMode+  deriving stock (Eq, Show)++data Traffic = FreshTraffic | RepeatedTraffic | DuplicateTraffic+  deriving stock (Eq, Show)++data Scenario = Scenario+  { name :: !Text,+    mode :: !IntakeMode,+    chunkSize :: !Int,+    traffic :: !Traffic,+    metrics :: !(Maybe KeiroMetrics),+    runNumber :: !(IORef Int),+    duplicateRun :: !(Maybe DownstreamRun)+  }++data DownstreamReceipt++data DownstreamWork = DownstreamWork+  { event :: !IntegrationEvent,+    kafka :: !KafkaDeliveryRef,+    targetName :: !StreamName,+    target :: !(Stream DownstreamReceipt),+    marker :: !EventId,+    eventData :: !EventData,+    prepared :: ![PreparedEvent]+  }++data DownstreamRun = DownstreamRun+  { deliveries :: ![(IntegrationEvent, Maybe KafkaDeliveryRef)],+    workByMessageId :: !(Map Text DownstreamWork)+  }++instance NFData DownstreamRun where+  rnf downstreamRun =+    length downstreamRun.deliveries `seq`+      Map.size downstreamRun.workByMessageId `seq`+        ()++prepareInboxDelegatedBenchmarks :: Store.KirokuStore -> KeiroMetrics -> IO [Benchmark]+prepareInboxDelegatedBenchmarks store metrics = do+  runStoreChecked store $ Store.runTransaction (Tx.sql businessTableSql)+  scenarios <- concat <$> traverse (prepareScenario store metrics) scenarioInputs+  traverse_ (runScenario store) [scenario | scenario <- scenarios, scenario.traffic == FreshTraffic]+  pure+    ( [ bgroup+          (Text.unpack scenario.name)+          [ bgroup+              (trafficName scenario.traffic)+              [bench (metricsName scenario.metrics) (nfIO (runScenario store scenario))]+          ]+      | scenario <- scenarios+      ]+        <> [bgroup "delegated-history-duplicate" (historyBenchmark store <$> [10, 1000, 100000])]+    )++runInboxDelegatedExplainIfRequested :: Store.KirokuStore -> IO ()+runInboxDelegatedExplainIfRequested store =+  lookupEnv "KEIRO_INBOX_DELEGATED_EXPLAIN" >>= \case+    Nothing -> pure ()+    Just outputPath -> do+      downstreamRun <- prepareHistoryRun store 100000+      work <- case Map.elems downstreamRun.workByMessageId of+        [] -> fail "explain benchmark run has no work"+        item : _ -> pure item+      let EventId markerUuid = work.marker+          StreamName targetText = work.targetName+          sql =+            "EXPLAIN (ANALYZE, BUFFERS) SELECT EXISTS (SELECT 1 FROM stream_events se WHERE se.event_id = '"+              <> UUID.toText markerUuid+              <> "'::uuid AND se.stream_id = (SELECT stream_id FROM streams WHERE stream_name = '"+              <> targetText+              <> "' AND deleted_at IS NULL))"+          statement =+            preparable+              sql+              Encoders.noParams+              (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text)))+      planLines <- runStoreChecked store (Store.runTransaction (Tx.statement () statement))+      settings <-+        runStoreChecked store $+          Store.runTransaction $+            traverse+              ( \settingName -> do+                  value <- Tx.statement () (settingStatement settingName)+                  pure (settingName <> " = " <> value)+              )+              ["server_version", "fsync", "synchronous_commit", "full_page_writes"]+      createDirectoryIfMissing True (takeDirectory outputPath)+      Text.IO.writeFile outputPath (Text.unlines (settings <> [""] <> planLines))++settingStatement :: Text -> Hasql.Statement.Statement () Text+settingStatement settingName =+  preparable+    ("SHOW " <> settingName)+    Encoders.noParams+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.text)))++scenarioInputs :: [(Text, IntakeMode, Int)]+scenarioInputs =+  [ ("table-downstream-single", TableMode, 1),+    ("delegated-single", DelegatedMode, 1),+    ("delegated-direct-single", DirectDelegatedMode, 1),+    ("table-downstream-batch-100", TableMode, 100),+    ("delegated-batch-100", DelegatedMode, 100),+    ("table-downstream-batch-1000", TableMode, 1000),+    ("delegated-batch-1000", DelegatedMode, 1000)+  ]++prepareScenario :: Store.KirokuStore -> KeiroMetrics -> (Text, IntakeMode, Int) -> IO [Scenario]+prepareScenario store metrics (name, mode, chunkSize) =+  traverse make [(traffic, mMetrics) | traffic <- [FreshTraffic, RepeatedTraffic, DuplicateTraffic], mMetrics <- [Nothing, Just metrics]]+  where+    make (traffic, mMetrics) = do+      runNumber <- newIORef 0+      duplicateRun <-+        case traffic of+          DuplicateTraffic -> do+            prepared <- prepareDownstreamRun (scenarioPrefix name traffic mMetrics <> "-seed") RepeatedTraffic+            seedDuplicateRun store mode prepared+            pure (Just prepared)+          _ -> pure Nothing+      pure Scenario {name, mode, chunkSize, traffic, metrics = mMetrics, runNumber, duplicateRun}++runScenario :: Store.KirokuStore -> Scenario -> IO ()+runScenario store scenario = do+  downstreamRun <- case scenario.duplicateRun of+    Just prepared -> pure prepared+    Nothing -> do+      invocation <- atomicModifyIORef' scenario.runNumber (\current -> let next = current + 1 in (next, next))+      prepareDownstreamRun (scenarioPrefix scenario.name scenario.traffic scenario.metrics <> "-" <> Text.pack (show invocation)) scenario.traffic+  runStoreChecked store (runDownstream scenario downstreamRun)++runDownstream :: (IOE :> es, Store :> es) => Scenario -> DownstreamRun -> Eff es ()+runDownstream scenario downstreamRun =+  case scenario.mode of+    TableMode ->+      if scenario.chunkSize == 1+        then traverse_ (runTableSingle scenario.metrics downstreamRun.workByMessageId) downstreamRun.deliveries+        else traverse_ (runTableBatch scenario.metrics downstreamRun.workByMessageId) (chunksOf scenario.chunkSize downstreamRun.deliveries)+    DelegatedMode ->+      if scenario.chunkSize == 1+        then traverse_ (runDelegatedSingle scenario.metrics downstreamRun.workByMessageId) downstreamRun.deliveries+        else traverse_ (runDelegatedBatch scenario.metrics downstreamRun.workByMessageId) (chunksOf scenario.chunkSize downstreamRun.deliveries)+    DirectDelegatedMode ->+      traverse_ (runDelegatedDirect downstreamRun.workByMessageId) downstreamRun.deliveries++runDelegatedDirect ::+  (IOE :> es, Store :> es) =>+  Map Text DownstreamWork ->+  (IntegrationEvent, Maybe KafkaDeliveryRef) ->+  Eff es ()+runDelegatedDirect workById (event, _) =+  void (delegatedDownstream (lookupWorkPure workById event))++runTableSingle ::+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  Map Text DownstreamWork ->+  (IntegrationEvent, Maybe KafkaDeliveryRef) ->+  Eff es ()+runTableSingle mMetrics workById (event, kafka) = do+  work <- lookupWork workById event+  outcome <-+    runInboxTransactionWith+      mMetrics+      PersistFullEnvelope+      PreferIntegrationMessageId+      event+      kafka+      (\_ -> tableDownstream work)+  expectInboxResult outcome++runTableBatch ::+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  Map Text DownstreamWork ->+  [(IntegrationEvent, Maybe KafkaDeliveryRef)] ->+  Eff es ()+runTableBatch mMetrics workById deliveries = do+  outcomes <-+    runInboxTransactionBatch+      mMetrics+      3+      PreferIntegrationMessageId+      PersistFullEnvelope+      deliveries+      (\event -> tableDownstream (lookupWorkPure workById event))+  traverse_ expectInboxResult outcomes++runDelegatedSingle ::+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  Map Text DownstreamWork ->+  (IntegrationEvent, Maybe KafkaDeliveryRef) ->+  Eff es ()+runDelegatedSingle mMetrics workById (event, kafka) = do+  outcome <-+    runInboxDelegated+      mMetrics+      PreferIntegrationMessageId+      event+      kafka+      (\_ delivered -> delegatedDownstream (lookupWorkPure workById delivered))+  expectInboxResult outcome++runDelegatedBatch ::+  (IOE :> es, Store :> es) =>+  Maybe KeiroMetrics ->+  Map Text DownstreamWork ->+  [(IntegrationEvent, Maybe KafkaDeliveryRef)] ->+  Eff es ()+runDelegatedBatch mMetrics workById deliveries = do+  outcomes <-+    runInboxDelegatedBatch+      mMetrics+      PreferIntegrationMessageId+      deliveries+      (\_ delivered -> delegatedDownstream (lookupWorkPure workById delivered))+  traverse_ expectInboxResult outcomes++tableDownstream :: DownstreamWork -> Tx.Transaction Bool+tableDownstream work = do+  let EventId markerUuid = work.marker+      StreamName targetText = work.targetName+  duplicate <- Tx.statement (targetText, markerUuid) StoreSQL.eventExistsInStreamStmt+  if duplicate+    then pure False+    else do+      StoreTransaction.appendToStreamTx work.targetName NoStream work.prepared fixedOccurredAt >>= \case+        Left _ -> Tx.condemn >> pure False+        Right _ -> Tx.sql businessEffectSql >> pure True++delegatedDownstream ::+  (IOE :> es, Store :> es) =>+  DownstreamWork ->+  Eff es (DelegatedOutcome (CommandResult DownstreamReceipt))+delegatedDownstream work = do+  outcome <-+    delegatedCommand+      defaultRunCommandOptions+      work.targetName+      work.marker+      (\_ -> first StoreFailed <$> appendDownstream work)+  case outcome of+    Left err -> liftIO (fail ("unexpected delegated benchmark command result: " <> show err))+    Right result -> pure result++appendDownstream ::+  (IOE :> es, Store :> es) =>+  DownstreamWork ->+  Eff es (Either Store.StoreError (CommandResult DownstreamReceipt))+appendDownstream work =+  StoreTransaction.runTransactionAppending work.targetName NoStream [work.eventData] $ \appendResult -> do+    Tx.sql businessEffectSql+    pure (commandResult work.target appendResult)++commandResult :: Stream DownstreamReceipt -> AppendResult -> CommandResult DownstreamReceipt+commandResult target appendResult =+  CommandResult+    { target,+      streamVersion = appendResult.streamVersion,+      globalPosition = Just appendResult.globalPosition,+      eventsAppended = 1+    }++expectInboxResult :: (IOE :> es) => Either err (InboxResult a) -> Eff es ()+expectInboxResult = \case+  Right (InboxProcessed _) -> pure ()+  Right InboxDuplicate -> pure ()+  Right _ -> liftIO (fail "unexpected inbox benchmark classification")+  Left _ -> liftIO (fail "unexpected inbox benchmark policy failure")++lookupWork :: (IOE :> es) => Map Text DownstreamWork -> IntegrationEvent -> Eff es DownstreamWork+lookupWork workById event =+  case Map.lookup event.messageId workById of+    Just work -> pure work+    Nothing -> liftIO (fail ("missing downstream benchmark work for " <> Text.unpack event.messageId))++lookupWorkPure :: Map Text DownstreamWork -> IntegrationEvent -> DownstreamWork+lookupWorkPure workById event =+  case Map.lookup event.messageId workById of+    Just work -> work+    Nothing -> error ("missing downstream benchmark work for " <> Text.unpack event.messageId)++prepareDownstreamRun :: Text -> Traffic -> IO DownstreamRun+prepareDownstreamRun prefix traffic = do+  uniqueWorks <- traverse (prepareWork prefix) uniqueIndexes+  let selected = case (traffic, uniqueWorks) of+        (FreshTraffic, _) -> uniqueWorks+        (RepeatedTraffic, work : _) -> Prelude.replicate deliveryCount work+        (DuplicateTraffic, work : _) -> Prelude.replicate deliveryCount work+        _ -> error "prepareDownstreamRun: traffic generated no work"+      deliveries = [(work.event, Just work.kafka) | work <- selected]+      workByMessageId = Map.fromList [(work.event.messageId, work) | work <- uniqueWorks]+  pure DownstreamRun {deliveries, workByMessageId}+  where+    uniqueIndexes = case traffic of+      FreshTraffic -> [1 .. deliveryCount]+      RepeatedTraffic -> [1]+      DuplicateTraffic -> [1]++prepareWork :: Text -> Int -> IO DownstreamWork+prepareWork prefix item = do+  let suffix = prefix <> "-" <> Text.pack (show item)+      messageId = "bench-delegated-" <> suffix+      event = integrationEvent messageId+      kafka = KafkaDeliveryRef "bench.inbox.delegated.v1" 0 (fromIntegral item)+      targetName = StreamName ("benchInbox-" <> suffix)+      target = stream ("benchInbox-" <> suffix)+      marker = delegatedEventId "keiro-bench" event.source messageId targetName "apply"+      eventData = receiptEvent marker+  prepared <- StoreTransaction.prepareEventsIO [eventData]+  pure DownstreamWork {event, kafka, targetName, target, marker, eventData, prepared}++seedDuplicateRun :: Store.KirokuStore -> IntakeMode -> DownstreamRun -> IO ()+seedDuplicateRun store mode downstreamRun =+  runStoreChecked store do+    case downstreamRun.deliveries of+      [] -> liftIO (fail "duplicate benchmark run has no delivery")+      delivery : _ ->+        case mode of+          TableMode -> runTableSingle Nothing downstreamRun.workByMessageId delivery+          DelegatedMode -> runDelegatedSingle Nothing downstreamRun.workByMessageId delivery+          DirectDelegatedMode -> runDelegatedDirect downstreamRun.workByMessageId delivery++historyBenchmark :: Store.KirokuStore -> Int -> Benchmark+historyBenchmark store historySize =+  env (prepareHistoryRun store historySize) $ \downstreamRun ->+    bench ("events-" <> show historySize) $+      nfIO $+        runStoreChecked store $+          traverse_ (runDelegatedSingle Nothing downstreamRun.workByMessageId) downstreamRun.deliveries++prepareHistoryRun :: Store.KirokuStore -> Int -> IO DownstreamRun+prepareHistoryRun store historySize = do+  downstreamRun <- prepareDownstreamRun ("history-" <> Text.pack (show historySize)) DuplicateTraffic+  seedDuplicateRun store DelegatedMode downstreamRun+  case Map.elems downstreamRun.workByMessageId of+    [] -> fail "history benchmark run has no work"+    work : _ ->+      runStoreChecked store $+        traverse_+          (\chunk -> void (Store.appendToStream work.targetName Store.AnyVersion chunk))+          (chunksOf 1000 (Prelude.replicate (max 0 (historySize - 1)) historyEvent))+  pure downstreamRun++historyEvent :: EventData+historyEvent =+  EventData+    { eventId = Nothing,+      eventType = EventType "BenchHistoricalEvent",+      payload = Aeson.toJSON (0 :: Int),+      metadata = Nothing,+      causationId = Nothing,+      correlationId = Nothing+    }++integrationEvent :: Text -> IntegrationEvent+integrationEvent messageId =+  IntegrationEvent+    { messageId,+      source = "bench.inbox.delegated",+      destination = "bench.inbox.delegated.v1",+      key = Just messageId,+      eventType = "BenchDelegatedIntake",+      schemaVersion = 1,+      contentType = ApplicationJson,+      schemaReference = Nothing,+      sourceEventId = Nothing,+      sourceGlobalPosition = Nothing,+      payloadBytes = ByteString.replicate payloadSize 65,+      occurredAt = fixedOccurredAt,+      causationId = Nothing,+      correlationId = Nothing,+      traceContext = Nothing,+      attributes = Nothing+    }++receiptEvent :: EventId -> EventData+receiptEvent marker =+  EventData+    { eventId = Just marker,+      eventType = EventType "BenchDelegatedApplied",+      payload = Aeson.toJSON ("applied" :: Text),+      metadata = Nothing,+      causationId = Nothing,+      correlationId = Nothing+    }++scenarioPrefix :: Text -> Traffic -> Maybe KeiroMetrics -> Text+scenarioPrefix name traffic mMetrics =+  Text.intercalate "-" [name, Text.pack (trafficName traffic), Text.pack (metricsName mMetrics)]++trafficName :: Traffic -> String+trafficName = \case+  FreshTraffic -> "fresh"+  RepeatedTraffic -> "repeated-key"+  DuplicateTraffic -> "all-duplicate"++metricsName :: Maybe KeiroMetrics -> String+metricsName = maybe "metrics-off" (const "metrics-on")++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++businessTableSql :: ByteString.ByteString+businessTableSql =+  "CREATE TABLE IF NOT EXISTS keiro.keiro_inbox_delegated_bench_effect (singleton bool PRIMARY KEY DEFAULT true, applied bigint NOT NULL DEFAULT 0); INSERT INTO keiro.keiro_inbox_delegated_bench_effect (singleton, applied) VALUES (true, 0) ON CONFLICT (singleton) DO NOTHING"++businessEffectSql :: ByteString.ByteString+businessEffectSql =+  "UPDATE keiro.keiro_inbox_delegated_bench_effect SET applied = applied + 1 WHERE singleton = true"++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

@@ -17,6 +17,7 @@ import Data.UUID qualified as UUID import Effectful (Eff, IOE, (:>)) import Effectful.Error.Static (Error)+import InboxDelegatedBench (prepareInboxDelegatedBenchmarks, runInboxDelegatedExplainIfRequested) import Keiki.Core   ( Edge (..),     HsPred,@@ -92,6 +93,7 @@ import OpenTelemetry.MeterProvider (createMeterProvider, defaultSdkMeterProviderOptions) import OpenTelemetry.Metric.Core (getMeter) import OpenTelemetry.Resource (emptyMaterializedResources)+import ProducerIdentityBench (producerIdentityBenchmarks) import ReadModelBench   ( readModelBenchmarks,     runReadModelExplainEvidenceIfRequested,@@ -158,10 +160,12 @@         readModelFixture <- setupReadModelBench readModelStore readModelRunner         runReadModelExplainEvidenceIfRequested readModelFixture         runReadModelLatencyEvidenceIfRequested readModelFixture-        defaultMain (benchmarks store runner metrics rebuildRunCounter <> readModelBenchmarks readModelFixture)+        delegatedInboxBenchmarks <- prepareInboxDelegatedBenchmarks store metrics+        runInboxDelegatedExplainIfRequested store+        defaultMain (benchmarks store runner metrics rebuildRunCounter delegatedInboxBenchmarks <> readModelBenchmarks readModelFixture <> producerIdentityBenchmarks store rebuildRunCounter) -benchmarks :: Store.KirokuStore -> StoreRunner -> Telemetry.KeiroMetrics -> IORef Int -> [Benchmark]-benchmarks store runner metrics rebuildRunCounter =+benchmarks :: Store.KirokuStore -> StoreRunner -> Telemetry.KeiroMetrics -> IORef Int -> [Benchmark] -> [Benchmark]+benchmarks store runner metrics rebuildRunCounter delegatedInboxBenchmarks =   [ bgroup       "outbox"       [ scenarioBench store hotKey,@@ -173,7 +177,8 @@       [ inboxScenarioBench store (singleFull metrics),         inboxScenarioBench store singleNoMetrics,         inboxScenarioBench store batch100,-        inboxScenarioBench store singleSlim+        inboxScenarioBench store singleSlim,+        bgroup "downstream" delegatedInboxBenchmarks       ],     bgroup       "command"

@@ -0,0 +1,115 @@+-- | Compare the pre-plan-164 fresh-ID path with deterministic producer writes.+module ProducerIdentityBench (producerIdentityBenchmarks) where++import Control.Monad (forM, forM_)+import Data.Aeson qualified as Aeson+import Data.ByteString qualified as BS+import Data.IORef (IORef, atomicModifyIORef')+import Data.Time (UTCTime (..), secondsToDiffTime)+import Data.Time.Calendar (Day (ModifiedJulianDay))+import Data.UUID qualified as UUID+import Keiro.Integration.Event+import Keiro.Outbox+import Keiro.Prelude+import Kiroku.Store qualified as Store+import Kiroku.Store.Types (EventId (..), EventType (..), GlobalPosition (..), RecordedEvent (..), StreamId (..), StreamVersion (..))+import Test.Tasty.Bench (Benchmark, bcompareWithin, bench, bgroup, nf, nfIO)+import "hasql-transaction" Hasql.Transaction qualified as Tx++producerIdentityBenchmarks :: Store.KirokuStore -> IORef Int -> [Benchmark]+producerIdentityBenchmarks store sequenceRef =+  [ bgroup+      "producer-identity"+      [ bench "derive-v1" $ nf identityText (ProducerEventKey (EventId (UUID.fromWords 0 0 0 1)) 0),+        bench "legacy-fresh-1000" $ nfIO (run True False False),+        bcompareWithin 0 1.10 "$0 == \"All.producer-identity.legacy-fresh-1000\"" $ bench "deterministic-fresh-1000" $ nfIO (run True True False),+        bench "deterministic-fresh-and-replay-1000" $ nfIO (run True True True),+        bench "legacy-single-tx-per-event-1000" $ nfIO (run False False False),+        bcompareWithin 0 1.10 "$0 == \"All.producer-identity.legacy-single-tx-per-event-1000\"" $ bench "deterministic-single-tx-per-event-1000" $ nfIO (run False True False)+      ]+  ]+  where+    run batch deterministic replay = do+      generation <- atomicModifyIORef' sequenceRef (\n -> (n + 1, n + 1))+      result <- Store.runStoreIO store $ do+        Store.runTransaction (Tx.sql "TRUNCATE keiro.keiro_outbox")+        let recorded = [sourceEvent generation i | i <- [1 .. 1000]]+        if deterministic+          then do+            let actions = fmap (\event -> enqueueProducerEventTx producer event 0 draft) recorded+            if batch+              then do+                first <- Store.runTransaction (sequence actions)+                unless (all isInserted first) (error "producer benchmark failed to insert")+              else forM_ actions $ \action -> do+                outcome <- Store.runTransaction action+                unless (isInserted outcome) (error "producer benchmark failed to insert")+            when replay $ do+              second <- Store.runTransaction (sequence actions)+              unless (all isDuplicate second) (error "producer benchmark failed to replay")+          else do+            -- Match the old helper's preparation boundary: bulk preparation+            -- for bulk SQL, and preparation immediately before each individual+            -- transaction for the normal subscription path.+            let prepare event = do+                  oid <- freshOutboxId+                  envelope <- freshIntegrationEvent producer (draft & #sourceEventId ?~ event ^. #eventId & #sourceGlobalPosition ?~ event ^. #globalPosition)+                  pure (oid, envelope)+            if batch+              then do+                messages <- forM recorded prepare+                Store.runTransaction (traverse_ (uncurry enqueueIntegrationEventTx) messages)+              else forM_ recorded $ \event -> do+                message <- prepare event+                Store.runTransaction (uncurry enqueueIntegrationEventTx message)+      case result of+        Left err -> fail (show err)+        Right () -> pure ()+    isInserted ProducerInserted {} = True+    isInserted _ = False+    isDuplicate ProducerDuplicateIdentical {} = True+    isDuplicate _ = False++producer :: IntegrationProducer ()+producer = IntegrationProducer "bench-producer" "bench.outbox" "msg" (\_ _ -> Just draft)++draft :: IntegrationEventDraft+draft =+  IntegrationEventDraft+    { destination = "bench.outbox.events.v1",+      key = Just "key",+      eventType = "BenchEvent",+      schemaVersion = 1,+      contentType = ApplicationJson,+      schemaReference = Nothing,+      sourceEventId = Nothing,+      sourceGlobalPosition = Nothing,+      payloadBytes = BS.replicate 1024 65,+      occurredAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0),+      causationId = Nothing,+      correlationId = Nothing,+      traceContext = Nothing,+      attributes = Nothing+    }++sourceEvent :: Int -> Int -> RecordedEvent+sourceEvent generation i =+  RecordedEvent+    { eventId = EventId (UUID.fromWords 0 (fromIntegral generation) 0 (fromIntegral i)),+      eventType = EventType "BenchEvent",+      streamVersion = StreamVersion (fromIntegral i),+      globalPosition = GlobalPosition (fromIntegral i),+      originalStreamId = StreamId 1,+      originalVersion = StreamVersion (fromIntegral i),+      payload = Aeson.Null,+      metadata = Nothing,+      causationId = Nothing,+      correlationId = Nothing,+      createdAt = UTCTime (ModifiedJulianDay 60000) (secondsToDiffTime 0)+    }++-- Force both identifiers, including the UUID projection, in the pure benchmark.+identityText :: ProducerEventKey -> (Text, Text)+identityText key =+  let identity = deriveProducerIdentity producer key+   in (UUID.toText (unOutboxId (identity ^. #outboxId)), identity ^. #messageId)

@@ -1,36 +1,48 @@-cabal-version:   3.0-name:            keiro-version:         0.16.0.0-synopsis:        Event sourcing framework and workflow engine+cabal-version: 3.0+name: keiro+version: 0.17.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-license-file:    LICENSE-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+license: BSD-3-Clause+license-file: LICENSE+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+  type: git   location: https://github.com/shinzui/keiro.git +flag reaction-hydration-probe+  description:+    Emit opt-in stderr markers for process-reaction saga hydration and witness recovery++  manual: True+  default: False+ common warnings   ghc-options:-    -Wall -Wcompat -Widentities -Wincomplete-record-updates-    -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wpartial-fields+    -Wredundant-constraints  common shared-  default-language:   GHC2024+  default-language: GHC2024   default-extensions:     DeriveAnyClass     DuplicateRecordFields@@ -41,8 +53,8 @@     PackageImports  library-  import:             warnings, shared-  autogen-modules:    Paths_keiro+  import: warnings, shared+  autogen-modules: Paths_keiro   exposed-modules:     Keiro     Keiro.Command@@ -52,14 +64,17 @@     Keiro.DeadLetter.Schema     Keiro.DeterministicId     Keiro.Inbox+    Keiro.Inbox.Delegated     Keiro.Inbox.Kafka     Keiro.Inbox.Schema     Keiro.Inbox.Types     Keiro.Outbox+    Keiro.Outbox.Identity     Keiro.Outbox.Kafka     Keiro.Outbox.Schema     Keiro.Outbox.Types     Keiro.ProcessManager+    Keiro.ProcessManager.Reaction     Keiro.Projection     Keiro.Projection.Catalog     Keiro.Projection.Catalog.Operations@@ -96,6 +111,8 @@     Keiro.Workflow.Snapshot     Keiro.Workflow.Types +  if flag(reaction-hydration-probe)+    cpp-options: -DKEIRO_REACTION_HYDRATION_PROBE   other-modules:     Keiro.Command.Domain     Keiro.Outbox.Rejection@@ -115,59 +132,59 @@   reexported-modules:     keiro-core:Keiro.Codec,     keiro-core:Keiro.Codec.IdDomain,+    keiro-core:Keiro.Codec.Nominal,     keiro-core:Keiro.Codec.Structural,     keiro-core:Keiro.Codec.Structural.Generic,-    keiro-core:Keiro.Codec.Nominal,     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+    keiro-core:Keiro.Stream, -  hs-source-dirs:     src+  hs-source-dirs: src   build-depends:-    , aeson                                  >=2.2.2     && <2.3-    , aeson-casing                           >=0.2       && <0.3-    , base                                   >=4.21      && <5-    , base16-bytestring                      >=1.0.2     && <1.1-    , bytestring                             >=0.11      && <0.13-    , containers                             >=0.6       && <0.8-    , contravariant-extras                   >=0.3       && <0.4-    , cryptohash-sha256                      >=0.11.102  && <0.12-    , deepseq                                >=1.5       && <1.6-    , effectful                              >=2.6       && <2.7-    , effectful-core                         >=2.6       && <2.7-    , generic-lens                           >=2.2       && <2.4-    , hasql                                  >=1.10      && <1.11-    , hasql-pool                             >=1.2       && <1.5-    , hasql-transaction                      >=1.1       && <1.3-    , hs-opentelemetry-api                   >=1.0       && <1.1-    , hs-opentelemetry-propagator-w3c        >=1.0       && <1.1-    , hs-opentelemetry-semantic-conventions  >=1.40      && <2-    , keiki                                  >=0.9       && <0.10-    , keiki-codec-json                       >=0.9       && <0.10-    , keiro-core                             ^>=0.16.0.0-    , kiroku-store                           >=0.8       && <0.9-    , lens                                   >=5.2       && <5.4-    , mmzk-typeid                            >=0.7       && <0.8-    , random                                 >=1.2.1     && <1.4-    , scientific                             >=0.3       && <0.4-    , shibuya-core                           ^>=0.9.0.0-    , stm                                    >=2.5       && <2.6-    , streamly                               >=0.11      && <0.12-    , streamly-core                          >=0.3       && <0.4-    , text                                   >=2.1       && <2.2-    , time                                   >=1.12      && <1.15-    , unliftio-core                          >=0.2       && <0.3-    , uuid                                   >=1.3       && <1.4-    , vector                                 >=0.13      && <0.14+    aeson >=2.2.2 && <2.3,+    aeson-casing >=0.2 && <0.3,+    base >=4.21 && <5,+    base16-bytestring >=1.0.2 && <1.1,+    bytestring >=0.11 && <0.13,+    containers >=0.6 && <0.8,+    contravariant-extras >=0.3 && <0.4,+    cryptohash-sha256 >=0.11.102 && <0.12,+    deepseq >=1.5 && <1.6,+    effectful >=2.6 && <2.7,+    effectful-core >=2.6 && <2.7,+    generic-lens >=2.2 && <2.4,+    hasql >=1.10 && <1.11,+    hasql-pool >=1.2 && <1.5,+    hasql-transaction >=1.1 && <1.3,+    hs-opentelemetry-api >=1.0 && <1.1,+    hs-opentelemetry-propagator-w3c >=1.0 && <1.1,+    hs-opentelemetry-semantic-conventions >=1.40 && <2,+    keiki >=0.9 && <0.10,+    keiki-codec-json >=0.9 && <0.10,+    keiro-core ^>=0.17.0.0,+    kiroku-store >=0.8 && <0.9,+    lens >=5.2 && <5.4,+    mmzk-typeid >=0.7 && <0.8,+    random >=1.2.1 && <1.4,+    scientific >=0.3 && <0.4,+    shibuya-core ^>=0.9.0.0,+    stm >=2.5 && <2.6,+    streamly >=0.11 && <0.12,+    streamly-core >=0.3 && <0.4,+    text >=2.1 && <2.2,+    time >=1.12 && <1.15,+    unliftio-core >=0.2 && <0.3,+    uuid >=1.3 && <1.4,+    vector >=0.13 && <0.14,  test-suite keiro-test-  import:          warnings, shared-  type:            exitcode-stdio-1.0-  hs-source-dirs:  test-  main-is:         Main.hs+  import: warnings, shared+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs   autogen-modules: Paths_keiro   other-modules:     CatalogEvolutionSpec@@ -180,68 +197,84 @@     PreCanonicalRecoverySpec     PreimageSpec     ProjectionReplaySpec+    ReactionExample     ReadModelSpec     VersionedRebuildSpec     VersionedTargetPostgresSpec -  ghc-options:     -threaded -rtsopts -with-rtsopts=-N+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N+   build-depends:-    , aeson                                  >=2.2       && <2.3-    , base                                   >=4.21      && <5-    , bytestring                             >=0.11      && <0.13-    , containers                             >=0.6       && <0.8-    , contravariant-extras                   >=0.3       && <0.4-    , effectful                              >=2.6       && <2.7-    , effectful-core                         >=2.6       && <2.7-    , hasql                                  >=1.10      && <1.11-    , hasql-pool                             >=1.2       && <1.5-    , hasql-transaction                      >=1.1       && <1.3-    , 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                     ^>=0.16.0.0-    , kiroku-store                           >=0.8       && <0.9-    , process                                >=1.6       && <1.7-    , shibuya-core                           ^>=0.9.0.0-    , stm                                    >=2.5       && <2.6-    , streamly-core                          >=0.3       && <0.4-    , text                                   >=2.1       && <2.2-    , time                                   >=1.12      && <1.15-    , unliftio-core                          >=0.2       && <0.3-    , uuid                                   >=1.3       && <1.4-    , vector                                 >=0.13      && <0.14+    aeson >=2.2 && <2.3,+    base >=4.21 && <5,+    bytestring >=0.11 && <0.13,+    containers >=0.6 && <0.8,+    contravariant-extras >=0.3 && <0.4,+    effectful >=2.6 && <2.7,+    effectful-core >=2.6 && <2.7,+    hasql >=1.10 && <1.11,+    hasql-pool >=1.2 && <1.5,+    hasql-transaction >=1.1 && <1.3,+    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 ^>=0.17.0.0,+    kiroku-store >=0.8 && <0.9,+    process >=1.6 && <1.7,+    shibuya-core ^>=0.9.0.0,+    stm >=2.5 && <2.6,+    streamly-core >=0.3 && <0.4,+    text >=2.1 && <2.2,+    time >=1.12 && <1.15,+    unliftio-core >=0.2 && <0.3,+    uuid >=1.3 && <1.4,+    vector >=0.13 && <0.14,  benchmark keiro-bench-  import:         warnings, shared-  type:           exitcode-stdio-1.0+  import: warnings, shared+  type: exitcode-stdio-1.0   hs-source-dirs: bench-  main-is:        Main.hs-  other-modules:  ReadModelBench-  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  main-is: Main.hs+  other-modules:+    InboxDelegatedBench+    ProducerIdentityBench+    ReadModelBench++  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N+   build-depends:-    , aeson                 >=2.2.2     && <2.3-    , base                  >=4.21      && <5-    , bytestring            >=0.11      && <0.13-    , containers            >=0.6       && <0.8-    , effectful             >=2.6       && <2.7-    , hasql                 >=1.10      && <1.11-    , hasql-transaction     >=1.1       && <1.3-    , hs-opentelemetry-api  >=1.0       && <1.1-    , hs-opentelemetry-sdk  >=1.0       && <1.1-    , keiki                 >=0.9       && <0.10-    , keiro-    , keiro-core            ^>=0.16.0.0-    , keiro-test-support    ^>=0.16.0.0-    , kiroku-store          >=0.8       && <0.9-    , shibuya-core          ^>=0.9.0.0-    , streamly-core         >=0.3       && <0.4-    , tasty-bench           >=0.4-    , text                  >=2.1       && <2.2-    , time                  >=1.12      && <1.15-    , uuid                  >=1.3       && <1.4+    aeson >=2.2.2 && <2.3,+    base >=4.21 && <5,+    bytestring >=0.11 && <0.13,+    containers >=0.6 && <0.8,+    deepseq >=1.5 && <1.6,+    directory >=1.3 && <1.4,+    effectful >=2.6 && <2.7,+    filepath >=1.4 && <1.6,+    hasql >=1.10 && <1.11,+    hasql-transaction >=1.1 && <1.3,+    hs-opentelemetry-api >=1.0 && <1.1,+    hs-opentelemetry-sdk >=1.0 && <1.1,+    keiki >=0.9 && <0.10,+    keiro,+    keiro-core ^>=0.17.0.0,+    keiro-test-support ^>=0.17.0.0,+    kiroku-store >=0.8 && <0.9,+    shibuya-core ^>=0.9.0.0,+    streamly-core >=0.3 && <0.4,+    tasty-bench >=0.4,+    text >=2.1 && <2.2,+    time >=1.12 && <1.15,+    uuid >=1.3 && <1.4,

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- | The command side of the framework: hydrate an aggregate, transduce, append. -- -- Running a command against an 'EventStream' follows one pipeline:@@ -89,6 +91,9 @@ import Control.Concurrent (threadDelay) import Control.Exception (displayException) import Data.Aeson qualified as Aeson+#ifdef KEIRO_REACTION_HYDRATION_PROBE+import Data.ByteString.Char8 qualified as ByteString.Char8+#endif import Data.ByteString.Lazy.Char8 qualified as LazyByteString import Data.Functor (($>)) import Data.Int (Int32)@@ -409,7 +414,35 @@   EventStream phi rs s ci co ->   Stream (EventStream phi rs s ci co) ->   Eff es (Either CommandError (Hydrated rs s))+#ifdef KEIRO_REACTION_HYDRATION_PROBE hydrate options eventStream targetStream =+  liftIO+    ( ByteString.Char8.hPutStrLn stderr+        ( LazyByteString.toStrict+            ( Aeson.encode+                ( Aeson.object+                    [ "marker" Aeson..= ("reaction-probe" :: Text),+                      "operation" Aeson..= ("hydrate" :: Text),+                      "stream" Aeson..= resolvedStreamName eventStream targetStream+                    ]+                )+            )+        )+    )+    >> hydrateAfterProbe options eventStream targetStream+#else+hydrate options eventStream targetStream =+  hydrateAfterProbe options eventStream targetStream+#endif++hydrateAfterProbe ::+  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))+hydrateAfterProbe options eventStream targetStream =   snapshotSeed >>= \case     Nothing -> hydrateFull options eventStream targetStream     Just seed -> do

@@ -40,12 +40,16 @@     runInboxTransactionWithRetriesWith,     runInboxTransactionWithRetriesKey,     runInboxTransactionBatch,+    runInboxDelegated,+    runInboxDelegatedWithRetries,+    runInboxDelegatedBatch,     sampleInboxBacklog,   ) where  import Data.Map.Strict qualified as Map import Data.Maybe (listToMaybe, mapMaybe)+import Data.Set qualified as Set import Data.Text qualified as Text import Effectful (Eff, IOE, (:>)) import Effectful.Exception (displayException, trySync)@@ -407,6 +411,117 @@            in if Map.member key seen                 then BatchDuplicate : go seen rest                 else BatchWork (event ^. #source) dedupe event kafka : go (Map.insert key () seen) rest++-- | Run an integration handler whose downstream operation owns the durable+-- deduplication receipt.+--+-- This wrapper computes the same policy key as the table-backed inbox, but it+-- performs no inbox reads or writes and requires no 'Store' effect. The handler+-- receives the computed key and must cover every protected effect with that+-- identity. A returned 'DelegatedOutcome' is the handler's assertion about the+-- downstream result; it is not independently verified by this wrapper.+--+-- Synchronous and asynchronous exceptions both propagate. Use+-- 'runInboxDelegatedWithRetries' when synchronous failures should be classified+-- for a caller-owned retry ladder.+runInboxDelegated ::+  forall a es.+  (IOE :> es) =>+  Maybe KeiroMetrics ->+  InboxDedupePolicy ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  (Text -> IntegrationEvent -> Eff es (DelegatedOutcome a)) ->+  Eff es (Either InboxError (InboxResult a))+runInboxDelegated mMetrics policy event kafka handler =+  case dedupeKeyFor policy event kafka of+    Left err -> pure (Left err)+    Right dedupe -> do+      result <- delegatedResult <$> handler dedupe event+      recordInboxResult mMetrics Nothing result+      pure (Right result)++-- | Run delegated intake with an explicit, caller-owned retry position.+--+-- At an attempt above the configured ceiling, the handler is not invoked and+-- the result is 'InboxPreviouslyFailed'. At or below the ceiling, synchronous+-- exceptions become 'InboxHandlerFailed' with the current attempt number;+-- asynchronous cancellation still propagates. Typed errors in the handler's+-- effect stack are not exceptions and must be handled by the caller.+runInboxDelegatedWithRetries ::+  forall a es.+  (IOE :> es) =>+  Maybe KeiroMetrics ->+  DelegatedRetryContext ->+  InboxDedupePolicy ->+  IntegrationEvent ->+  Maybe KafkaDeliveryRef ->+  (Text -> IntegrationEvent -> Eff es (DelegatedOutcome a)) ->+  Eff es (Either InboxError (InboxResult a))+runInboxDelegatedWithRetries mMetrics retryContext policy event kafka handler =+  case dedupeKeyFor policy event kafka of+    Left err -> pure (Left err)+    Right dedupe -> do+      let attemptLimit = delegatedRetryCeiling retryContext+          attempt = delegatedRetryAttempt retryContext+      result <-+        if attempt > attemptLimit+          then pure (InboxPreviouslyFailed Nothing)+          else do+            attempted <- trySync (handler dedupe event)+            pure $ case attempted of+              Right outcome -> delegatedResult outcome+              Left err -> InboxHandlerFailed (Text.pack (displayException err)) attempt+      recordInboxResult mMetrics (Just attemptLimit) result+      pure (Right result)++-- | Process a bounded chunk of delegated deliveries sequentially.+--+-- Successful identities are remembered only for this call, keyed by source and+-- dedupe key. A later occurrence of a successful identity is classified as a+-- duplicate without invoking the handler. Policy errors and synchronous+-- handler exceptions are returned per item and do not suppress a later retry of+-- the same identity. Async cancellation propagates immediately. This function+-- creates no threads or transactions and retains O(n) results and keys for an+-- input chunk of size n.+runInboxDelegatedBatch ::+  forall a es.+  (IOE :> es) =>+  Maybe KeiroMetrics ->+  InboxDedupePolicy ->+  [(IntegrationEvent, Maybe KafkaDeliveryRef)] ->+  (Text -> IntegrationEvent -> Eff es (DelegatedOutcome a)) ->+  Eff es [Either InboxError (InboxResult a)]+runInboxDelegatedBatch mMetrics policy deliveries handler =+  go Set.empty [] deliveries+  where+    go _ results [] = pure (reverse results)+    go seen results ((event, kafka) : rest) =+      case dedupeKeyFor policy event kafka of+        Left err -> go seen (Left err : results) rest+        Right dedupe -> do+          let identity = (event ^. #source, dedupe)+          if Set.member identity seen+            then do+              recordInboxResult mMetrics Nothing InboxDuplicate+              go seen (Right InboxDuplicate : results) rest+            else do+              attempted <- trySync (handler dedupe event)+              case attempted of+                Left err -> do+                  let result = InboxHandlerFailed (Text.pack (displayException err)) 1+                  recordInboxResult mMetrics Nothing result+                  go seen (Right result : results) rest+                Right outcome -> do+                  let result = delegatedResult outcome+                      seen' = Set.insert identity seen+                  recordInboxResult mMetrics Nothing result+                  seen' `seq` go seen' (Right result : results) rest++delegatedResult :: DelegatedOutcome a -> InboxResult a+delegatedResult = \case+  DelegatedFresh value -> InboxProcessed value+  DelegatedDuplicate -> InboxDuplicate  -- | Count the inbox backlog and record the gauge when metrics are enabled. --

@@ -0,0 +1,122 @@+-- | Safe adapters for handlers used with delegated-idempotence inbox intake.+--+-- The wrappers in "Keiro.Inbox" deliberately accept any effectful handler, so+-- they cannot prove that its complete operation is idempotent. This module+-- supplies narrower adapters for one aggregate command or one already-resolved+-- process-manager command result. Both require a durable event receipt and+-- refuse to acknowledge failures or successful commands that appended no event.+module Keiro.Inbox.Delegated+  ( delegatedEventId,+    DelegatedCommandError (..),+    delegatedCommand,+    delegatedFromPMCommand,+  )+where++import Data.ByteString qualified as ByteString+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Data.UUID.V5 qualified as UUID.V5+import Effectful (Eff, (:>))+import Keiro.Command (CommandError, CommandResult, RunCommandOptions)+import Keiro.DeterministicId (identitySeedBytes)+import Keiro.Inbox.Types (DelegatedOutcome (..))+import Keiro.Prelude+import Keiro.ProcessManager (PMCommandResult (..), dispatchDeduplicatedCommand)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Types (EventId (..), StreamName (..))++-- | Derive the permanent first-event receipt for one delegated command.+--+-- The identity contains a version tag followed by consumer, integration source,+-- inbox dedupe key, resolved target stream, and stable operation name. Every+-- field is prefixed with its UTF-8 byte length, making boundaries unambiguous+-- even for empty, Unicode, or delimiter-containing values. These inputs and the+-- version-1 recipe are replay identity and must remain stable for the full+-- redelivery horizon.+delegatedEventId :: Text -> Text -> Text -> StreamName -> Text -> EventId+delegatedEventId consumer source dedupe (StreamName target) operation =+  EventId+    ( UUID.V5.generateNamed+        UUID.V5.namespaceURL+        ( identitySeedBytes+            ( Text.concat+                ( encodeField+                    <$> [ "keiro/inbox-delegated/1",+                          consumer,+                          source,+                          dedupe,+                          target,+                          operation+                        ]+                )+            )+        )+    )+  where+    encodeField field =+      Text.pack (show (ByteString.length (Text.Encoding.encodeUtf8 field)))+        <> ":"+        <> field++-- | Why a command cannot serve as a delegated-idempotence receipt.+data DelegatedCommandError+  = -- | The command failed; the target name is retained for retry and diagnostics.+    DelegatedCommandFailed !StreamName !CommandError+  | -- | The command succeeded without appending an event, so it left no durable+    -- receipt for this intake identity.+    DelegatedCommandWithoutReceipt !StreamName+  deriving stock (Generic, Eq, Show)++-- | Protect one atomic command append with a deterministic first-event receipt.+--+-- The adapter probes @markerId@ in @targetStream@ before invoking the callback,+-- preventing hydration or dispatch on a confirmed replay. It replaces the+-- options' event-id list with the singleton marker, then passes those prepared+-- options to the callback. The callback must use the supplied options and target,+-- perform exactly one atomic append, and include all protected SQL, projection,+-- and outbox work in that append transaction.+--+-- A positive append is fresh; a preflight hit or a concurrently confirmed append+-- is duplicate. A zero-event success and every unconfirmed command error remain+-- typed failures. In particular, callers must inspect 'Left' and apply their+-- retry or dead-letter policy; wrapping this whole result in 'DelegatedFresh'+-- would acknowledge a failed operation.+delegatedCommand ::+  forall target es.+  (Store :> es) =>+  RunCommandOptions ->+  StreamName ->+  EventId ->+  (RunCommandOptions -> Eff es (Either CommandError (CommandResult target))) ->+  Eff es (Either DelegatedCommandError (DelegatedOutcome (CommandResult target)))+delegatedCommand baseOptions targetStream markerId dispatch =+  dispatchDeduplicatedCommand+    preparedOptions+    targetStream+    (markerId :| [])+    (const (Right DelegatedDuplicate))+    (Left . DelegatedCommandFailed targetStream)+    classifySuccess+    (dispatch preparedOptions)+  where+    preparedOptions = baseOptions & #eventIds .~ [markerId]+    classifySuccess result+      | result ^. #eventsAppended > 0 = Right (DelegatedFresh result)+      | otherwise = Left (DelegatedCommandWithoutReceipt targetStream)++-- | Adapt one process-manager command result after its deterministic dispatch.+--+-- This is valid only for a single dispatch whose command identity already+-- absorbs the intake identity. It does not prove that an arbitrary multi-command+-- process-manager reaction completed.+delegatedFromPMCommand ::+  StreamName ->+  PMCommandResult target ->+  Either DelegatedCommandError (DelegatedOutcome (CommandResult target))+delegatedFromPMCommand resolvedTarget = \case+  PMCommandDuplicate _ -> Right DelegatedDuplicate+  PMCommandAppended result+    | result ^. #eventsAppended > 0 -> Right (DelegatedFresh result)+    | otherwise -> Left (DelegatedCommandWithoutReceipt resolvedTarget)+  PMCommandFailed failedTarget err -> Left (DelegatedCommandFailed failedTarget err)

@@ -9,9 +9,15 @@ module Keiro.Inbox.Types   ( RetryDelay (..),     InboxDedupePolicy (..),+    InboxIdempotence (..),     InboxPersistence (..),     InboxStatus (..),     InboxResult (..),+    DelegatedOutcome (..),+    DelegatedRetryContext,+    mkDelegatedRetryContext,+    delegatedRetryCeiling,+    delegatedRetryAttempt,     InboxError (..),     InboxRow (..),     KafkaDeliveryRef (..),@@ -56,6 +62,16 @@   | CustomDedupeKey !Text   deriving stock (Generic, Eq, Show) +-- | Where an integration consumer keeps its durable deduplication receipt.+--+-- 'IdempotenceInboxTable' uses Keiro's @keiro_inbox@ table. In+-- 'IdempotenceDelegated' mode the supplied handler owns the receipt and Keiro+-- performs no inbox reads or writes.+data InboxIdempotence+  = IdempotenceInboxTable+  | IdempotenceDelegated+  deriving stock (Generic, Eq, Show)+ -- | How much of the integration-event envelope the inbox persists on the -- success path. --@@ -84,8 +100,10 @@ -- | 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.+-- * 'InboxDuplicate' — a previous delivery already completed. Table-backed+--   intake does not run the handler; delegated intake may run it so the+--   downstream state machine can confirm the duplicate, while its protected+--   effects remain unchanged. -- * '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.@@ -98,6 +116,42 @@   | InboxPreviouslyFailed !(Maybe Text)   | InboxHandlerFailed !Text !Int   deriving stock (Generic, Eq, Show)++-- | The result asserted by a delegated-idempotence handler.+--+-- 'DelegatedFresh' means the handler durably completed the protected operation+-- for the first time. 'DelegatedDuplicate' means that same durable operation+-- was already complete. This value is an explicit assertion by the caller;+-- Keiro cannot prove that arbitrary effects were covered by the downstream+-- receipt.+data DelegatedOutcome a+  = DelegatedFresh !a+  | DelegatedDuplicate+  deriving stock (Generic, Eq, Show)++-- | Validated, caller-owned retry position for delegated intake.+--+-- The first value supplied to 'mkDelegatedRetryContext' is the positive attempt+-- ceiling and the second is the positive, one-based current attempt. Attempts+-- above the ceiling are valid: they classify a redelivery as+-- 'InboxPreviouslyFailed' without invoking the handler.+data DelegatedRetryContext = DelegatedRetryContext !Int !Int+  deriving stock (Eq, Show)++-- | Validate a retry ceiling and one-based current attempt.+mkDelegatedRetryContext :: Int -> Int -> Either Text DelegatedRetryContext+mkDelegatedRetryContext attemptLimit attempt+  | attemptLimit <= 0 = Left "delegated retry ceiling must be positive"+  | attempt <= 0 = Left "delegated retry attempt must be positive"+  | otherwise = Right (DelegatedRetryContext attemptLimit attempt)++-- | Read the configured attempt ceiling from a validated context.+delegatedRetryCeiling :: DelegatedRetryContext -> Int+delegatedRetryCeiling (DelegatedRetryContext attemptLimit _) = attemptLimit++-- | Read the one-based current attempt from a validated context.+delegatedRetryAttempt :: DelegatedRetryContext -> Int+delegatedRetryAttempt (DelegatedRetryContext _ attempt) = attempt  -- | Errors surfaced by the inbox wrapper that originate from the inbox -- itself rather than from the supplied handler.

@@ -6,9 +6,8 @@ -- -- * 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.+--   one outbox row per mapped event. Versioned source-event coordinates+--   derive both IDs deterministically across producer and publication 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@@ -32,6 +31,9 @@ module Keiro.Outbox   ( -- * Re-exports     module Keiro.Outbox.Types,+    module Keiro.Outbox.Identity,+    deriveProducerIdentity,+    recordProducerEnqueueOutcome,      -- * Storage primitives (transport-neutral)     enqueueOutboxTx,@@ -55,6 +57,7 @@     IntegrationEventDraft (..),     mkIntegrationProducer,     mintIntegrationEvent,+    freshIntegrationEvent,     draftToEvent,     enqueueProducerEventTx, @@ -71,6 +74,7 @@ import Data.Text qualified as Text import Data.TypeID qualified as TypeID import Data.UUID.V7 qualified as V7+import Data.Word (Word32) import Effectful (Eff, IOE, (:>)) import Effectful.Exception (displayException, trySync) import Keiro.Integration.Event@@ -79,6 +83,7 @@     SchemaReference,     TraceContext,   )+import Keiro.Outbox.Identity import Keiro.Outbox.Kafka (outboxRowToKafkaRecord) import Keiro.Outbox.Schema import Keiro.Outbox.Types@@ -87,6 +92,7 @@   ( KeiroMetrics,     recordOutboxBacklog,     recordOutboxDeadlettered,+    recordOutboxIdentityConflict,     recordOutboxPublished,     recordOutboxReclaimed,     recordOutboxRejected,@@ -95,7 +101,7 @@   ) import Kiroku.Store.Effect (Store) import Kiroku.Store.Transaction (runTransaction)-import Kiroku.Store.Types (EventId, GlobalPosition, RecordedEvent)+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)@@ -133,18 +139,16 @@ -- -- 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.+-- each 'Just' result writes one 'keiro_outbox' row. Source-event coordinates+-- derive stable IDs across enqueue and publication 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.+-- * 'messageIdPrefix' — non-empty namespace, validated using TypeID prefix+--   syntax. The resulting deterministic message ID is opaque text, not a TypeID.+--   Prefer 'mkIntegrationProducer'; direct record construction bypasses validation. -- * 'mapEvent' — pure mapper from a private 'RecordedEvent' and its --   decoded payload to an 'IntegrationEventDraft'. Returning 'Nothing' --   skips the event without enqueuing a row.@@ -162,22 +166,22 @@  -- | 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))-        )+mkIntegrationProducer producer+  | Text.null (producer ^. #messageIdPrefix) = Left (InvalidMessageIdPrefix "" "namespace must not be empty")+  | otherwise = 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.+-- those are filled by 'enqueueProducerEventTx' using deterministic identity. -- -- @sourceEventId@ and @sourceGlobalPosition@ default to the values on the--- underlying 'RecordedEvent' (see 'mintIntegrationEvent'); a mapper that+-- underlying 'RecordedEvent' (see 'enqueueProducerEventTx'); a mapper that -- needs to override them can replace the draft fields directly. data IntegrationEventDraft = IntegrationEventDraft   { destination :: !Text,@@ -205,7 +209,13 @@   IntegrationProducer e ->   IntegrationEventDraft ->   Eff es IntegrationEvent-mintIntegrationEvent producer draft = do+mintIntegrationEvent = freshIntegrationEvent+{-# DEPRECATED mintIntegrationEvent "Use enqueueProducerEventTx for replay-safe producer identity, or freshIntegrationEvent for explicitly fresh envelopes." #-}++-- | Generate an explicitly fresh envelope. Persist it before retrying; this+-- helper alone provides no producer replay identity or provenance defaulting.+freshIntegrationEvent :: (IOE :> es) => IntegrationProducer e -> IntegrationEventDraft -> Eff es IntegrationEvent+freshIntegrationEvent producer draft = do   typeId <- liftIO (TypeID.genTypeID (producer ^. #messageIdPrefix))   pure (draftToEvent (producer ^. #source) (TypeID.toText typeId) draft) @@ -231,33 +241,39 @@       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.+-- | Observe a completed enqueue attempt outside its transaction. Invoke once+-- after the runner returns; SQL serialization retries do not multiply metrics.+recordProducerEnqueueOutcome :: (MonadIO m) => Maybe KeiroMetrics -> ProducerEnqueueOutcome -> m ()+recordProducerEnqueueOutcome metrics = \case+  ProducerIdentityConflict {} -> recordOutboxIdentityConflict metrics 1+  _ -> pure ()++-- | Pure identity for one stable producer/source-event coordinate.+deriveProducerIdentity :: IntegrationProducer e -> ProducerEventKey -> ProducerIdentity+deriveProducerIdentity producer = deriveIdentity (producer ^. #source) (producer ^. #name) (producer ^. #messageIdPrefix)++-- | Enqueue a source event emission. Use index zero for today's single-draft+-- mapper. Missing source provenance defaults from the recorded event. On a+-- conflict, callers should condemn the surrounding checkpoint transaction and+-- report the returned field classes after the transaction completes.+-- Suppression is bounded by outbox retention; wire identity survives GC. enqueueProducerEventTx ::-  forall e es.-  (IOE :> es) =>   IntegrationProducer e ->-  OutboxId ->+  RecordedEvent ->+  Word32 ->   IntegrationEventDraft ->-  Eff es (Tx.Transaction ())-enqueueProducerEventTx producer outboxId draft = do-  event <- mintIntegrationEvent producer draft-  pure (enqueueOutboxTx (OutboxMessage {outboxId, event}))+  Tx.Transaction ProducerEnqueueOutcome+enqueueProducerEventTx producer recorded emission draft =+  enqueueProducerOutboxTx identity event+  where+    identity = deriveProducerIdentity producer (ProducerEventKey (recorded ^. #eventId) emission)+    withProvenance =+      draft+        & #sourceEventId+        .~ ((draft ^. #sourceEventId) <|> Just (recorded ^. #eventId))+        & #sourceGlobalPosition+        .~ ((draft ^. #sourceGlobalPosition) <|> Just (recorded ^. #globalPosition))+    event = normalizeProducerEvent (draftToEvent (producer ^. #source) (identity ^. #messageId) withProvenance)  -- --------------------------------------------------------------------------- -- Publisher worker

@@ -0,0 +1,139 @@+-- | Frozen version-1 producer identities and canonical envelope comparisons.+module Keiro.Outbox.Identity+  ( ProducerEventKey (..),+    ProducerIdentity (..),+    ProducerEnqueueOutcome (..),+    ConflictField (..),+    producerIdentityBytes,+    deriveIdentity,+    producerContentDigest,+    differingContentFields,+    normalizeProducerEvent,+  )+where++import Crypto.Hash.SHA256 qualified as SHA256+import Data.Bits ((.&.), (.|.))+import Data.ByteString qualified as BS+import Data.ByteString.Base16 qualified as Base16+import Data.ByteString.Builder qualified as Builder+import Data.ByteString.Lazy qualified as Lazy+import Data.Text.Encoding qualified as TE+import Data.Time (UTCTime (..))+import Data.UUID qualified as UUID+import Data.Word (Word16, Word32)+import Keiro.Integration.Event+import Keiro.Outbox.Types (OutboxId (..))+import Keiro.Prelude+import Keiro.ReplayDigest (canonicalJsonBytes, replayDigest)+import Kiroku.Store.Types (EventId (..))++data ProducerEventKey = ProducerEventKey+  { sourceEventId :: !EventId,+    emissionIndex :: !Word32+  }+  deriving stock (Generic, Eq, Show)++data ProducerIdentity = ProducerIdentity+  { outboxId :: !OutboxId,+    messageId :: !Text,+    derivationVersion :: !Word16+  }+  deriving stock (Generic, Eq, Show)++-- | Field classes only: no payload or metadata values appear in conflicts.+data ConflictField+  = IdentityField+  | RoutingField+  | SchemaField+  | PayloadField+  | OccurredAtField+  | CausalField+  | TraceField+  | AttributesField+  | ProvenanceField+  deriving stock (Generic, Eq, Ord, Show)++-- | Transaction-local result. Insertion does not assert that the surrounding+-- transaction committed; later checkpoint failure can still roll it back.+data ProducerEnqueueOutcome+  = ProducerInserted !ProducerIdentity+  | ProducerDuplicateIdentical !ProducerIdentity+  | ProducerIdentityConflict !ProducerIdentity !(NonEmpty ConflictField)+  deriving stock (Generic, Eq, Show)++-- | Each field has an unsigned 64-bit big-endian byte length. Fields are+-- domain, version (two bytes), UTF-8 source/name, source UUID (16 network-order+-- bytes), and emission index (four bytes). The namespace labels the message ID;+-- changing it intentionally conflicts with the unchanged outbox UUID.+producerIdentityBytes :: Text -> Text -> ProducerEventKey -> BS.ByteString+producerIdentityBytes source name key =+  Lazy.toStrict . Builder.toLazyByteString $+    field "keiro.producer.outbox"+      <> Builder.word64BE 2+      <> Builder.word16BE 1+      <> field (TE.encodeUtf8 source)+      <> field (TE.encodeUtf8 name)+      <> Builder.word64BE 16+      <> Builder.word32BE a+      <> Builder.word32BE b+      <> Builder.word32BE c+      <> Builder.word32BE d+      <> Builder.word64BE 4+      <> Builder.word32BE (key ^. #emissionIndex)+  where+    EventId uuid = key ^. #sourceEventId+    (a, b, c, d) = UUID.toWords uuid+    field value = Builder.word64BE (fromIntegral (BS.length value)) <> Builder.byteString value++-- | SHA-256 of the canonical tuple. UUID uses the first 128 bits with RFC+-- variant and version 8 bits set. Message ID is namespace <> "_v1_" <> full+-- lowercase SHA-256 hex. No clock, random generator, or process state is read.+deriveIdentity :: Text -> Text -> Text -> ProducerEventKey -> ProducerIdentity+deriveIdentity source name namespace key =+  ProducerIdentity+    { outboxId = OutboxId (UUID.fromWords (word 0) ((word 4 .&. 0xffff0fff) .|. 0x8000) ((word 8 .&. 0x3fffffff) .|. 0x80000000) (word 12)),+      messageId = namespace <> "_v1_" <> TE.decodeUtf8 (Base16.encode digest),+      derivationVersion = 1+    }+  where+    digest = SHA256.hash (producerIdentityBytes source name key)+    word offset = BS.foldl' (\acc byte -> acc * 256 + fromIntegral byte) 0 (BS.take 4 (BS.drop offset digest))++-- | PostgreSQL stores whole microseconds. Normalize before writing so the+-- canonical timestamp is unchanged by the database round trip.+normalizeProducerEvent :: IntegrationEvent -> IntegrationEvent+normalizeProducerEvent event = event & #occurredAt .~ UTCTime day (fromRational (fromInteger micros / 1000000))+  where+    UTCTime day time = event ^. #occurredAt+    micros = floor (toRational time * 1000000) :: Integer++-- | RFC 8785 JSON of a fixed ordered list of field classes. Payload stays+-- byte-exact (hex); attributes are structured canonical JSON, not encoded text.+producerContentDigest :: IntegrationEvent -> Text+producerContentDigest = replayDigest . toJSON . fmap snd . contentFields++differingContentFields :: IntegrationEvent -> IntegrationEvent -> [ConflictField]+differingContentFields a b+  -- Exact envelope equality implies canonical equality. This avoids hex/JSON+  -- allocation for the usual identical replay; canonical comparison still+  -- handles equivalent structured values and wire-equivalent optional schemas.+  | normalizeProducerEvent a == normalizeProducerEvent b = []+  | otherwise = [field | ((field, x), (_, y)) <- zip (contentFields a) (contentFields b), canonicalJsonBytes x /= canonicalJsonBytes y]++contentFields :: IntegrationEvent -> [(ConflictField, Value)]+contentFields original =+  [ (IdentityField, headers [headerMessageId, headerSource]),+    (RoutingField, toJSON (event ^. #destination, event ^. #key)),+    (SchemaField, headers [headerEventType, headerSchemaVersion, headerContentType, headerSchemaRegistry, headerSchemaSubject, headerSchemaVersionRef, headerSchemaId, headerSchemaFingerprint]),+    (PayloadField, toJSON (TE.decodeUtf8 (Base16.encode (event ^. #payloadBytes)))),+    (OccurredAtField, headers [headerOccurredAt]),+    (CausalField, headers [headerCausationId, headerCorrelationId]),+    (TraceField, headers [headerTraceParent, headerTraceState]),+    (AttributesField, toJSON (maybe [] pure (event ^. #attributes))),+    (ProvenanceField, headers [headerSourceEventId, headerSourceGlobalPosition])+  ]+  where+    event = normalizeProducerEvent original+    allHeaders = integrationHeaders event+    headers names = toJSON [(name, lookup name allHeaders) | name <- names]

@@ -7,6 +7,7 @@ -- ('Keiro.Outbox.Kafka') consume these primitives. module Keiro.Outbox.Schema   ( enqueueOutboxTx,+    enqueueProducerOutboxTx,     claimOutboxBatch,     requeueStuckOutbox,     markOutboxSent,@@ -27,6 +28,7 @@ import Contravariant.Extras (contrazip2, contrazip3, contrazip4, contrazip5) import Data.ByteString (ByteString) import Data.Functor.Contravariant ((>$<))+import Data.List.NonEmpty qualified as NE import Data.Time.Clock (NominalDiffTime, addUTCTime) import Data.UUID (UUID) import Effectful (Eff, (:>))@@ -34,12 +36,13 @@ import Hasql.Encoders qualified as E import Hasql.Statement (Statement, preparable) import Keiro.Integration.Event-  ( IntegrationEvent (..),+  ( IntegrationContentType (..),+    IntegrationEvent (..),     SchemaReference (..),     TraceContext (..),     contentTypeText,-    parseContentType,   )+import Keiro.Outbox.Identity import Keiro.Outbox.Rejection (PublishRejection (..)) import Keiro.Outbox.Types import Keiro.Prelude@@ -64,6 +67,33 @@ enqueueOutboxTx message =   Tx.statement (toEncodedRow message) enqueueOutboxStmt +-- | Insert or compare both unique identities without mutating a retained row.+-- A separate statement sees a concurrent winner at READ COMMITTED. Higher+-- isolation levels require the caller's normal serialization retry policy.+enqueueProducerOutboxTx :: ProducerIdentity -> IntegrationEvent -> Tx.Transaction ProducerEnqueueOutcome+enqueueProducerOutboxTx identity event = do+  inserted <- Tx.statement (toEncodedRow (OutboxMessage (identity ^. #outboxId) event)) enqueueProducerStmt+  if inserted+    then pure (ProducerInserted identity)+    else do+      rows <- Tx.statement (unOutboxId (identity ^. #outboxId), event ^. #source, event ^. #messageId) producerConflictStmt+      case rows of+        [] -> enqueueProducerOutboxTx identity event -- GC won between insert and read.+        _ -> case NE.nonEmpty (concatMap differences rows) of+          Nothing -> pure (ProducerDuplicateIdentical identity)+          Just fields -> pure (ProducerIdentityConflict identity fields)+  where+    differences row =+      [IdentityField | row ^. #outboxId /= identity ^. #outboxId]+        <> differingContentFields event (row ^. #event)++producerConflictStmt :: Statement (UUID, Text, Text) [OutboxRow]+producerConflictStmt =+  preparable+    (selectAllSql <> " WHERE outbox_id = $1 OR (source = $2 AND message_id = $3) ORDER BY outbox_id FOR UPDATE")+    (contrazip3 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.text)))+    (D.rowList outboxRowDecoder)+ -- | Read a single outbox row by id. Used by tests and inspection tooling. lookupOutbox :: (Store :> es) => OutboxId -> Eff es (Maybe OutboxRow) lookupOutbox outboxId =@@ -372,40 +402,42 @@ -- ---------------------------------------------------------------------------  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+enqueueOutboxStmt = preparable (enqueueOutboxSql <> " ON CONFLICT (source, message_id) DO NOTHING") encodedRowEncoder D.noResult +enqueueProducerStmt :: Statement EncodedRow Bool+enqueueProducerStmt = preparable (enqueueOutboxSql <> " ON CONFLICT DO NOTHING") encodedRowEncoder ((> 0) <$> D.rowsAffected)++enqueueOutboxSql :: Text+enqueueOutboxSql =+  """+  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)+  """+ claimStmt :: OrderingPolicy -> Statement (Int64, UTCTime) [OutboxRow] claimStmt policy =   preparable@@ -871,7 +903,7 @@             key = raw ^. #key,             eventType = raw ^. #eventType,             schemaVersion = raw ^. #schemaVersion,-            contentType = parseContentType (raw ^. #contentType),+            contentType = if raw ^. #contentType == "application/json" then ApplicationJson else OtherContentType (raw ^. #contentType),             schemaReference,             sourceEventId = raw ^. #sourceEventId,             sourceGlobalPosition = raw ^. #sourceGlobalPosition,

@@ -230,8 +230,10 @@  -- | 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'.+-- zero or more 'timers'. The manager-state append and timer writes share one+-- transaction. Each target command then commits in its own transaction, so a+-- later failure cannot roll back an earlier target append; deterministic ids+-- make redelivery finish missing dispatches. data ProcessManagerAction ci targetCi = ProcessManagerAction   { command :: !ci,     commands :: ![PMCommand targetCi],

@@ -0,0 +1,713 @@+{-# LANGUAGE CPP #-}++-- | Additive process-manager reactions with explicit typed outcomes.+--+-- A reaction may advance a private saga stream, run timer SQL atomically with+-- that append, and then dispatch commands to independent target streams. The+-- timer and target phases are deliberately separate transactions. Accepted+-- redelivery validates the recorded saga witness, skips timer SQL, and retries+-- target fan-out with deterministic target-keyed ids.+--+-- 'NoAdvance' and silent domain decisions have no durable receipt. Their+-- unconditional timer effects may therefore run again, including around a+-- concurrent accepted delivery; effects that must be tied to acceptance belong+-- in @onAccepted@. Inputs to 'react', including command order and payloads, must+-- be stable for a source event. Dispatches are attempted in declared order, but+-- independent transactions, failures, and replay do not guarantee that commit+-- order. Switching an existing manager to this identity family requires a+-- drain; there is no positional-id fallback.+module Keiro.ProcessManager.Reaction+  ( -- * Definition+    ReactiveProcessManager (..),+    ReactionPlan (..),+    FollowUp (..),+    ScheduleMode (..),++    -- * Results+    ReactionStateResult (..),+    ReactionTimerEffects (..),+    ReactionError (..),+    ReactiveProcessManagerResult (..),++    -- * Running+    runReactiveProcessManagerOnce,+    runReactiveProcessManagerWorkerWith,+    runReactiveProcessManagerWorker,++    -- * Identity+    deterministicReactionCommandId,+  )+where++import Control.Monad (foldM)+#ifdef KEIRO_REACTION_HYDRATION_PROBE+import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy.Char8 qualified as LazyByteString+#endif+import Data.ByteString qualified as ByteString+import Data.ByteString.Char8 qualified as ByteString.Char8+import Data.Coerce (coerce)+import Data.List qualified as List+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Data.UUID qualified as UUID+import Data.UUID.V5 qualified as UUID.V5+import Data.Vector qualified as Vector+import Effectful (Eff, IOE, (:>))+import Effectful.Error.Static (Error, tryError)+import GHC.Stack (HasCallStack)+import Keiki.Core (BoolAlg, RegFile)+import Keiro.Codec (decodeRecorded)+import Keiro.Command+  ( CommandError (..),+    DomainCommandHandler,+    DomainCommandOutcome (..),+    DomainDecision (..),+    RunCommandOptions,+    runDomainCommandWithSqlEvents,+  )+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,+    decideForFailures,+    defaultWorkerOptions,+    deterministicCommandIdProbes,+    dispatchDeduplicatedCommand,+    firstExistingEventId,+  )+import Keiro.Projection (InlineProjection, runCommandWithProjections)+import Keiro.Stream (Stream)+import Keiro.Telemetry (recordDispatchDuplicate, recordDispatchFailed, recordDispatchPoison)+import Keiro.Timer+  ( TimerId,+    TimerRequest,+    cancelTimerTx,+    scheduleTimerOnceTx,+    scheduleTimerTx,+  )+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Effect.Resource (KirokuStoreResource)+import Kiroku.Store.Error (StoreError)+import Kiroku.Store.Read (getStream, readStreamForward)+import Kiroku.Store.Transaction (runTransaction)+import Kiroku.Store.Types (EventId (..), RecordedEvent, StreamName (..), StreamVersion (..))+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+#ifdef KEIRO_REACTION_HYDRATION_PROBE+import System.IO (stderr)+#endif+import "hasql-transaction" Hasql.Transaction qualified as Tx+import Prelude qualified++-- | A pure reaction selected from one decoded input.+--+-- 'NoAdvance' has no saga command and therefore cannot carry accepted-only+-- effects. 'AdvanceReaction' always runs @followUps@ for the observed outcome;+-- @onAccepted@ is added only when this invocation appends or recovers the+-- deterministic accepted witness.+data ReactionPlan ci targetCi+  = NoAdvance ![FollowUp targetCi]+  | AdvanceReaction+      { command :: !ci,+        followUps :: ![FollowUp targetCi],+        onAccepted :: ![FollowUp targetCi]+      }+  deriving stock (Generic, Eq, Show)++-- | One ordered reaction effect. Timer operations retain their relative order+-- in the timer transaction and dispatches retain theirs in the later target+-- phase; the two kinds are not one cross-stream transaction. 'Once' is+-- insert-only for the timer id, while 'Rearm' updates only a still-scheduled+-- row. Cancellation cannot revoke a callback that has already claimed a timer.+data FollowUp targetCi+  = FollowDispatch !(PMCommand targetCi)+  | FollowSchedule !ScheduleMode !TimerRequest+  | FollowCancel !TimerId+  deriving stock (Generic, Eq, Show)++-- | Whether scheduling may move an existing still-scheduled row or is strictly+-- insert-only while any row with the timer id exists.+data ScheduleMode = Rearm | Once+  deriving stock (Generic, Eq, Show)++-- | The saga-state portion of a reaction result.+data ReactionStateResult target co rejection noOp+  = ReactionNotAdvanced+  | ReactionEvaluated !(DomainCommandOutcome target co rejection noOp)+  | ReactionDuplicate !EventId+  deriving stock (Generic, Eq, Show)++-- | Honest accounting for the timer transaction that committed.+--+-- @statementsCommitted@ includes no-op statements. @onceInserted@ and+-- @timersCancelled@ count only rows actually changed. Rearm intentionally has+-- no changed-row counter because the underlying SQL does not return one.+data ReactionTimerEffects = ReactionTimerEffects+  { statementsCommitted :: !Int,+    onceInserted :: !Int,+    timersCancelled :: !Int+  }+  deriving stock (Generic, Eq, Show)++-- | Reaction failures that are not infrastructure failures. Store errors stay+-- in the ambient @Error StoreError@ effect.+data ReactionError+  = ReactionCommandFailed !CommandError+  | ReactionWitnessMissing !StreamName !EventId+  | ReactionWitnessUndecodable !StreamName !EventId+  deriving stock (Generic, Eq, Show)++-- | Detailed result for a one-shot caller. Worker entry points use a strict+-- payload-free reduction instead of retaining this value through fan-out.+data ReactiveProcessManagerResult managerTarget co rejection noOp commandTarget = ReactiveProcessManagerResult+  { managerResult :: !(ReactionStateResult managerTarget co rejection noOp),+    commandResults :: ![PMCommandResult commandTarget],+    timerEffects :: !ReactionTimerEffects+  }+  deriving stock (Generic, Eq, Show)++-- | Runtime wiring for one reactive process manager.+data ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp = ReactiveProcessManager+  { name :: !Text,+    correlate :: !(input -> Text),+    sagaHandler :: !(DomainCommandHandler phi rs s ci co rejection noOp),+    streamFor :: !(Text -> Stream (EventStream phi rs s ci co)),+    targetEventStream :: !(ValidatedEventStream targetPhi targetRs targetState targetCi targetCo),+    targetProjections :: !(Stream targetCi -> [InlineProjection targetCo]),+    react :: !(input -> ReactionPlan ci targetCi)+  }+  deriving stock (Generic)++zeroTimerEffects :: ReactionTimerEffects+zeroTimerEffects = ReactionTimerEffects 0 0 0++data EngineReducer managerTarget co rejection noOp commandTarget summary = EngineReducer+  { beginReduction :: !(ReactionStateResult managerTarget co rejection noOp -> ReactionTimerEffects -> summary),+    addDispatchReduction :: !(Int -> PMCommandResult commandTarget -> summary -> summary),+    finishReduction :: !(summary -> summary)+  }+  deriving stock (Generic)++data ReactionWorkerSummary = ReactionWorkerSummary+  { workerDuplicates :: !Int64,+    workerFailures :: ![DispatchFailure]+  }+  deriving stock (Generic, Eq, Show)++-- | Run one reaction. Accepted saga events and their timer effects commit in+-- one transaction; target commands are then attempted independently in source+-- order. Duplicate accepted recovery validates the exact saga witness before+-- skipping timer SQL and retrying target dispatches.+runReactiveProcessManagerOnce ::+  forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp 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 ->+  ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp ->+  RecordedEvent ->+  input ->+  Eff+    es+    ( Either+        ReactionError+        ( ReactiveProcessManagerResult+            (EventStream phi rs s ci co)+            co+            rejection+            noOp+            (EventStream targetPhi targetRs targetState targetCi targetCo)+        )+    )+runReactiveProcessManagerOnce options manager sourceEvent input =+  runReactiveProcessManagerEngine onceReducer options manager sourceEvent input+  where+    onceReducer =+      EngineReducer+        { beginReduction = \managerResult timerEffects ->+            ReactiveProcessManagerResult managerResult [] timerEffects,+          addDispatchReduction = \_ commandResult result ->+            result {commandResults = commandResult : result ^. #commandResults},+          finishReduction = \result ->+            result {commandResults = Prelude.reverse (result ^. #commandResults)}+        }++runReactiveProcessManagerEngine ::+  forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp summary 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+  ) =>+  EngineReducer+    (EventStream phi rs s ci co)+    co+    rejection+    noOp+    (EventStream targetPhi targetRs targetState targetCi targetCo)+    summary ->+  RunCommandOptions ->+  ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp ->+  RecordedEvent ->+  input ->+  Eff es (Either ReactionError summary)+runReactiveProcessManagerEngine reducer options manager sourceEvent input =+  case (manager ^. #react) input of+    NoAdvance unconditional -> do+      timers <- runTimerPhase unconditional+      finish ReactionNotAdvanced timers unconditional+    AdvanceReaction sagaCommand unconditional acceptedOnly -> do+      existing <- firstExistingEventId options sagaStreamName managerProbes+      case existing of+        Just matchedId -> recoverAndFinish matchedId (unconditional <> acceptedOnly)+        Nothing -> do+          outcome <-+            runDomainCommandWithSqlEvents+              managerOptions+              (manager ^. #sagaHandler)+              sagaStream+              sagaCommand+              (\_ _ -> runTimerPhaseTx (unconditional <> acceptedOnly))+          case outcome of+            Left commandError -> do+              raced <- firstExistingEventId options sagaStreamName managerProbes+              case raced of+                Just matchedId -> recoverAndFinish matchedId (unconditional <> acceptedOnly)+                Nothing -> pure (Left (ReactionCommandFailed commandError))+            Right (domainOutcome@DomainCommandOutcome {decision = DomainAccepted {}}, Just timers) ->+              finish (ReactionEvaluated domainOutcome) timers (unconditional <> acceptedOnly)+            Right (DomainCommandOutcome {decision = DomainAccepted {}}, Nothing) ->+              Prelude.error "runReactiveProcessManagerOnce: accepted append omitted timer callback result"+            Right (domainOutcome, Nothing) -> do+              raced <- firstExistingEventId options sagaStreamName managerProbes+              case raced of+                Just matchedId -> recoverAndFinish matchedId (unconditional <> acceptedOnly)+                Nothing -> do+                  timers <- runTimerPhase unconditional+                  finish (ReactionEvaluated domainOutcome) timers unconditional+            Right (_, Just _) ->+              Prelude.error "runReactiveProcessManagerOnce: silent decision returned a timer callback result"+  where+    correlationId = (manager ^. #correlate) input+    sourceId = sourceEvent ^. #eventId+    sagaStream = (manager ^. #streamFor) correlationId+    sagaEventStream = (manager ^. #sagaHandler) ^. #eventStream+    sagaStreamName = ((unvalidated sagaEventStream) ^. #resolveStreamName) sagaStream+    managerProbes = deterministicCommandIdProbes (manager ^. #name) correlationId sourceId (-1)+    managerId = NonEmpty.head managerProbes+    managerOptions = options & #eventIds .~ [managerId]++    recoverAndFinish matchedId selected = do+      recovered <- recoverWitness sagaEventStream sagaStreamName matchedId+      case recovered of+        Left err -> pure (Left err)+        Right () -> finish (ReactionDuplicate matchedId) zeroTimerEffects selected++    finish state timers selected = do+      let initial = (reducer ^. #beginReduction) state timers+      initial `Prelude.seq` do+        reduced <-+          dispatchReactionCommandsWith+            (reducer ^. #addDispatchReduction)+            initial+            options+            manager+            correlationId+            sourceId+            selected+        pure (Right ((reducer ^. #finishReduction) reduced))++-- | Drain a Shibuya adapter with the configured poison, rejection, retry, and+-- telemetry policies. Each normally resolved delivery is finalized exactly+-- once. The worker reduces accepted saga payloads before target fan-out and+-- retains only duplicate and failure accounting while dispatching.+runReactiveProcessManagerWorkerWith ::+  forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp 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 ->+  ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp ->+  Adapter es msg ->+  (msg -> Maybe (RecordedEvent, input)) ->+  Eff es ()+runReactiveProcessManagerWorkerWith 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 -> decidePoison env+        Just (recorded, input) -> decideReaction env recorded input+      finalizeAck decision+      pure decision++    decideReaction env recorded input = do+      let correlationId = (manager ^. #correlate) input+          sagaStream = (manager ^. #streamFor) correlationId+          sagaEventStream = (manager ^. #sagaHandler) ^. #eventStream+          sagaStreamName = ((unvalidated sagaEventStream) ^. #resolveStreamName) sagaStream+          attemptCount = envelopeAttemptCount env+      outcome <-+        tryError @StoreError+          (runReactiveProcessManagerEngine workerReducer options manager recorded input)+      case outcome of+        Left (_, storeError) -> do+          recordDispatchFailed (workerOptions ^. #metrics) 1+          pure (ackForCommandError (workerOptions ^. #transientRetryDelay) (StoreFailed storeError))+        Right (Left (ReactionCommandFailed commandError)) -> do+          recordDispatchFailed (workerOptions ^. #metrics) 1+          decideForFailures+            workerOptions+            DispatcherProcessManager+            (manager ^. #name)+            correlationId+            recorded+            attemptCount+            [DispatchFailure (-1) sagaStreamName commandError]+        Right (Left witnessError) -> do+          recordDispatchFailed (workerOptions ^. #metrics) 1+          pure (AckHalt (HaltFatal (witnessReason witnessError)))+        Right (Right summary) -> do+          recordDispatchDuplicate (workerOptions ^. #metrics) (summary ^. #workerDuplicates)+          recordDispatchFailed+            (workerOptions ^. #metrics)+            (Prelude.fromIntegral (Prelude.length (summary ^. #workerFailures)))+          decideForFailures+            workerOptions+            DispatcherProcessManager+            (manager ^. #name)+            correlationId+            recorded+            attemptCount+            (summary ^. #workerFailures)++    decidePoison env = do+      recordDispatchPoison (workerOptions ^. #metrics) 1+      case workerOptions ^. #poisonPolicy of+        PoisonHalt -> pure (AckHalt (HaltFatal "process-reaction-worker-decode-failed"))+        PoisonSkip callback -> do+          callback env+          pure AckOk+        PoisonDeadLetter callback -> do+          callback env+          pure (AckDeadLetter (InvalidPayload "process-reaction-worker-decode-failed"))++    workerReducer =+      EngineReducer+        { beginReduction = \state _ ->+            ReactionWorkerSummary+              { workerDuplicates = case state of+                  ReactionDuplicate {} -> 1+                  ReactionNotAdvanced -> 0+                  ReactionEvaluated {} -> 0,+                workerFailures = []+              },+          addDispatchReduction = \emitIndex result summary ->+            case result of+              PMCommandAppended {} -> summary+              PMCommandDuplicate {} ->+                summary {workerDuplicates = summary ^. #workerDuplicates Prelude.+ 1}+              PMCommandFailed targetStreamName commandError ->+                summary+                  { workerFailures =+                      DispatchFailure emitIndex targetStreamName commandError+                        : summary ^. #workerFailures+                  },+          finishReduction = \summary ->+            summary {workerFailures = Prelude.reverse (summary ^. #workerFailures)}+        }++    envelopeAttemptCount env =+      case env ^. #attempt of+        Nothing -> 1+        Just (Attempt attempt) -> Prelude.fromIntegral attempt Prelude.+ 1++    witnessReason = \case+      ReactionWitnessMissing {} -> "process-reaction-witness-missing"+      ReactionWitnessUndecodable {} -> "process-reaction-witness-undecodable"+      ReactionCommandFailed {} -> "process-reaction-command-failed"++-- | Run a reactive process-manager worker with 'defaultWorkerOptions'.+runReactiveProcessManagerWorker ::+  forall msg input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp 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 ->+  ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp ->+  Adapter es msg ->+  (msg -> Maybe (RecordedEvent, input)) ->+  Eff es ()+runReactiveProcessManagerWorker =+  runReactiveProcessManagerWorkerWith defaultWorkerOptions++-- | Execute just the timer subsequence in one transaction.+runTimerPhase :: (IOE :> es, Store :> es) => [FollowUp targetCi] -> Eff es ReactionTimerEffects+runTimerPhase followUps+  | List.null timerFollowUps = pure zeroTimerEffects+  | otherwise = do+      emitTimerPhaseProbe (List.length timerFollowUps)+      runTransaction (runTimerPhaseTx followUps)+  where+    timerFollowUps = List.filter isTimerFollowUp followUps+    isTimerFollowUp FollowSchedule {} = True+    isTimerFollowUp FollowCancel {} = True+    isTimerFollowUp FollowDispatch {} = False++#ifdef KEIRO_REACTION_HYDRATION_PROBE+emitTimerPhaseProbe :: (IOE :> es) => Int -> Eff es ()+emitTimerPhaseProbe statementCount =+  liftIO+    ( ByteString.Char8.hPutStrLn stderr+        ( LazyByteString.toStrict+            ( Aeson.encode+                ( Aeson.object+                    [ "marker" Aeson..= ("reaction-probe" :: Text.Text),+                      "operation" Aeson..= ("timer-phase" :: Text.Text),+                      "statements" Aeson..= statementCount+                    ]+                )+            )+        )+    )+#else+emitTimerPhaseProbe :: Int -> Eff es ()+emitTimerPhaseProbe _ = pure ()+#endif++runTimerPhaseTx :: [FollowUp targetCi] -> Tx.Transaction ReactionTimerEffects+runTimerPhaseTx = foldM step zeroTimerEffects+  where+    step summary = \case+      FollowDispatch {} -> pure summary+      FollowSchedule Rearm request -> do+        scheduleTimerTx request+        pure summary {statementsCommitted = summary ^. #statementsCommitted Prelude.+ 1}+      FollowSchedule Once request -> do+        inserted <- scheduleTimerOnceTx request+        pure+          summary+            { statementsCommitted = summary ^. #statementsCommitted Prelude.+ 1,+              onceInserted = summary ^. #onceInserted Prelude.+ if inserted then 1 else 0+            }+      FollowCancel timerId -> do+        cancelled <- cancelTimerTx timerId+        pure+          summary+            { statementsCommitted = summary ^. #statementsCommitted Prelude.+ 1,+              timersCancelled = summary ^. #timersCancelled Prelude.+ if cancelled then 1 else 0+            }++-- | Validate the exact accepted event while holding only one page at a time.+-- The stream version captured after the positive point probe is a finite read+-- ceiling, so a vanished witness cannot chase concurrent appends forever.+recoverWitness ::+  (IOE :> es, Store :> es) =>+  ValidatedEventStream phi rs s ci co ->+  StreamName ->+  EventId ->+  Eff es (Either ReactionError ())+#ifdef KEIRO_REACTION_HYDRATION_PROBE+recoverWitness validated streamName witnessId =+  do+    let probeStreamName = case streamName of StreamName name -> name+    liftIO+      ( ByteString.Char8.hPutStrLn stderr+          ( LazyByteString.toStrict+              ( Aeson.encode+                  ( Aeson.object+                      [ "marker" Aeson..= ("reaction-probe" :: Text.Text),+                        "operation" Aeson..= ("witness" :: Text.Text),+                        "stream" Aeson..= probeStreamName+                      ]+                  )+              )+          )+      )+    recoverWitnessAfterProbe validated streamName witnessId+#else+recoverWitness validated streamName witnessId =+  recoverWitnessAfterProbe validated streamName witnessId+#endif++recoverWitnessAfterProbe ::+  (Store :> es) =>+  ValidatedEventStream phi rs s ci co ->+  StreamName ->+  EventId ->+  Eff es (Either ReactionError ())+recoverWitnessAfterProbe validated streamName witnessId = do+  streamInfo <- getStream streamName+  case streamInfo of+    Nothing -> pure (Left missing)+    Just info -> scan (info ^. #id) (info ^. #version) (StreamVersion 0)+  where+    missing = ReactionWitnessMissing streamName witnessId+    codec = (unvalidated validated) ^. #eventCodec+    pageSize = 256++    scan expectedStreamId ceiling cursor = do+      page <- readStreamForward streamName cursor pageSize+      let withinCeiling = Vector.takeWhile (\event -> event ^. #streamVersion <= ceiling) page+          found = Vector.find (\event -> event ^. #eventId == witnessId) withinCeiling+      case found of+        Just witness+          | witness ^. #originalStreamId /= expectedStreamId -> pure (Left missing)+          | otherwise ->+              pure+                $ case decodeRecorded codec witness of+                  Left _ -> Left (ReactionWitnessUndecodable streamName witnessId)+                  Right _ -> Right ()+        Nothing+          | Vector.null withinCeiling -> pure (Left missing)+          | otherwise ->+              let next = (Vector.last withinCeiling) ^. #streamVersion+               in if next >= ceiling+                    then pure (Left missing)+                    else scan expectedStreamId ceiling next++dispatchReactionCommandsWith ::+  forall input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp summary es.+  ( HasCallStack,+    IOE :> es,+    Store :> es,+    Error StoreError :> es,+    KirokuStoreResource :> es,+    BoolAlg targetPhi (RegFile targetRs, targetCi),+    Eq targetCo+  ) =>+  (Int -> PMCommandResult (EventStream targetPhi targetRs targetState targetCi targetCo) -> summary -> summary) ->+  summary ->+  RunCommandOptions ->+  ReactiveProcessManager input phi rs s ci co targetPhi targetRs targetState targetCi targetCo rejection noOp ->+  Text ->+  EventId ->+  [FollowUp targetCi] ->+  Eff es summary+dispatchReactionCommandsWith reduce initial options manager correlationId sourceId =+  go Map.empty 0 initial+  where+    go _ _ summary [] = pure summary+    go occurrences dispatchIndex summary (followUp : rest) =+      case followUp of+        FollowDispatch dispatched -> do+          let targetStream = retarget (dispatched ^. #target)+              targetName = ((unvalidated (manager ^. #targetEventStream)) ^. #resolveStreamName) targetStream+              occurrence = Map.findWithDefault 0 targetName occurrences+              nextOccurrences = Map.insert targetName (occurrence Prelude.+ 1) occurrences+              commandId =+                deterministicReactionCommandId+                  (manager ^. #name)+                  correlationId+                  sourceId+                  targetName+                  occurrence+          result <- dispatchOne targetStream targetName commandId dispatched+          let nextSummary = reduce dispatchIndex result summary+          nextSummary `Prelude.seq` go nextOccurrences (dispatchIndex Prelude.+ 1) nextSummary rest+        _ -> go occurrences dispatchIndex summary rest++    dispatchOne targetStream targetName commandId dispatched = do+      let targetOptions = options & #eventIds .~ [commandId]+      dispatchedInitial <-+        dispatchDeduplicatedCommand+          options+          targetName+          (commandId :| [])+          PMCommandDuplicate+          (PMCommandFailed targetName)+          PMCommandAppended+          ( runCommandWithProjections+              targetOptions+              (manager ^. #targetEventStream)+              targetStream+              (dispatched ^. #command)+              ((manager ^. #targetProjections) (dispatched ^. #target))+          )+      case dispatchedInitial of+        PMCommandFailed {} -> reconcile dispatchedInitial+        PMCommandAppended commandResult+          | commandResult ^. #eventsAppended == 0 -> reconcile dispatchedInitial+        _ -> pure dispatchedInitial+      where+        reconcile preserved = do+          raced <- firstExistingEventId options targetName (commandId :| [])+          pure (maybe preserved PMCommandDuplicate raced)++    retarget :: Stream targetCi -> Stream (EventStream targetPhi targetRs targetState targetCi targetCo)+    retarget = coerce++-- | Derive the stable first-event id for one reaction target command.+--+-- Every field is encoded as its decimal UTF-8 byte length, a colon, and the+-- bytes. The fields are, in order: @keiro@, @process-reaction@, manager name,+-- correlation id, canonical source UUID text, physical target stream name, and+-- decimal zero-based occurrence among commands to that target.+deterministicReactionCommandId :: Text -> Text -> EventId -> StreamName -> Int -> EventId+deterministicReactionCommandId managerName correlationId sourceEventId targetStreamName occurrence =+  EventId+    $ UUID.V5.generateNamed UUID.V5.namespaceURL+    $ ByteString.unpack+    $ ByteString.concat+    $ fmap+      encodeField+      [ "keiro",+        "process-reaction",+        managerName,+        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+            ]

@@ -18,7 +18,7 @@ -- deprecated 'runQueryWith' waiting overrides. Define new models through -- 'ReadModelBlueprint' and the truthful builders. 'ConsistencyMode', direct -- waiting fields, and 'runQueryWith' remain deprecated 0.12 compatibility and--- are removed in 0.13.+-- remain until the frozen Language 4 read-model generator is retired. -- -- Schema lifecycle (registration, status transitions) lives in -- "Keiro.ReadModel.Schema", which is re-exported here.@@ -331,27 +331,29 @@       pollMicros = 10000     } -{-# DEPRECATED ConsistencyMode "Use QueryFreshness. ConsistencyMode remains through the 0.12 compatibility window and is removed in 0.13." #-}+-- Published keiro-dsl Language 4 output still names this compatibility surface.+-- Keep it until that frozen read-model generator is retired.+{-# DEPRECATED ConsistencyMode "Use QueryFreshness. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED Strong "Use WaitForHead. Strong is a bounded captured-head wait, not linearizability; it is removed in 0.13." #-}+{-# DEPRECATED Strong "Use WaitForHead. Strong is a bounded captured-head wait, not linearizability. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED Eventual "Use Immediate. Eventual means only that the query does not wait; it is removed in 0.13." #-}+{-# DEPRECATED Eventual "Use Immediate. Eventual means only that the query does not wait. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED PositionWait "Use WaitForPosition with a concrete target. Legacy PositionWait Nothing remains immediate through 0.12 and is removed in 0.13." #-}+{-# DEPRECATED PositionWait "Use WaitForPosition with a concrete target. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED StrongScope "Use HeadScope. StrongScope remains through the 0.12 compatibility window and is removed in 0.13." #-}+{-# DEPRECATED StrongScope "Use HeadScope. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED EntireLog "Use EntireVisibleLog. EntireLog remains through the 0.12 compatibility window and is removed in 0.13." #-}+{-# DEPRECATED EntireLog "Use EntireVisibleLog. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED CategoryHead "Use CategoryVisibleHead. CategoryHead remains through the 0.12 compatibility window and is removed in 0.13." #-}+{-# DEPRECATED CategoryHead "Use CategoryVisibleHead. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED defaultStrongWaitOptions "Use defaultHeadWaitOptions. The legacy name is removed in 0.13." #-}+{-# DEPRECATED defaultStrongWaitOptions "Use defaultHeadWaitOptions. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED subscriptionName "Use ReadModelBlueprint.cursorAuthority and readModelCursorAuthority. The legacy record field is removed in 0.13." #-}+{-# DEPRECATED subscriptionName "Use ReadModelBlueprint.cursorAuthority and readModelCursorAuthority. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED defaultConsistency "Use ReadModelBlueprint builders and readModelDefaultFreshness. The legacy record field is removed in 0.13." #-}+{-# DEPRECATED defaultConsistency "Use ReadModelBlueprint builders and readModelDefaultFreshness. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-} -{-# DEPRECATED strongScope "Use HeadScope through the ReadModelBlueprint builders. The legacy record field is removed in 0.13." #-}+{-# DEPRECATED strongScope "Use HeadScope through the ReadModelBlueprint builders. It remains exported while keiro-dsl's Language 4 read-model generator emits it and is removed with that generator in a later major release." #-}  -- | Why a read-model query could not run. data ReadModelError@@ -415,7 +417,7 @@   Eff es (Either ReadModelError r) runQueryWith metrics consistency readModel =   runQueryWithFreshness metrics (legacyOverrideFreshness consistency readModel) readModel-{-# DEPRECATED runQueryWith "Use runQueryWithFreshness. The legacy override is removed in 0.13." #-}+{-# DEPRECATED runQueryWith "Use runQueryWithFreshness. It remains exported while keiro-dsl's Language 4 read-model generator emits the legacy consistency surface and is removed with that generator in a later major release." #-}  runValidatedQuery ::   (Store :> es) =>

@@ -73,6 +73,7 @@     keiroOutboxBacklogName,     keiroOutboxPublishedName,     keiroOutboxRejectedName,+    keiroOutboxIdentityConflictName,     keiroOutboxRetriedName,     keiroOutboxDeadletteredName,     keiroOutboxReclaimedName,@@ -126,6 +127,7 @@     recordOutboxBacklog,     recordOutboxPublished,     recordOutboxRejected,+    recordOutboxIdentityConflict,     recordOutboxRetried,     recordOutboxDeadlettered,     recordOutboxReclaimed,@@ -581,6 +583,9 @@ keiroOutboxPublishedName :: Text keiroOutboxPublishedName = "keiro.outbox.published" +keiroOutboxIdentityConflictName :: Text+keiroOutboxIdentityConflictName = "keiro.outbox.identity.conflict"+ keiroOutboxRejectedName :: Text keiroOutboxRejectedName = "keiro.outbox.rejected" @@ -742,6 +747,7 @@   { outboxBacklog :: Gauge Int64,     outboxPublished :: Counter Int64,     outboxRejected :: Counter Int64,+    outboxIdentityConflict :: Counter Int64,     outboxRetried :: Counter Int64,     outboxDeadlettered :: Counter Int64,     outboxReclaimed :: Counter Int64,@@ -802,6 +808,7 @@ newKeiroMetrics meter = liftIO $ do   outboxBacklog' <- gaugeI64 keiroOutboxBacklogName "{event}" "Outbox rows awaiting publish."   outboxPublished' <- counterI64 keiroOutboxPublishedName "{event}" "Outbox events successfully published."+  outboxIdentityConflict' <- counterI64 keiroOutboxIdentityConflictName "{event}" "Producer enqueues refused because retained identity has different content."   outboxRejected' <- counterI64 keiroOutboxRejectedName "{event}" "Outbox events intentionally and permanently rejected by the publisher."   outboxRetried' <- counterI64 keiroOutboxRetriedName "{event}" "Outbox publish attempts that failed and will retry."   outboxDeadlettered' <- counterI64 keiroOutboxDeadletteredName "{event}" "Outbox events parked after exhausting retries."@@ -856,6 +863,7 @@       { outboxBacklog = outboxBacklog',         outboxPublished = outboxPublished',         outboxRejected = outboxRejected',+        outboxIdentityConflict = outboxIdentityConflict',         outboxRetried = outboxRetried',         outboxDeadlettered = outboxDeadlettered',         outboxReclaimed = outboxReclaimed',@@ -939,6 +947,10 @@  recordOutboxPublished :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxPublished = recordCounter outboxPublished++-- | Record after the transaction runner returns, including deliberate checkpoint rollback.+recordOutboxIdentityConflict :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m ()+recordOutboxIdentityConflict = recordCounter outboxIdentityConflict  recordOutboxRejected :: (MonadIO m) => Maybe KeiroMetrics -> Int64 -> m () recordOutboxRejected = recordCounter outboxRejected

@@ -66,6 +66,7 @@     findStuckTimers,     requeueStuckTimers,     requeueStuckTimer,+    cancelTimerTx,     cancelTimer,     deadLetterTimer, 

@@ -59,6 +59,7 @@     findStuckTimers,     requeueStuckTimers,     requeueStuckTimer,+    cancelTimerTx,     cancelTimer,     deadLetterTimer,   )@@ -518,9 +519,15 @@ -- 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+cancelTimer = runTransaction . cancelTimerTx++-- | Transactional form of 'cancelTimer'. It uses the same guarded SQL but lets+-- callers compose cancellation atomically with an event append and other timer+-- mutations. Foreground-owned rows remain protected even after their lease has+-- expired; recovery must clear their ownership token first.+cancelTimerTx :: TimerId -> Tx.Transaction Bool+cancelTimerTx timerId =+  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

@@ -10,15260 +10,17051 @@ 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 (ErrorCall, Exception, SomeException, displayException, evaluate, finally, throwIO, try)-import Control.Monad (forM, forM_)-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.Char (isDigit)-import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)-import Data.Int (Int32)-import Data.List (isInfixOf)-import Data.List.NonEmpty qualified as NonEmpty-import Data.Map.Strict qualified as Map-import Data.Maybe (catMaybes)-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.Text.IO qualified as TextIO-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.UUID.V5 qualified as UUID.V5-import Data.Vector qualified as Vector-import Data.Version (showVersion)-import Data.Word (Word64)-import Effectful (Eff, IOE, (:>))-import Effectful.Error.Static (Error, throwError)-import Effectful.Exception qualified as EffException-import ExternalReadSpec qualified-import GHC.Conc (ThreadStatus (..), threadStatus)-import GroupRebuildSpec qualified-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,-    lit,-    matchInCtor,-    oNil,-    pack,-    proj,-    (*:),-    (.==),-  )-import Keiki.Core qualified as Keiki-import Keiki.Generics (emptyRegFile)-import Keiki.Operators qualified as K-import Keiki.Shape (CanonicalStateShape)-import Keiro-import Keiro qualified as KeiroRoot-import Keiro.Codec.Nominal-  ( NominalBinding (..),-    NominalFixture (..),-    NominalFixtureCases (..),-    nominalDomainRoundTrip,-    nominalRepresentationRoundTrip,-  )-import Keiro.Codec.Structural-  ( StructuralBinding (..),-    bindingDomainRoundTrip,-    bindingShapeRoundTrip,-    decodeViaBinding,-    encodeViaBinding,-  )-import Keiro.Connection (ensureProjectionSchema, qualifyTable, withProjectionSchema)-import Keiro.DeadLetter-  ( DispatchDeadLetter (..),-    DispatcherKind (..),-    listDispatchDeadLetters,-    recordDispatchDeadLetter,-  )-import Keiro.DeadLetter.Replay-  ( ReplayOutcome (..),-    ReplayResult (..),-    listSubscriptionDeadLetters,-    replaySubscriptionDeadLetters,-  )-import Keiro.DeterministicId (deterministicIdProbes, identitySeedBytes, legacySeedBytes)-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 (..),-    PublishRejectionError (..),-    claimOutboxBatch,-    defaultMaintenanceOptions,-    defaultPublishOptions,-    draftToEvent,-    enqueueIntegrationEventTx,-    freshOutboxId,-    garbageCollectSent,-    lookupOutbox,-    markOutboxSent,-    mintIntegrationEvent,-    mkIntegrationProducer,-    mkOutboxPublishOptions,-    mkPublishRejection,-    outboxMaintenancePass,-    publishClaimedOutbox,-    publishRejectionCode,-    publishRejectionDetail,-    sampleOutboxBacklog,-  )-import Keiro.Outbox.Kafka qualified as OutboxKafka-import Keiro.Outbox.Schema (markOutboxFailedTx, markOutboxRejectedTx)-import Keiro.Prelude-import Keiro.ProcessManager-import Keiro.Projection-import Keiro.ReadModel-import Keiro.ReadModel.Rebuild qualified as Rebuild-import Keiro.ReplayAudit qualified as ReplayAudit-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 (..),-    withFreshDatabase,-    withFreshResourceStore,-    withFreshResourceStoreWith,-    withFreshStore,-    withFreshStoreWith,-    withFreshStores2,-    withMigratedSuite,-  )-import Keiro.Timer-import Keiro.Timer qualified as Timer-import Keiro.Wake-  ( WakeReason (..),-    WakeSignal (..),-    neverWake,-    wakeSignalFromStore,-  )-import Keiro.Workflow-  ( LeaseHeartbeat (..),-    PatchId (..),-    StepName (..),-    Workflow,-    WorkflowError (..),-    WorkflowId (..),-    WorkflowIdentityError (..),-    WorkflowJournalEvent (StepRecorded, WorkflowCancelled, WorkflowCompleted, WorkflowContinuedAsNew, WorkflowFailed),-    WorkflowLeaseLost (..),-    WorkflowName (..),-    WorkflowOutcome (..),-    appendJournalEntry,-    appendJournalEntryReturningId,-    awaitStep,-    awakeableAllocStepPrefix,-    awakeableStepPrefix,-    cancelledStepName,-    completedStepName,-    continueAsNew,-    continueSeedStepName,-    continuedAsNewStepName,-    currentGeneration,-    defaultWorkflowRunOptions,-    deterministicJournalId,-    failedStepName,-    findUnfinishedWorkflowIds,-    loadStepIndex,-    mkWorkflowId,-    mkWorkflowName,-    patch,-    patchSetStepName,-    patchStepName,-    restoreSeed,-    runWorkflow,-    runWorkflowWith,-    step,-    stepExists,-    workflowGenerationStreamName,-    workflowJournalCodec,-  )-import Keiro.Workflow.Awakeable-  ( AwakeableId (..),-    WorkflowAwakeableCancelled (..),-    awakeableIdText,-    awakeableIdToUuid,-    awakeableNamed,-    cancelAwakeable,-    signalAwakeable,-    signalAwakeableFrom,-  )-import Keiro.Workflow.Awakeable.Compatibility-  ( generation0AwakeableId,-    preUtf8Generation0AwakeableId,-  )-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-  ( drainWorkflowSleepTimers,-    matchSleepTimerGeneration,-    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 Numeric.Natural (Natural)-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 Paths_keiro qualified as Package-import PreCanonicalRecoverySpec qualified-import PreimageSpec qualified-import ProjectionReplaySpec qualified-import ReadModelSpec qualified-import Shibuya.Adapter (Adapter (..))-import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..), deadLetterCodeText, deadLetterReasonCode, deadLetterReasonDetail, renderDeadLetterReason)-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 VersionedRebuildSpec qualified-import VersionedTargetPostgresSpec qualified-import "hasql-transaction" Hasql.Transaction qualified as Tx--main :: IO ()-main = withMigratedSuite $ \fixture -> hspec $ do-  CatalogSpec.spec-  PreimageSpec.spec-  CatalogEvolutionSpec.spec fixture-  CatalogOperationsSpec.spec fixture-  GroupRebuildSpec.spec fixture-  ExternalReadSpec.spec fixture-  VersionedTargetPostgresSpec.spec fixture-  VersionedRebuildSpec.spec fixture-  PreCanonicalRecoverySpec.spec fixture-  ProjectionReplaySpec.spec fixture-  ReadModelSpec.spec--  describe "catalog-fenced inline projections" $ around (withFreshResourceStore fixture) $ do-    it "rolls back the event append and target write while its group rebuilds" $ \(_storeHandle, StoreRunner runStore) -> do-      validated <--        case validateProjectionCatalog catalogInlineProjectionCatalog of-          Failure diagnostics ->-            expectationFailure ("catalog fixture failed validation: " <> show diagnostics)-              >> error "unreachable"-          Success value -> pure value-      Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql)-      Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated--      let targetStream = stream "counter-catalog-fence" :: Stream CounterEventStream-      first <--        runStore $-          runCommandWithCatalogProjections-            defaultRunCommandOptions-            counterEventStream-            targetStream-            (Add 4)-            validated-            catalogInlineProjectionSet-      first `shouldSatisfy` \case-        Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1-        _ -> False-      Right 1 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)--      Right (Right _) <--        runStore $-          Rebuild.beginGroupRebuild-            validated-            catalogInlineGroupId-            Rebuild.RebuildRequest-              { rebuildRunId = catalogInlineRunId,-                requestedBy = "keiro-test",-                requestReason = "inline fence proof",-                replayFrom = GlobalPosition 0-              }-      Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)--      second <--        runStore $-          runCommandWithCatalogProjections-            defaultRunCommandOptions-            counterEventStream-            targetStream-            (Add 5)-            validated-            catalogInlineProjectionSet-      second-        `shouldBe` Right (Right (ProjectionCommandFenced catalogInlineGroupId catalogInlineRunId))-      Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)-      Right recorded <--        runStore $-          Store.readStreamForward (StreamName "counter-catalog-fence") (StreamVersion 0) 10-      Vector.length recorded `shouldBe` 1--      let foreignSource = catalogIdentity mkSourceId "catalog-inline-foreign-source"-          foreignSet = catalogInlineProjectionSet & #projectionSource .~ foreignSource-          foreignStream = stream "counter-catalog-mismatch" :: Stream CounterEventStream-      mismatch <--        runStore $-          runCommandWithCatalogProjections-            defaultRunCommandOptions-            counterEventStream-            foreignStream-            (Add 6)-            validated-            foreignSet-      mismatch `shouldBe` Right (Right (ProjectionCommandCatalogMismatch foreignSource))-      Right absent <--        runStore $-          Store.readStreamForward (StreamName "counter-catalog-mismatch") (StreamVersion 0) 10-      Vector.null absent `shouldBe` True--    it "waits for an in-flight writer before preparing and clearing its group" $ \(_storeHandle, StoreRunner runStore) -> do-      validated <--        case validateProjectionCatalog catalogInlineProjectionCatalog of-          Failure diagnostics ->-            expectationFailure ("catalog fixture failed validation: " <> show diagnostics)-              >> error "unreachable"-          Success value -> pure value-      Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql)-      Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated--      writerDone <- newEmptyMVar-      let targetStream = stream "counter-catalog-lock-order" :: Stream CounterEventStream-      _ <--        forkIO $-          runStore-            ( runCommandWithCatalogProjections-                defaultRunCommandOptions-                counterEventStream-                targetStream-                (Add 9)-                validated-                catalogSlowInlineProjectionSet-            )-            >>= putMVar writerDone-      threadDelay 200_000-      startedAt <- getCurrentTime-      Right (Right _) <--        runStore $-          Rebuild.beginGroupRebuild-            validated-            catalogInlineGroupId-            Rebuild.RebuildRequest-              { rebuildRunId = catalogInlineRunId,-                requestedBy = "keiro-test",-                requestReason = "in-flight inline lock proof",-                replayFrom = GlobalPosition 0-              }-      finishedAt <- getCurrentTime--      writer <- takeMVar writerDone-      writer `shouldSatisfy` \case-        Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1-        _ -> False-      diffUTCTime finishedAt startedAt `shouldSatisfy` (> 0.5)-      Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)-      pure ()--    it "dispatches inline writes through the persisted serving revision before appending" $ \(_storeHandle, StoreRunner runStore) -> do-      validated <- expectValidatedCatalog catalogInlineProjectionCatalog-      v1Only <- expectValidatedCatalog catalogInlineV1Catalog-      Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql)-      Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated-      Right () <- runStore $ Store.runTransaction (Tx.sql seedCatalogInlineVersionedV1Sql)--      let targetStream = stream "counter-versioned-inline" :: Stream CounterEventStream-      first <--        runStore $-          runCommandWithCatalogProjections-            defaultRunCommandOptions-            counterEventStream-            targetStream-            (Add 4)-            validated-            catalogInlineProjectionSet-      first `shouldSatisfy` \case-        Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1-        _ -> False-      Right [101] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt)--      Right () <- runStore $ Store.runTransaction (Tx.sql promoteCatalogInlineV2Sql)-      second <--        runStore $-          runCommandWithCatalogProjections-            defaultRunCommandOptions-            counterEventStream-            targetStream-            (Add 5)-            validated-            catalogInlineProjectionSet-      second `shouldSatisfy` \case-        Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1-        _ -> False-      Right [202] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt)--      missing <--        runStore $-          runCommandWithCatalogProjections-            defaultRunCommandOptions-            counterEventStream-            targetStream-            (Add 6)-            v1Only-            catalogInlineProjectionSet-      missing-        `shouldBe` Right-          ( Right-              ( ProjectionCommandServingRevisionUnavailable-                  catalogInlineGroupId-                  catalogInlineRevisionV2Id-              )-          )-      Right recorded <--        runStore $-          Store.readStreamForward (StreamName "counter-versioned-inline") (StreamVersion 0) 10-      Vector.length recorded `shouldBe` 2-      Right [202] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt)-      pure ()--  describe "Keiro" $ do-    it "exposes the package metadata version" $-      KeiroRoot.version `shouldBe` Text.pack (showVersion Package.version)--    it "keeps package metadata as the only version authority" $ do-      source <- TextIO.readFile "src/Keiro.hs"-      source `shouldSatisfy` Text.isInfixOf "showVersion Package.version"-      let isNumericVersionAssignment sourceLine =-            "version =" `Text.isInfixOf` sourceLine-              && Text.count "." sourceLine >= 3-              && Text.any isDigit sourceLine-      Text.lines source `shouldSatisfy` all (not . isNumericVersionAssignment)--  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.Codec.Structural" $ do-    let pairBinding :: StructuralBinding (Int, Bool) (Bool, Int)-        pairBinding =-          StructuralBinding-            { bindingToShape = \(amount, enabled) -> (enabled, amount),-              bindingFromShape = \(enabled, amount) -> (amount, enabled)-            }-        encodePairShape (enabled, amount) =-          object ["enabled" Aeson..= enabled, "amount" Aeson..= amount]-        decodePairShape value =-          case parseEither (withObject "PairShape" $ \objectValue -> (,) <$> objectValue .: "enabled" <*> objectValue .: "amount") value of-            Left err -> Left (Text.pack err)-            Right shape -> Right shape--    it "checks both total binding laws" $ do-      bindingDomainRoundTrip pairBinding (7, True) `shouldBe` True-      bindingShapeRoundTrip pairBinding (False, 9) `shouldBe` True--    it "delegates encoding to the generated shape codec" $-      encodeViaBinding pairBinding encodePairShape (7, True)-        `shouldBe` object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]--    it "propagates only shape decode failures before total construction" $ do-      let encoded = object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]-      decodeViaBinding pairBinding decodePairShape encoded `shouldBe` Right (9, False)-      decodeViaBinding pairBinding (const (Left "shape-error")) Aeson.Null-        `shouldBe` Left "shape-error"--  describe "Keiro.Codec.Nominal" $ do-    let swappedBinding :: NominalBinding (Int, Bool) (Bool, Int)-        swappedBinding =-          NominalBinding-            { nominalToRepresentation = \(amount, enabled) -> (enabled, amount),-              nominalFromRepresentation = \(enabled, amount) -> (amount, enabled)-            }-        fixtures =-          NominalFixtureCases-            ( NominalFixture "enabled" (object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]) (7, True)-                :| [NominalFixture "disabled" (object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]) (9, False)]-            )--    it "checks both total nominal binding laws" $ do-      nominalDomainRoundTrip swappedBinding (7, True) `shouldBe` True-      nominalRepresentationRoundTrip swappedBinding (False, 9) `shouldBe` True--    it "retains labelled expected-wire fixtures" $-      nominalFixtureCases fixtures-        `shouldBe` ( NominalFixture "enabled" (object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]) (7, True)-                       :| [NominalFixture "disabled" (object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]) (9, False)]-                   )--  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 duplicate upcaster sources at the stream boundary" $ do-      let duplicateCodec =-            counterCodec-              { schemaVersion = 3,-                upcasters = [(1, const Right), (1, const Right)]-              }-          duplicateStream = counterEventStreamDef {eventCodec = duplicateCodec}-      case mkEventStream "duplicate-codec" duplicateStream of-        Left warnings -> do-          map eswStreamLabel warnings `shouldSatisfy` all (== "duplicate-codec")-          map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "duplicate upcaster source version(s): 1")-        Right _ -> expectationFailure "expected mkEventStream to reject duplicate upcaster sources"--    it "rejects a missing upcaster rung at the stream boundary" $ do-      let incompleteCodec =-            counterCodec-              { schemaVersion = 3,-                upcasters = [(2, const Right)]-              }-          incompleteStream = counterEventStreamDef {eventCodec = incompleteCodec}-      case mkEventStream "incomplete-codec" incompleteStream of-        Left warnings -> do-          map eswStreamLabel warnings `shouldSatisfy` all (== "incomplete-codec")-          map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "missing upcaster source version(s): 1")-        Right _ -> expectationFailure "expected mkEventStream to reject an incomplete upcaster chain"--    it "includes the stream label when throwing for an invalid codec" $ do-      let incompleteCodec =-            counterCodec-              { schemaVersion = 3,-                upcasters = [(2, const Right)]-              }-          incompleteStream = counterEventStreamDef {eventCodec = incompleteCodec}-      result <- try @ErrorCall (evaluate (mkEventStreamOrThrow "throwing-incomplete-codec" incompleteStream))-      case result of-        Left err -> do-          displayException err `shouldSatisfy` isInfixOf "throwing-incomplete-codec"-          displayException err `shouldSatisfy` isInfixOf "missing upcaster source version(s): 1"-        Right _ -> expectationFailure "expected mkEventStreamOrThrow to reject an incomplete upcaster chain"--    it "keeps invalid codecs available through the unchecked escape hatch" $ do-      let duplicateCodec =-            counterCodec-              { schemaVersion = 3,-                upcasters = [(1, const Right), (1, const Right)]-              }-          incompleteCodec =-            counterCodec-              { schemaVersion = 3,-                upcasters = [(2, const Right)]-              }-      _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef {eventCodec = duplicateCodec})-      _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef {eventCodec = incompleteCodec})-      pure ()--    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-" <> showVersion Package.version,-            "test/ReplaySafetyTypeProbe.hs"-          ]-          ""-      exitCode `shouldSatisfy` (/= ExitSuccess)-      stderr `shouldSatisfy` ("ValidatedEventStream" `isInfixOf`)--  describe "Keiro.Command" $ around (withFreshStore fixture) $ do-    describe "typed domain command outcomes" $ do-      it "returns the exact ordered accepted batch and compatibility result" $ \storeHandle -> do-        let target = stream "domain-command-accepted" :: Stream CounterEventStream-        commandResult <--          Store.runStoreIO storeHandle $-            runDomainCommand defaultRunCommandOptions multiCounterDomainHandler target (Add 4)-        case commandResult of-          Right (Right outcome@DomainCommandOutcome {decision = DomainAccepted events, result}) -> do-            events `shouldBe` (CounterAdded 4 :| [CounterAudited 4])-            result ^. #streamVersion `shouldBe` StreamVersion 2-            result ^. #eventsAppended `shouldBe` 2-            forgetDomainDecision outcome `shouldBe` result-          other -> expectationFailure ("expected typed accepted command, got " <> show other)-        Right recorded <--          Store.runStoreIO storeHandle $-            Store.readStreamForward (StreamName "domain-command-accepted") (StreamVersion 0) 10-        traverse (decodeRecorded counterCodec) (Vector.toList recorded)-          `shouldBe` Right [CounterAdded 4, CounterAudited 4]--      it "attributes sibling silent edges and returns typed rejection and no-op" $ \storeHandle -> do-        let rejectionTarget = stream "domain-command-rejected" :: Stream SilentChoiceEventStream-            noOpTarget = stream "domain-command-no-op" :: Stream SilentChoiceEventStream-        rejectionResult <--          Store.runStoreIO storeHandle $-            runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler rejectionTarget RejectSilently-        case rejectionResult of-          Right (Right outcome@DomainCommandOutcome {decision = DomainRejected reason, result}) -> do-            reason `shouldBe` "edge-0: rejected"-            result ^. #eventsAppended `shouldBe` 0-            result ^. #streamVersion `shouldBe` StreamVersion 0-            result ^. #globalPosition `shouldBe` Nothing-            forgetDomainDecision outcome `shouldBe` result-          other -> expectationFailure ("expected typed domain rejection, got " <> show other)-        noOpResult <--          Store.runStoreIO storeHandle $-            runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler noOpTarget NoOpSilently-        case noOpResult of-          Right (Right outcome@DomainCommandOutcome {decision = DomainNoOp explanation, result}) -> do-            explanation `shouldBe` "edge-1: already complete"-            result ^. #eventsAppended `shouldBe` 0-            result ^. #streamVersion `shouldBe` StreamVersion 0-            result ^. #globalPosition `shouldBe` Nothing-            forgetDomainDecision outcome `shouldBe` result-          other -> expectationFailure ("expected typed domain no-op, got " <> show other)-        Right rejectedEvents <--          Store.runStoreIO storeHandle $-            Store.readStreamForward (StreamName "domain-command-rejected") (StreamVersion 0) 10-        Right noOpEvents <--          Store.runStoreIO storeHandle $-            Store.readStreamForward (StreamName "domain-command-no-op") (StreamVersion 0) 10-        rejectedEvents `shouldBe` Vector.empty-        noOpEvents `shouldBe` Vector.empty--      it "keeps unmatched and ambiguous selection failures as CommandError" $ \storeHandle -> do-        let unmatchedTarget = stream "domain-command-unmatched" :: Stream SilentChoiceEventStream-            ambiguousTarget = stream "domain-command-ambiguous" :: Stream CounterEventStream-        unmatched <--          Store.runStoreIO storeHandle $-            runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler unmatchedTarget UnmatchedSilently-        ambiguous <--          Store.runStoreIO storeHandle $-            runDomainCommand defaultRunCommandOptions ambiguousCounterDomainHandler ambiguousTarget (Add 1)-        unmatched `shouldBe` Right (Left CommandRejected)-        ambiguous `shouldBe` Right (Left (CommandAmbiguous [0, 1]))--      it "retains validated rejection of state-changing silent edges" $ \_ -> do-        case mkEventStream "domain-state-changing-epsilon" stateChangingEpsilonEventStreamDef of-          Left warnings ->-            map eswReason warnings-              `shouldSatisfy` any (Text.isInfixOf "state-changing-epsilon")-          Right _ -> expectationFailure "expected validation to reject a state-changing silent edge"--      it "runs SQL once with the exact accepted event pairs" $ \_ ->-        withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do-          let target = stream "domain-command-sql-accepted" :: Stream CounterEventStream-          outcome <--            runner $-              runDomainCommandWithSqlEvents-                defaultRunCommandOptions-                multiCounterDomainHandler-                target-                (Add 6)-                (\pairs _appendResult -> pure (Prelude.fst <$> pairs))-          case outcome of-            Right-              ( Right-                  ( DomainCommandOutcome {decision = DomainAccepted events, result},-                    Just callbackEvents-                    )-                ) -> do-                events `shouldBe` (CounterAdded 6 :| [CounterAudited 6])-                callbackEvents `shouldBe` NonEmpty.toList events-                result ^. #eventsAppended `shouldBe` 2-            other -> expectationFailure ("expected accepted SQL domain command, got " <> show other)--      it "skips SQL callbacks and inline projections for rejection and no-op" $ \_ ->-        withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do-          let rejectionTarget = stream "domain-command-sql-rejected" :: Stream SilentChoiceEventStream-              noOpTarget = stream "domain-command-projection-no-op" :: Stream SilentChoiceEventStream-              callback _ _ = error "silent domain decision invoked SQL callback" :: Tx.Transaction Text-              projection =-                InlineProjection-                  { name = "silent-domain-bomb",-                    apply = \_ _ -> error "silent domain decision invoked projection"-                  }-          rejected <--            runner $-              runDomainCommandWithSqlEvents-                defaultRunCommandOptions-                silentChoiceDomainHandler-                rejectionTarget-                RejectSilently-                callback-          case rejected of-            Right (Right (DomainCommandOutcome {decision = DomainRejected reason}, Nothing)) ->-              reason `shouldBe` "edge-0: rejected"-            other -> expectationFailure ("expected silent SQL rejection, got " <> show other)-          noOp <--            runner $-              runDomainCommandWithProjections-                defaultRunCommandOptions-                silentChoiceDomainHandler-                noOpTarget-                NoOpSilently-                [projection]-          case noOp of-            Right (Right DomainCommandOutcome {decision = DomainNoOp explanation, result}) -> do-              explanation `shouldBe` "edge-1: already complete"-              result ^. #eventsAppended `shouldBe` 0-            other -> expectationFailure ("expected silent projection no-op, got " <> show other)--      it "applies inline projections atomically for accepted domain events" $ \_ ->-        withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do-          Right () <--            Store.runStoreIO storeHandle $-              initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-          let target = stream "domain-command-projection-accepted" :: Stream CounterEventStream-          outcome <--            runner $-              runDomainCommandWithProjections-                defaultRunCommandOptions-                multiCounterDomainHandler-                target-                (Add 7)-                [counterInlineProjection]-          case outcome of-            Right (Right DomainCommandOutcome {decision = DomainAccepted events}) ->-              events `shouldBe` (CounterAdded 7 :| [CounterAudited 7])-            other -> expectationFailure ("expected accepted projected domain command, got " <> show other)-          projected <--            Store.runStoreIO storeHandle $-              runQuery Nothing counterReadModel "inline"-          projected `shouldBe` Right (Right 7)--      it "preserves catalog outcomes while skipping catalog SQL for silent decisions" $ \_ ->-        withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do-          validated <--            case validateProjectionCatalog catalogInlineProjectionCatalog of-              Failure diagnostics ->-                expectationFailure ("catalog fixture failed validation: " <> show diagnostics)-                  >> error "unreachable"-              Success value -> pure value-          Right () <- runner $ Store.runTransaction (Tx.sql catalogInlineFixtureSql)-          Right (Right _) <- runner $ Rebuild.registerProjectionCatalog validated-          let target = stream "domain-command-catalog-rejected" :: Stream SilentChoiceEventStream-          outcome <--            runner $-              runDomainCommandWithCatalogProjections-                defaultRunCommandOptions-                silentChoiceDomainHandler-                target-                RejectSilently-                validated-                catalogInlineProjectionSet-          case outcome of-            Right (Right (DomainProjectionCommandApplied DomainCommandOutcome {decision = DomainRejected reason})) ->-              reason `shouldBe` "edge-0: rejected"-            other -> expectationFailure ("expected applied silent catalog decision, got " <> show other)-          Right 0 <- runner $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)-          let acceptedTarget = stream "domain-command-catalog-accepted" :: Stream CounterEventStream-          accepted <--            runner $-              runDomainCommandWithCatalogProjections-                defaultRunCommandOptions-                multiCounterDomainHandler-                acceptedTarget-                (Add 5)-                validated-                catalogInlineProjectionSet-          case accepted of-            Right (Right (DomainProjectionCommandApplied DomainCommandOutcome {decision = DomainAccepted events})) ->-              events `shouldBe` (CounterAdded 5 :| [CounterAudited 5])-            other -> expectationFailure ("expected applied accepted catalog decision, got " <> show other)-          Right 2 <- runner $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)-          Right (Right _) <--            runner $-              Rebuild.beginGroupRebuild-                validated-                catalogInlineGroupId-                Rebuild.RebuildRequest-                  { rebuildRunId = catalogInlineRunId,-                    requestedBy = "keiro-test",-                    requestReason = "typed domain catalog fence proof",-                    replayFrom = GlobalPosition 0-                  }-          let fencedTarget = stream "domain-command-catalog-fenced" :: Stream CounterEventStream-          fenced <--            runner $-              runDomainCommandWithCatalogProjections-                defaultRunCommandOptions-                multiCounterDomainHandler-                fencedTarget-                (Add 8)-                validated-                catalogInlineProjectionSet-          fenced-            `shouldBe` Right (Right (DomainProjectionCommandFenced catalogInlineGroupId catalogInlineRunId))-          Right recorded <--            runner $-              Store.readStreamForward (StreamName "domain-command-catalog-fenced") (StreamVersion 0) 10-          recorded `shouldBe` Vector.empty-          pure ()--      it "discards an accepted conflict attempt and returns the rehydrated silent decision" $ \_ ->-        withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do-          conflictInserted <- newIORef False-          let target = stream "domain-command-conflict-final-no-op" :: Stream RetryDecisionEventStream-              targetStreamName = StreamName "domain-command-conflict-final-no-op"-              insertConflict = do-                shouldInsert <- atomicModifyIORef' conflictInserted $ \inserted -> (True, not inserted)-                when shouldInsert $ do-                  encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 9))-                  appended <--                    Store.runStoreIO storeHandle $-                      Store.appendToStream targetStreamName NoStream [encoded]-                  case appended of-                    Right _ -> pure ()-                    Left err -> expectationFailure ("failed to inject domain conflict: " <> show err)-              options =-                defaultRunCommandOptions-                  & #beforeAppend-                  .~ insertConflict-                  & #retryBackoffMicros-                  .~ 0-              callback _ _ = error "stale accepted decision invoked SQL callback" :: Tx.Transaction Text-          outcome <--            runner $-              runDomainCommandWithSqlEvents-                options-                retryDecisionDomainHandler-                target-                (Add 1)-                callback-          case outcome of-            Right (Right (DomainCommandOutcome {decision = DomainNoOp explanation, result}, Nothing)) -> do-              explanation `shouldBe` "already drained"-              result ^. #streamVersion `shouldBe` StreamVersion 1-              result ^. #eventsAppended `shouldBe` 0-            other -> expectationFailure ("expected rehydrated no-op decision, got " <> show other)-          readIORef conflictInserted `shouldReturn` True-          Right recorded <--            Store.runStoreIO storeHandle $-              Store.readStreamForward targetStreamName (StreamVersion 0) 10-          traverse (decodeRecorded counterCodec) (Vector.toList recorded)-            `shouldBe` Right [CounterAdded 9]--      it "records only bounded decision classes on successful spans and metrics" $ \storeHandle -> do-        (processor, spansRef) <- inMemoryListExporter-        tracerProvider <- createTracerProvider [processor] emptyTracerProviderOptions-        (metricExporter, metricsRef) <- inMemoryMetricExporter-        (meterProvider, _env) <--          createMeterProvider-            emptyMaterializedResources-            defaultSdkMeterProviderOptions {metricExporter = Just metricExporter}-        meter <- getMeter meterProvider Telemetry.keiroInstrumentationLibrary-        keiroMetrics <- Telemetry.newKeiroMetrics meter-        let tracer = makeTracer tracerProvider "keiro-test" tracerOptions-            options =-              defaultRunCommandOptions-                & #tracer-                ?~ tracer-                & #metrics-                ?~ keiroMetrics-        Right (Right _) <--          Store.runStoreIO storeHandle $-            runDomainCommand options multiCounterDomainHandler (stream "domain-telemetry-accepted") (Add 1)-        Right (Right _) <--          Store.runStoreIO storeHandle $-            runDomainCommand options silentChoiceDomainHandler (stream "domain-telemetry-rejected") RejectSilently-        Right (Right _) <--          Store.runStoreIO storeHandle $-            runDomainCommand options silentChoiceDomainHandler (stream "domain-telemetry-no-op") NoOpSilently-        _ <- shutdownTracerProvider tracerProvider Nothing-        _ <- forceFlushMeterProvider meterProvider Nothing-        spans <- traverse captureSpan =<< readIORef spansRef-        fmap (\sp -> textAttr (csAttributes sp) "keiro.command.decision") spans-          `shouldMatchList` [Just "accepted", Just "rejected", Just "no_op"]-        fmap csStatus spans `shouldSatisfy` all (== Unset)-        fmap (\sp -> textAttr (csAttributes sp) "error.type") spans-          `shouldSatisfy` all (== Nothing)-        exported <- readIORef metricsRef-        let decisionPoints =-              [ (textAttr attrs "keiro.command.decision", value)-              | (name, value, attrs) <- flattenScalarPointsWithAttributes exported,-                name == "keiro.command.decisions"-              ]-        decisionPoints-          `shouldMatchList` [ (Just "accepted", IntNumber 1),-                              (Just "rejected", IntNumber 1),-                              (Just "no_op", IntNumber 1)-                            ]--      it "keeps all five process-manager target outcomes distinguishable" $ \_ ->-        withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do-          let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-              input =-                DomainDispatchInput-                  "five-outcomes"-                  [ CoordinatorAccept 3,-                    CoordinatorReject "private rejection",-                    CoordinatorNoOp "private no-op",-                    CoordinatorUnmatched-                  ]-          first <--            runner $-              runDomainProcessManagerOnce-                defaultRunCommandOptions-                domainProcessManager-                sourceEvent-                input-          case first of-            Right (Right result) -> do-              result ^. #managerResult `shouldSatisfy` \case-                PMStateAppended {} -> True-                _ -> False-              case result ^. #commandResults of-                [ DomainPMCommandHandled DomainCommandOutcome {decision = DomainAccepted events},-                  DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected reason},-                  DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp explanation},-                  DomainPMCommandFailed _ CommandRejected-                  ] -> do-                    events `shouldBe` (CounterAdded 3 :| [])-                    reason `shouldBe` "private rejection"-                    explanation `shouldBe` "private no-op"-                other -> expectationFailure ("expected four fresh domain PM outcomes, got " <> show other)-            other -> expectationFailure ("expected domain process-manager success, got " <> show other)-          second <--            runner $-              runDomainProcessManagerOnce-                defaultRunCommandOptions-                domainProcessManager-                sourceEvent-                input-          case second of-            Right (Right result) -> do-              result ^. #managerResult `shouldSatisfy` \case-                PMStateDuplicate {} -> True-                _ -> False-              result ^. #commandResults `shouldSatisfy` \case-                [ DomainPMCommandDuplicate {},-                  DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected "private rejection"},-                  DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp "private no-op"},-                  DomainPMCommandFailed _ CommandRejected-                  ] -> True-                _ -> False-            other -> expectationFailure ("expected domain process-manager redelivery, got " <> show other)--      it "keeps all five router target outcomes distinguishable" $ \_ ->-        withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do-          let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)-              input =-                DomainDispatchInput-                  "five-outcomes"-                  [ CoordinatorAccept 4,-                    CoordinatorReject "router rejection",-                    CoordinatorNoOp "router no-op",-                    CoordinatorUnmatched-                  ]-          Right (DomainRouterResult first) <--            runner $-              runDomainRouterOnce-                defaultRunCommandOptions-                domainRouter-                sourceEvent-                input-          case first of-            [ DomainPMCommandHandled DomainCommandOutcome {decision = DomainAccepted events},-              DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected reason},-              DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp explanation},-              DomainPMCommandFailed _ CommandRejected-              ] -> do-                events `shouldBe` (CounterAdded 4 :| [])-                reason `shouldBe` "router rejection"-                explanation `shouldBe` "router no-op"-            other -> expectationFailure ("expected four fresh domain router outcomes, got " <> show other)-          Right (DomainRouterResult second) <--            runner $-              runDomainRouterOnce-                defaultRunCommandOptions-                domainRouter-                sourceEvent-                input-          second `shouldSatisfy` \case-            [ DomainPMCommandDuplicate {},-              DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected "router rejection"},-              DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp "router no-op"},-              DomainPMCommandFailed _ CommandRejected-              ] -> True-            _ -> False--      it "acks domain rejection and no-op in coordinator workers without leaking payloads" $ \_ ->-        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-          processManagerDecisions <- newIORef []-          routerDecisions <- newIORef []-          let rejectionPayload = "pm-private-rejection-payload"-              noOpPayload = "router-private-no-op-payload"-              processManagerSource = recordedFromEventId (EventId sampleUuid3) (CounterAdded 1)-              routerSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)-              processManagerInput = DomainDispatchInput "worker-pm" [CoordinatorReject rejectionPayload, CoordinatorNoOp "pm no-op"]-              routerInput = DomainDispatchInput "worker-router" [CoordinatorReject "router rejection", CoordinatorNoOp noOpPayload]-              processManagerAdapter = inMemoryAdapter processManagerDecisions [(processManagerSource, processManagerInput)]-              routerAdapter = inMemoryAdapter routerDecisions [(routerSource, routerInput)]-              workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics-              commandOptions = defaultRunCommandOptions & #metrics ?~ keiroMetrics-          Right () <--            runner $-              runDomainProcessManagerWorkerWith-                workerOptions-                commandOptions-                domainProcessManager-                processManagerAdapter-                Just-          Right () <--            runner $-              runDomainRouterWorkerWith-                workerOptions-                commandOptions-                domainRouter-                routerAdapter-                Just-          readIORef processManagerDecisions `shouldReturn` [AckOk]-          readIORef routerDecisions `shouldReturn` [AckOk]-          Right processManagerDeadLetters <- runner (listDispatchDeadLetters "domain-pm")-          Right routerDeadLetters <- runner (listDispatchDeadLetters "domain-router")-          processManagerDeadLetters `shouldBe` []-          routerDeadLetters `shouldBe` []-          _ <- forceFlushMeterProvider provider Nothing-          exported <- readIORef metricsRef-          lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 0)-          let rendered = Text.pack (show exported)-          Text.isInfixOf rejectionPayload rendered `shouldBe` False-          Text.isInfixOf noOpPayload rendered `shouldBe` False--    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 "fails hydration after guard tightening without a replay-only twin (plan 143 reproduction)" $ \storeHandle -> do-      let target = stream "divert-black-acuity-bad" :: Stream DivertEventStream-      Right (Right appended) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True)-      appended ^. #streamVersion `shouldBe` StreamVersion 1-      result <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions tightenedDivertEventStream target (ConfirmDivert False)-      result-        `shouldBe` Right-          (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge))--    it "replays black-acuity history through the replay-only twin and keeps serving the live rule" $ \storeHandle -> do-      let target = stream "divert-black-acuity-good" :: Stream DivertEventStream-      Right (Right appended) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True)-      appended ^. #streamVersion `shouldBe` StreamVersion 1-      result <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert False)-      case result of-        Right (Right commandResult) -> do-          commandResult ^. #streamVersion `shouldBe` StreamVersion 2-          commandResult ^. #eventsAppended `shouldBe` 1-        other ->-          expectationFailure ("expected hydration through the twin to succeed, got " <> show other)-      Right recorded <--        Store.runStoreIO storeHandle $-          Store.readStreamForward (StreamName "divert-black-acuity-good") (StreamVersion 0) 10-      traverse (decodeRecorded divertCodec) (Vector.toList recorded)-        `shouldBe` Right [DivertConfirmed True, DivertConfirmed False]--    it "rejects a new command in the removed region under the twin-bearing machine" $ \storeHandle -> do-      let target = stream "divert-black-acuity-removed" :: Stream DivertEventStream-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True)-      result <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert True)-      result `shouldBe` Right (Left CommandRejected)-      Right recorded <--        Store.runStoreIO storeHandle $-          Store.readStreamForward (StreamName "divert-black-acuity-removed") (StreamVersion 0) 10-      Vector.length recorded `shouldBe` 1--    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 "invalidates a snapshot when the control-state shape changes" $ \storeHandle -> do-      let targetStreamName = StreamName "snapshot-state-shape-change"-          target = stream "snapshot-state-shape-change" :: Stream SnapshotCounterEventStream-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2)-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3)-      lookupResult <--        Store.runStoreIO storeHandle $-          lookupSnapshotSeed-            targetStreamName-            (defaultStateCodec @SnapshotCounterRegs @CounterStateV2 1)-      case lookupResult of-        Right (SnapshotUnavailable SnapshotNotFound) -> pure ()-        _ -> expectationFailure "expected the changed control-state shape to miss the stored snapshot"--    it "uses the fold fingerprint as a snapshot discriminator" $ \storeHandle -> do-      let targetStreamName = StreamName "snapshot-fold-fingerprint-lookup"-          target = stream "snapshot-fold-fingerprint-lookup" :: Stream SnapshotCounterEventStream-          foldV1Codec =-            defaultStateCodecWithFold-              @SnapshotCounterRegs-              @CounterState-              (FoldVersion "fold-v1")-              1-          foldV2Codec =-            defaultStateCodecWithFold-              @SnapshotCounterRegs-              @CounterState-              (FoldVersion "fold-v2")-              1-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2)-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3)-      sameFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV1Codec-      case sameFingerprint of-        Right (SnapshotHit seed) -> seed ^. #streamVersion `shouldBe` StreamVersion 2-        _ -> expectationFailure "expected an equal fold fingerprint to reuse the snapshot"-      changedFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV2Codec-      case changedFingerprint of-        Right (SnapshotUnavailable SnapshotNotFound) -> pure ()-        _ -> expectationFailure "expected a changed fold fingerprint to miss the snapshot"--    it "composes the hand-owned fold version into the state discriminator" $ \_storeHandle -> do-      let plain = defaultStateCodec @SnapshotCounterRegs @CounterState 1-          withFold =-            defaultStateCodecWithFold-              @SnapshotCounterRegs-              @CounterState-              (FoldVersion "fold-v1")-              1-      withFold ^. #stateShapeHash `shouldBe` (plain ^. #stateShapeHash <> ";fold=fold-v1")-      withFold ^. #stateCodecVersion `shouldBe` plain ^. #stateCodecVersion-      withFold ^. #shapeHash `shouldBe` plain ^. #shapeHash--    it "full-replays under a changed fold and persists the new discriminator" $ \storeHandle -> do-      let targetStreamName = "snapshot-fold-fingerprint-e2e"-          target = stream targetStreamName :: Stream SnapshotCounterEventStream-          candidateCodec =-            defaultStateCodecWithFold-              @SnapshotCounterRegs-              @CounterState-              (FoldVersion "fold-v2")-              1-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2)-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3)-      case Keiki.applyEventsEither-        foldV2SnapshotCounterTransducer-        (Counting, RCons (Proxy @"lastAmount") 0 RNil)-        [CounterAdded 2, CounterAdded 3] of-        Right (_, RCons _ fullReplayLastAmount RNil) ->-          fullReplayLastAmount `shouldBe` 4-        Left failure ->-          expectationFailure ("expected full replay under fold v2, got " <> show failure)-      candidateResult <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV2SnapshotCounterEventStream target (Add 104)-      case candidateResult of-        Right (Right result) -> do-          result ^. #streamVersion `shouldBe` StreamVersion 3-          result ^. #eventsAppended `shouldBe` 1-        other -> expectationFailure ("expected changed-fold full replay to accept probe command, got " <> show other)-      Right storedStateShape <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement targetStreamName snapshotStateShapeForStreamStmt-      storedStateShape `shouldBe` Just (candidateCodec ^. #stateShapeHash)--    it "pins the manual-contract hazard when fold logic changes without a discriminator bump" $ \storeHandle -> do-      let targetStreamName = StreamName "snapshot-fold-manual-contract"-          target = stream "snapshot-fold-manual-contract" :: Stream SnapshotCounterEventStream-          unchangedCodec =-            defaultStateCodecWithFold-              @SnapshotCounterRegs-              @CounterState-              (FoldVersion "fold-v1")-              1-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2)-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3)-      staleSeed <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName unchangedCodec-      case staleSeed of-        Right (SnapshotHit seed) ->-          case seed ^. #registers of-            RCons _ staleLastAmount RNil -> staleLastAmount `shouldBe` 3-        _ -> expectationFailure "expected the unchanged discriminator to serve the stale seed"-      residualResult <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV2WithoutFingerprintBumpEventStream target (Add 104)-      residualResult `shouldBe` Right (Left CommandRejected)--    it "samples a stale accepted seed without failing the command or writing a snapshot" $ \storeHandle -> do-      (exporter, metricsRef) <- inMemoryMetricExporter-      (provider, _env) <--        createMeterProvider-          emptyMaterializedResources-          defaultSdkMeterProviderOptions {metricExporter = Just exporter}-      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-      keiroMetrics <- Telemetry.newKeiroMetrics meter-      let targetName = "snapshot-seed-sampled-divergence"-          target = stream targetName :: Stream SnapshotCounterEventStream-          candidateStream :: ValidatedSnapshotCounterEventStream-          candidateStream =-            mkEventStreamOrThrow-              "snapshot-counter-fold-v2-sampled"-              (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never)-          options =-            defaultRunCommandOptions-              & #metrics-              ?~ keiroMetrics-              & #seedVerifySampleRate-              .~ 1-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2)-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3)-      result <--        Store.runStoreIO storeHandle $-          runCommand options candidateStream target (Add 4)-      case result of-        Right (Right commandResult) -> do-          commandResult ^. #streamVersion `shouldBe` StreamVersion 3-          commandResult ^. #eventsAppended `shouldBe` 1-        other -> expectationFailure ("expected sampled verification to stay advisory, got " <> show other)-      observed <--        timeout 5_000_000 $-          let awaitDivergence = do-                _ <- forceFlushMeterProvider provider Nothing-                exported <- readIORef metricsRef-                case lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) of-                  Just (IntNumber 1) -> pure ()-                  _ -> threadDelay 10_000 >> awaitDivergence-           in awaitDivergence-      observed `shouldBe` Just ()-      Right snapshotVersion <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement targetName snapshotVersionForStreamStmt-      snapshotVersion `shouldBe` Just (StreamVersion 2)--    it "disables sampled seed verification at rate zero" $ \storeHandle -> do-      (exporter, metricsRef) <- inMemoryMetricExporter-      (provider, _env) <--        createMeterProvider-          emptyMaterializedResources-          defaultSdkMeterProviderOptions {metricExporter = Just exporter}-      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-      keiroMetrics <- Telemetry.newKeiroMetrics meter-      let targetName = "snapshot-seed-sampling-disabled"-          target = stream targetName :: Stream SnapshotCounterEventStream-          candidateStream :: ValidatedSnapshotCounterEventStream-          candidateStream =-            mkEventStreamOrThrow-              "snapshot-counter-fold-v2-sampling-disabled"-              (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never)-          options =-            defaultRunCommandOptions-              & #metrics-              ?~ keiroMetrics-              & #seedVerifySampleRate-              .~ 0-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2)-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3)-      Right (Right commandResult) <--        Store.runStoreIO storeHandle $-          runCommand options candidateStream target (Add 4)-      commandResult ^. #streamVersion `shouldBe` StreamVersion 3-      threadDelay 100_000-      _ <- forceFlushMeterProvider provider Nothing-      exported <- readIORef metricsRef-      lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) `shouldBe` Nothing-      Right snapshotVersion <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement targetName snapshotVersionForStreamStmt-      snapshotVersion `shouldBe` Just (StreamVersion 2)--    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,-                stateShapeHash = rollbackCodec ^. #stateShapeHash-              }-      Right snapshotVersionAfter <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt-      snapshotVersionAfter `shouldBe` Just (StreamVersion 2)--  describe "Keiro.ReplayAudit" $ around (withFreshStore fixture) $ do-    it "accepts only stream names in the configured category" $ \_ -> do-      ReplayAudit.streamInCategory "counter" (StreamName "counter-one")-        `shouldBe` (Just (Stream.Stream (StreamName "counter-one")) :: Maybe (Stream ()))-      ReplayAudit.streamInCategory "counter" (StreamName "other-one")-        `shouldBe` (Nothing :: Maybe (Stream ()))--    it "catches a removed inverting edge while skipping unaffected streams" $ \storeHandle -> do-      let affectedTarget =-            stream "auditremove-affected" :: Stream CounterEventStream-          unaffectedTarget =-            stream "auditremove-unaffected" :: Stream CounterEventStream-          affected =-            ReplayAudit.AffectedSet-              { affectedEventTypes = Set.singleton (EventType "CounterAdded"),-                includeSnapshotStreams = False-              }-          budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 2-          candidateTarget =-            ReplayAudit.AuditTarget-              { eventStream = auditedCounterEventStream,-                category = "auditremove",-                mkStream = Just . Stream.Stream-              }-          deployedTarget =-            ReplayAudit.AuditTarget-              { eventStream = counterEventStream,-                category = "auditremove",-                mkStream = Just . Stream.Stream-              }-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions counterEventStream affectedTarget (Add 7)-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions auditedCounterEventStream unaffectedTarget (Add 9)--      Right candidateReport <--        Store.runStoreIO storeHandle $-          ReplayAudit.auditStreams-            (ReplayAudit.AuditTargeted affected)-            budget-            candidateTarget-      candidateReport ^. #streamsSelected `shouldBe` 1-      candidateReport ^. #streamsSkipped `shouldBe` 1-      candidateReport ^. #failures `shouldBe` 1-      candidateReport ^. #divergences `shouldBe` 0-      candidateReport ^. #rejectedStreams `shouldBe` []-      case candidateReport ^. #results of-        [ ReplayAudit.StreamAuditResult-            _-            ( ReplayAudit.ReplayFailed-                (HydrationReplayFailed _ HydrationNoInvertingEdge)-              )-          ] -> pure ()-        other ->-          expectationFailure-            ("expected a no-inverting-edge audit failure, got " <> show other)--      Right deployedReport <--        Store.runStoreIO storeHandle $-          ReplayAudit.auditStreams-            (ReplayAudit.AuditTargeted affected)-            budget-            deployedTarget-      ReplayAudit.auditExitCode [deployedReport] `shouldBe` 0--      Right eventsAfterAudit <--        Store.runStoreIO storeHandle $-          Store.readStreamForward-            (StreamName "auditremove-affected")-            (StreamVersion 0)-            10-      Vector.length eventsAfterAudit `shouldBe` 1--    it "proves a replay-only twin preserves the stored guard-tightening history" $ \storeHandle -> do-      let target = stream "divert-audit-replay-only" :: Stream DivertEventStream-          affected =-            ReplayAudit.AffectedSet-              { affectedEventTypes = Set.singleton (EventType "DivertConfirmed"),-                includeSnapshotStreams = False-              }-          budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 1-          auditWith candidate =-            ReplayAudit.auditStreams-              (ReplayAudit.AuditTargeted affected)-              budget-              ReplayAudit.AuditTarget-                { eventStream = candidate,-                  category = "divert",-                  mkStream = Just . Stream.Stream-                }-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True)--      Right withoutTwin <--        Store.runStoreIO storeHandle $-          auditWith tightenedDivertEventStream-      withoutTwin ^. #results-        `shouldBe` [ ReplayAudit.StreamAuditResult-                       (StreamName "divert-audit-replay-only")-                       ( ReplayAudit.ReplayFailed-                           (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge)-                       )-                   ]-      ReplayAudit.auditExitCode [withoutTwin] `shouldBe` 1--      Right withTwin <--        Store.runStoreIO storeHandle $-          auditWith twinDivertEventStream-      withTwin ^. #results-        `shouldBe` [ ReplayAudit.StreamAuditResult-                       (StreamName "divert-audit-replay-only")-                       ReplayAudit.ReplayOk-                         { ReplayAudit.streamVersion = StreamVersion 1,-                           ReplayAudit.digest = Nothing-                         }-                   ]-      ReplayAudit.auditExitCode [withTwin] `shouldBe` 0--    it "reports a stale accepted snapshot seed as a divergence" $ \storeHandle -> do-      let target =-            stream "auditfold-stale" :: Stream SnapshotCounterEventStream-          auditTarget =-            ReplayAudit.AuditTarget-              { eventStream = foldV2WithoutFingerprintBumpEventStream,-                category = "auditfold",-                mkStream = Just . Stream.Stream-              }-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 7)-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 8)--      Right outcome <--        Store.runStoreIO storeHandle $-          ReplayAudit.auditStream auditTarget target-      case outcome of-        ReplayAudit.SeedDivergence-          { seedVersion = StreamVersion 2,-            seededDigest,-            fullDigest-          } ->-            seededDigest `shouldNotBe` fullDigest-        other ->-          expectationFailure-            ("expected a stale-seed divergence, got " <> show other)--    it "keeps clean digests stable and resumes without re-auditing" $ \storeHandle -> do-      let targets =-            [ stream "auditclean-one" :: Stream SnapshotCounterEventStream,-              stream "auditclean-two" :: Stream SnapshotCounterEventStream-            ]-          affected =-            ReplayAudit.AffectedSet-              { affectedEventTypes = Set.singleton (EventType "CounterAdded"),-                includeSnapshotStreams = False-              }-          auditTarget =-            ReplayAudit.AuditTarget-              { eventStream = snapshotCounterEventStream,-                category = "auditclean",-                mkStream = Just . Stream.Stream-              }-          unbounded = ReplayAudit.defaultAuditBudget & #parallelism .~ 2-      for_ (zip targets [10, 20]) $ \(target, amount) -> do-        Right (Right _) <--          Store.runStoreIO storeHandle $-            runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add amount)-        Right (Right _) <--          Store.runStoreIO storeHandle $-            runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add (amount + 1))-        pure ()--      Right firstFull <--        Store.runStoreIO storeHandle $-          ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget-      Right secondFull <--        Store.runStoreIO storeHandle $-          ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget-      firstFull ^. #streamsSelected `shouldBe` 2-      firstFull ^. #streamsSkipped `shouldBe` 0-      firstFull ^. #results `shouldBe` secondFull ^. #results--      Right firstPage <--        Store.runStoreIO storeHandle $-          ReplayAudit.auditStreams-            (ReplayAudit.AuditTargeted affected)-            (unbounded & #maxStreams ?~ 1)-            auditTarget-      firstPage ^. #streamsSelected `shouldBe` 1-      firstPage ^. #checkpoint `shouldSatisfy` isJust-      Right secondPage <--        Store.runStoreIO storeHandle $-          ReplayAudit.auditStreams-            (ReplayAudit.AuditTargeted affected)-            ( unbounded-                & #maxStreams-                ?~ 1-                & #resumeFrom-                .~ (firstPage ^. #checkpoint)-            )-            auditTarget-      secondPage ^. #streamsSelected `shouldBe` 1-      let firstNames = Set.fromList ((^. #streamName) <$> firstPage ^. #results)-          secondNames = Set.fromList ((^. #streamName) <$> secondPage ^. #results)-      Set.disjoint firstNames secondNames `shouldBe` True-      firstNames <> secondNames-        `shouldBe` Set.fromList (Stream.streamName <$> targets)--      Right targeted <--        Store.runStoreIO storeHandle $-          ReplayAudit.auditStreams-            (ReplayAudit.AuditTargeted affected)-            unbounded-            auditTarget-      targeted ^. #results `shouldBe` firstFull ^. #results--  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)-        truthfulResult <--          Store.runStoreIO storeHandle $-            runQueryWithFreshness Nothing Immediate counterImmediateReadModel "inline"-        truthfulResult `shouldBe` queryResult--    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 "returns no subscription position for an empty durable inventory" $ \_ -> do-      let inventory =-            KirokuSub.SubscriptionCheckpointInventory-              (GlobalPosition 17)-              Vector.empty-      subscriptionPositionFromInventory (SubscriptionName "missing") inventory-        `shouldBe` Nothing--    it "returns the newest visible position after a stream is hard deleted" $ \storeHandle -> do-      let target = stream "read-model-captured-head" :: Stream CounterEventStream-      Right (Right commandResult) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions counterEventStream target (Add 1)-      capturedPosition <- case commandResult ^. #globalPosition of-        Just position -> pure position-        Nothing -> expectationFailure "expected command global position" *> error "unreachable"-      Right (Just _) <--        Store.runStoreIO storeHandle $-          Store.hardDeleteStream (StreamName "read-model-captured-head")-      observedHead <- Store.runStoreIO storeHandle storeHeadPosition-      observedHead `shouldBe` Right (GlobalPosition 0)-      Right (KirokuSub.SubscriptionCheckpointInventory authoritativePosition _) <--        Store.runStoreIO storeHandle Store.subscriptionCheckpointInventory-      authoritativePosition `shouldBe` capturedPosition--    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)-      truthfulResult <--        Store.runStoreIO storeHandle $-          runQueryWithFreshness-            Nothing-            (WaitForHead EntireVisibleLog)-            counterCursorReadModel-            "empty"-      truthfulResult `shouldBe` queryResult--    it "rejects truthful waits when an immediate inline model has no cursor" $ \storeHandle -> do-      Right () <--        Store.runStoreIO storeHandle $-          initializeRegisteredReadModel counterImmediateReadModel initializeCounterReadModelTable-      queryResult <--        Store.runStoreIO storeHandle $-          runQueryWithFreshness-            Nothing-            (WaitForHead EntireVisibleLog)-            counterImmediateReadModel-            "inline"-      queryResult-        `shouldBe` Right-          ( Left-              ( ReadModelMissingCursor-                  "counter-read-model"-                  (WaitForHead EntireVisibleLog)-              )-          )--    it "waitFor fails fast on a cursorless model instead of burning the timeout" $ \storeHandle -> do-      (exporter, metricsRef) <- inMemoryMetricExporter-      (provider, _env) <--        createMeterProvider-          emptyMaterializedResources-          defaultSdkMeterProviderOptions {metricExporter = Just exporter}-      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-      keiroMetrics <- Telemetry.newKeiroMetrics meter-      startedAt <- getCurrentTime-      waitResult <--        Store.runStoreIO storeHandle $-          waitFor (Just keiroMetrics) defaultHeadWaitOptions counterImmediateReadModel (GlobalPosition 5)-      finishedAt <- getCurrentTime-      waitResult-        `shouldBe` Right-          ( Left-              ( ReadModelMissingCursor-                  "counter-read-model"-                  (WaitForPosition (defaultHeadWaitOptions & #target ?~ GlobalPosition 5))-              )-          )-      diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2)-      _ <- forceFlushMeterProvider provider Nothing-      exported <- readIORef metricsRef-      lookup "keiro.projection.wait.timeouts" (flattenScalarPoints exported) `shouldBe` Nothing--    it "deprecated Strong and PositionWait overrides fail fast on a cursorless model" $ \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 counterImmediateReadModel initializeCounterReadModelTable-      let target = stream "read-model-cursorless-strong" :: Stream CounterEventStream-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand defaultRunCommandOptions counterEventStream target (Add 5)-      startedAt <- getCurrentTime-      strongResult <--        Store.runStoreIO storeHandle $-          runQueryWith (Just keiroMetrics) Strong counterImmediateReadModel "inline"-      finishedAt <- getCurrentTime-      strongResult-        `shouldBe` Right-          (Left (ReadModelMissingCursor "counter-read-model" (WaitForHead EntireVisibleLog)))-      diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2)-      truthfulResult <--        Store.runStoreIO storeHandle $-          runQueryWithFreshness Nothing (WaitForHead EntireVisibleLog) counterImmediateReadModel "inline"-      truthfulResult `shouldBe` strongResult-      positionResult <--        Store.runStoreIO storeHandle $-          runQueryWith-            (Just keiroMetrics)-            (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5)))-            counterImmediateReadModel-            "inline"-      positionResult-        `shouldBe` Right-          ( Left-              ( ReadModelMissingCursor-                  "counter-read-model"-                  (WaitForPosition (fastWaitOptions & #target .~ Just (GlobalPosition 5)))-              )-          )-      _ <- forceFlushMeterProvider provider Nothing-      exported <- readIORef metricsRef-      lookup "keiro.projection.wait.timeouts" (flattenScalarPoints exported) `shouldBe` Nothing--    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 and WaitForHead return promptly after workflow GC hard-deletes the newest events" $ \_ ->-      withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do-        Right () <--          Store.runStoreIO storeHandle $-            initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-        Right (Right commandResult) <--          runner $-            runCommandWithProjections-              defaultRunCommandOptions-              counterEventStream-              (stream "read-model-gc-strong" :: Stream CounterEventStream)-              (Add 5)-              [counterInlineProjection]-        visiblePosition <- 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 visiblePosition)-                upsertSubscriptionCursorStmt--        counter <- newIORef (0 :: Int)-        Right (Completed _) <--          Store.runStoreIO storeHandle $-            runWorkflowWith-              (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal)-              (WorkflowName "gc-strong-wf")-              (WorkflowId "gsw-1")-              (demoWorkflow counter)-        now <- getCurrentTime-        Right summary <--          Store.runStoreIO storeHandle $-            WorkflowGc.gcWorkflowsOnce-              (addUTCTime 1 now)-              WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10}-        summary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1}--        observedHead <- Store.runStoreIO storeHandle storeHeadPosition-        observedHead `shouldBe` Right visiblePosition-        Right (KirokuSub.SubscriptionCheckpointInventory authoritativePosition _) <--          Store.runStoreIO storeHandle Store.subscriptionCheckpointInventory-        authoritativePosition `shouldSatisfy` (> visiblePosition)--        startedAt <- getCurrentTime-        queryResult <--          Store.runStoreIO storeHandle $-            runQueryWith Nothing Strong counterReadModel "inline"-        finishedAt <- getCurrentTime-        queryResult `shouldBe` Right (Right 5)-        diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2)--        truthfulStartedAt <- getCurrentTime-        truthfulResult <--          Store.runStoreIO storeHandle $-            runQueryWithFreshness-              Nothing-              (WaitForHead EntireVisibleLog)-              counterCursorReadModel-              "inline"-        truthfulFinishedAt <- getCurrentTime-        truthfulResult `shouldBe` queryResult-        diffUTCTime truthfulFinishedAt truthfulStartedAt `shouldSatisfy` (< 2)--    it "Strong and WaitForHead still time out when visible events outrun the subscription" $ \_ ->-      withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do-        Right () <--          Store.runStoreIO storeHandle $-            initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable-        Right (Right commandResult) <--          runner $-            runCommandWithProjections-              defaultRunCommandOptions-              counterEventStream-              (stream "read-model-strong-visible-behind" :: Stream CounterEventStream)-              (Add 5)-              [counterInlineProjection]-        visiblePosition <- case commandResult ^. #globalPosition of-          Just position -> pure position-          Nothing -> expectationFailure "expected command global position" *> error "unreachable"-        queryResult <--          Store.runStoreIO storeHandle $-            runQueryWith Nothing Strong counterReadModel "inline"-        queryResult-          `shouldBe` Right-            ( Left-                ( ReadModelWaitTimeout-                    "counter-read-model"-                    visiblePosition-                    (GlobalPosition 0)-                )-            )-        truthfulResult <--          Store.runStoreIO storeHandle $-            runQueryWithFreshness-              Nothing-              (WaitForHead EntireVisibleLog)-              counterCursorReadModel-              "inline"-        truthfulResult `shouldBe` queryResult--    it "Strong and WaitForHead return when their 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)-        truthfulResult <--          Store.runStoreIO storeHandle $-            runQueryWithFreshness-              Nothing-              (WaitForHead (CategoryVisibleHead "counter"))-              counterCursorReadModel-              "inline"-        truthfulResult `shouldBe` queryResult--    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)-        truthfulResult <--          Store.runStoreIO storeHandle $-            runQueryWithFreshness-              Nothing-              (WaitForPosition (fastWaitOptions & #target .~ Just globalPosition))-              counterCursorReadModel-              "inline"-        truthfulResult `shouldBe` queryResult--    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)))-      truthfulResult <--        Store.runStoreIO storeHandle $-          runQueryWithFreshness-            Nothing-            (WaitForPosition (fastWaitOptions & #target .~ Just (GlobalPosition 5)))-            counterCursorReadModel-            "timeout"-      truthfulResult `shouldBe` queryResult--    it "rejects a truthful position wait without a target" $ \storeHandle -> do-      Right () <--        Store.runStoreIO storeHandle $-          initializeRegisteredReadModel counterCursorReadModel initializeCounterReadModelTable-      queryResult <--        Store.runStoreIO storeHandle $-          runQueryWithFreshness-            Nothing-            (WaitForPosition fastWaitOptions)-            counterCursorReadModel-            "missing-target"-      queryResult-        `shouldBe` Right (Left (ReadModelMissingPosition "counter-read-model"))--    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 "startRebuild on a cursorless model skips the checkpoint reset and completes" $ \storeHandle -> do-      Right () <--        Store.runStoreIO storeHandle $-          initializeRegisteredReadModel-            counterCursorlessRebuildReadModel-            initializeCounterReadModelTable-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $ do-            Tx.sql "INSERT INTO counter_read_model (model_id, amount, last_seen) VALUES ('inline', 9, 1)"-            Tx.statement ("counter-read-model-sub", 7) upsertSubscriptionCursorStmt-      rebuildingResult <--        Store.runStoreIO storeHandle $-          Rebuild.startRebuild counterCursorlessRebuildReadModel [] (GlobalPosition 0)-      rebuilding <- case rebuildingResult of-        Right metadata -> pure metadata-        Left err -> expectationFailure ("cursorless startRebuild failed: " <> show err) *> error "unreachable"-      rebuilding ^. #status `shouldBe` Rebuilding-      untouched <--        Store.runStoreIO storeHandle $-          readSubscriptionPosition "counter-read-model-sub"-      untouched `shouldBe` Right (Just (GlobalPosition 7))-      Right (Right live) <--        Store.runStoreIO storeHandle $-          Rebuild.finishRebuild counterCursorlessRebuildReadModel [] (GlobalPosition 0)-      live ^. #status `shouldBe` Live-      afterRebuild <--        Store.runStoreIO storeHandle $-          runQuery Nothing counterCursorlessRebuildReadModel "inline"-      afterRebuild `shouldBe` Right (Right 0)--    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 matching global position distance and projection lag gauges" $ \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 both the preferred and-      -- compatibility gauges record the same non-negative position distance.-      Right () <--        Store.runStoreIO storeHandle $-          recordProjectionGlobalPositionDistance (Just keiroMetrics) counterAsyncProjection-      _ <- forceFlushMeterProvider provider Nothing-      exported <- readIORef metricsRef-      let scalars = flattenScalarPoints exported-          preferred = lookup "keiro.projection.global_position_distance" scalars-          compatibility = lookup "keiro.projection.lag" scalars-      preferred `shouldBe` compatibility-      case preferred of-        Just (IntNumber n) -> n `shouldSatisfy` (>= 1)-        other -> expectationFailure ("expected an integer global position distance, got " <> show other)--    it "reports zero global position distance after the newest events are hard deleted" $ \storeHandle -> do-      (exporter, metricsRef) <- inMemoryMetricExporter-      (provider, _env) <--        createMeterProvider-          emptyMaterializedResources-          defaultSdkMeterProviderOptions {metricExporter = Just exporter}-      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary-      keiroMetrics <- Telemetry.newKeiroMetrics meter-      Right (Right survivorResult) <--        Store.runStoreIO storeHandle $-          runCommand-            defaultRunCommandOptions-            counterEventStream-            (stream "gauge-gc-survivor" :: Stream CounterEventStream)-            (Add 1)-      survivorPosition <- case survivorResult ^. #globalPosition of-        Just position -> pure position-        Nothing -> expectationFailure "expected survivor global position" *> error "unreachable"-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement-              ("counter-read-model-sub", globalPositionToInt survivorPosition)-              upsertSubscriptionCursorStmt-      Right (Right _) <--        Store.runStoreIO storeHandle $-          runCommand-            defaultRunCommandOptions-            counterEventStream-            (stream "gauge-gc-victim" :: Stream CounterEventStream)-            (Add 1)-      Right (Just _) <--        Store.runStoreIO storeHandle $-          Store.hardDeleteStream (StreamName "gauge-gc-victim")-      Right () <--        Store.runStoreIO storeHandle $-          recordProjectionGlobalPositionDistance (Just keiroMetrics) counterAsyncProjection-      _ <- forceFlushMeterProvider provider Nothing-      exported <- readIORef metricsRef-      let scalars = flattenScalarPoints exported-      lookup "keiro.projection.global_position_distance" scalars-        `shouldBe` Just (IntNumber 0)-      lookup "keiro.projection.lag" scalars-        `shouldBe` Just (IntNumber 0)--    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 "bridges a pre-UTF-8 process-manager state and command redelivery" $ \(storeHandle, StoreRunner _runner) -> do-      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-          correlationId = "\x4E2D\x6587-42"-          managerStreamName = StreamName "pm:counter-unicode"-          targetStreamName = StreamName "counter-target-unicode"-          legacyManagerId = legacyDeterministicCommandId "unicode-pm" correlationId (sourceEvent ^. #eventId) (-1)-          legacyCommandId = legacyDeterministicCommandId "unicode-pm" correlationId (sourceEvent ^. #eventId) 0-      appendCounterEventWithId storeHandle managerStreamName legacyManagerId (CounterAdded 9)-      appendCounterEventWithId storeHandle targetStreamName legacyCommandId (CounterAdded 9)-      Right (Right pmResult) <--        _runner $-          runProcessManagerOnce defaultRunCommandOptions unicodeCounterProcessManager sourceEvent (CounterAdded 9)-      Right managerEvents <- _runner $ Store.readStreamForward managerStreamName (StreamVersion 0) 10-      Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10-      ( pmResult ^. #managerResult,-        pmResult ^. #commandResults,-        Vector.length managerEvents,-        Vector.length targetEvents-        )-        `shouldBe` ( PMStateDuplicate legacyManagerId,-                     [PMCommandDuplicate legacyCommandId],-                     1,-                     1-                   )--    it "bridges a pre-UTF-8 domain process-manager state and command redelivery" $ \(storeHandle, StoreRunner _runner) -> do-      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-          correlationId = "\x4E2D\x6587-9"-          managerStreamName = StreamName ("domain-pm:" <> correlationId)-          targetStreamName = StreamName ("domain-pm-target:" <> correlationId <> ":0")-          legacyManagerId = legacyDeterministicCommandId "domain-pm" correlationId (sourceEvent ^. #eventId) (-1)-          legacyCommandId = legacyDeterministicCommandId "domain-pm" correlationId (sourceEvent ^. #eventId) 0-          input = DomainDispatchInput correlationId [CoordinatorAccept 9]-      appendCounterEventWithId storeHandle managerStreamName legacyManagerId (CounterAdded 1)-      appendCounterEventWithId storeHandle targetStreamName legacyCommandId (CounterAdded 9)-      Right (Right pmResult) <--        _runner $-          runDomainProcessManagerOnce defaultRunCommandOptions domainProcessManager sourceEvent input-      Right managerEvents <- _runner $ Store.readStreamForward managerStreamName (StreamVersion 0) 10-      Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10-      ( pmResult ^. #managerResult,-        pmResult ^. #commandResults,-        Vector.length managerEvents,-        Vector.length targetEvents-        )-        `shouldBe` ( PMStateDuplicate legacyManagerId,-                     [DomainPMCommandDuplicate legacyCommandId],-                     1,-                     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)-      -- kiroku-store 0.8.0.0 types class-40 rollbacks separately from-      -- UnexpectedServerError. The transaction rolled back completely and-      -- nothing was committed, so the source event retries rather than halting-      -- the subscription; every other server code still halts.-      ackForCommandError-        (RetryDelay 5)-        (StoreFailed (Store.TransientTransactionFailure "40001" "could not serialize access"))-        `shouldBe` AckRetry (RetryDelay 5)-      ackForCommandError-        (RetryDelay 5)-        (StoreFailed (Store.TransientTransactionFailure "40P01" "deadlock detected"))-        `shouldBe` AckRetry (RetryDelay 5)-      ackForCommandError (RetryDelay 5) (StoreFailed (Store.UnexpectedServerError "XX000" "boom"))-        `shouldSatisfy` \case-          AckHalt (HaltFatal _) -> True-          _ -> False-      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 "RouterSelection validates positive runtime invariants" $ \(_storeHandle, StoreRunner _runner) -> do-      mkRecipientLimit 0 `shouldSatisfy` \case Left _ -> True; Right _ -> False-      mkSelectionVersion 0 `shouldSatisfy` \case Left _ -> True; Right _ -> False-      limit <- shouldBeRight (mkRecipientLimit 2)-      selectionVersion <- shouldBeRight (mkSelectionVersion 3)-      recipientLimitValue limit `shouldBe` 2-      selectionVersionValue selectionVersion `shouldBe` 3--    it "RouterSelection sorts, deduplicates, caps, and rejects conflicts before dispatch" $ \(_storeHandle, StoreRunner _runner) -> do-      limit <- shouldBeRight (mkRecipientLimit 2)-      one <- shouldBeRight (mkRecipientLimit 1)-      let targetA = PMCommand {target = stream "selection-a", command = Add 1}-          targetB = PMCommand {target = stream "selection-b", command = Add 1}-          targetBConflict = PMCommand {target = stream "selection-b", command = Add 2}-      normalizeRecipients limit [targetB, targetA, targetB]-        `shouldBe` Right [targetA, targetB]-      normalizeRecipients limit [targetB, targetBConflict, targetA]-        `shouldBe` Left (SelectionConflictingCommands (StreamName "selection-b"))-      normalizeRecipients one [targetB, targetA, targetB]-        `shouldBe` Left (SelectionRecipientOverflow one 2)-      normalizeRecipients limit [targetB, targetA]-        `shouldBe` Right [targetA, targetB]--    it "RouterSelection exposes stable public dead-letter code, detail, and rendering" $ \(_storeHandle, StoreRunner _runner) -> do-      contract <- testSelectionContract EmptyDeadLetter FailureDeadLetter 4-      recipientLimit <- shouldBeRight (mkRecipientLimit 4)-      let failures =-            [ (SelectionQueryFailed "secret backend detail", "keiro.router.selection.query_failed"),-              (SelectionEvaluationFailed "secret payload", "keiro.router.selection.evaluation_failed"),-              (SelectionConflictingCommands (StreamName "hospital-1"), "keiro.router.selection.target_conflict"),-              (SelectionRecipientOverflow recipientLimit 5, "keiro.router.selection.recipient_overflow")-            ]-          assertReason expectedCode reason = do-            deadLetterCodeText (deadLetterReasonCode reason) `shouldBe` expectedCode-            deadLetterReasonDetail reason `shouldSatisfy` maybe False (not . Text.null)-            renderDeadLetterReason reason `shouldSatisfy` Text.isPrefixOf (expectedCode <> ": ")-      assertReason "keiro.router.selection.empty" (emptySelectionDeadLetterReason contract)-      for_ failures $ \(failure, expectedCode) -> do-        let reason = selectionFailureDeadLetterReason contract failure-        assertReason expectedCode reason-        renderDeadLetterReason reason `shouldNotSatisfy` Text.isInfixOf "secret"--    it "RouterSelection performs no target callback on conflict or overflow and dispatches exactly at the cap" $ \(_storeHandle, StoreRunner _runner) -> do-      twoRecipientContract <- testSelectionContract EmptyAck FailureRetry 2-      oneRecipientContract <- testSelectionContract EmptyAck FailureRetry 1-      callbacks <- newIORef (0 :: Int)-      let options = defaultRunCommandOptions & #beforeAppend .~ modifyIORef' callbacks (+ 1)-          sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-          targetA = PMCommand {target = stream "bounded-a", command = Add 1}-          targetB = PMCommand {target = stream "bounded-b", command = Add 1}-          targetBConflict = PMCommand {target = stream "bounded-b", command = Add 2}-      Right conflict <--        _runner $-          runDeclarativeRouterOnce-            options-            (selectionRouter twoRecipientContract (pure (Right [targetB, targetBConflict, targetA])))-            sourceEvent-            (RouteGroup "g1")-      conflict `shouldBe` DeclarativeSelectionFailed (SelectionConflictingCommands (StreamName "bounded-b"))-      readIORef callbacks `shouldReturn` 0-      Right overflow <--        _runner $-          runDeclarativeRouterOnce-            options-            (selectionRouter oneRecipientContract (pure (Right [targetB, targetA, targetB])))-            sourceEvent-            (RouteGroup "g1")-      overflow `shouldBe` DeclarativeSelectionFailed (SelectionRecipientOverflow (oneRecipientContract ^. #limit) 2)-      readIORef callbacks `shouldReturn` 0-      Right atCap <--        _runner $-          runDeclarativeRouterOnce-            options-            (selectionRouter twoRecipientContract (pure (Right [targetB, targetA, targetB])))-            sourceEvent-            (RouteGroup "g1")-      atCap `shouldSatisfy` \case-        DeclarativeSelectionDispatched (RouterResult results) -> length results == 2 && all isAppended results-        _ -> False-      readIORef callbacks `shouldReturn` 2--    it "RouterSelection retains successful targets after a later target dispatch fails" $ \(_storeHandle, StoreRunner _runner) -> do-      contract <- testSelectionContract EmptyAck FailureRetry 2-      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-          router =-            selectionRouter contract (pure (Right [PMCommand {target = stream "partial-a", command = Add 1}, PMCommand {target = stream "partial-b", command = Add 9}]))-              & #targetEventStream-              .~ rejectNineEventStream-      Right result <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1"))-      result `shouldSatisfy` \case-        DeclarativeSelectionDispatched (RouterResult [first, second]) -> isAppended first && isFailed second-        _ -> False-      Right partialA <- _runner (Store.readStreamForward (StreamName "partial-a") (StreamVersion 0) 10)-      Right partialB <- _runner (Store.readStreamForward (StreamName "partial-b") (StreamVersion 0) 10)-      Vector.length partialA `shouldBe` 1-      Vector.length partialB `shouldBe` 0--    it "RouterSelection preserves target-keyed stable union across result drift" $ \(_storeHandle, StoreRunner _runner) -> do-      contract <- testSelectionContract EmptyAck FailureRetry 2-      attempts <- newIORef (0 :: Int)-      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-          selectAttempt _ = do-            attempt <- liftIO (atomicModifyIORef' attempts (\value -> (value + 1, value)))-            pure $ Right $ case attempt of-              0 -> commandsFor ["union-b", "union-a"]-              _ -> commandsFor ["union-c", "union-a"]-          commandsFor targetNames = [PMCommand {target = stream targetName, command = Add 1} | targetName <- targetNames]-          router = (selectionRouter contract (pure (Right []))) {select = selectAttempt}-      Right first <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1"))-      Right second <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1"))-      first `shouldSatisfy` \case-        DeclarativeSelectionDispatched (RouterResult results) -> all isAppended results-        _ -> False-      second `shouldSatisfy` \case-        DeclarativeSelectionDispatched (RouterResult [unionA, unionC]) -> isDuplicate unionA && isAppended unionC-        _ -> False-      for_ ["union-a", "union-b", "union-c"] $ \targetName -> do-        Right events <- _runner (Store.readStreamForward (StreamName targetName) (StreamVersion 0) 10)-        Vector.length events `shouldBe` 1--    it "RouterSelection worker lowers the complete empty and failure policy matrices" $ \(_storeHandle, StoreRunner _runner) -> do-      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-          message = (sourceEvent, RouteGroup "g1")-          runCase emptySelectionPolicy failureSelectionPolicy selected = do-            contract <- testSelectionContract emptySelectionPolicy failureSelectionPolicy 2-            decisions <- newIORef []-            Right () <--              _runner $-                runDeclarativeRouterWorker-                  defaultRunCommandOptions-                  (selectionRouter contract (pure selected))-                  (inMemoryAdapter decisions [message])-                  Just-            readIORef decisions-      runCase EmptyAck FailureRetry (Right []) `shouldReturn` [AckOk]-      runCase EmptyRetry FailureRetry (Right []) `shouldReturn` [AckRetry (RetryDelay 5)]-      emptyDeadLetter <- runCase EmptyDeadLetter FailureRetry (Right [])-      emptyDeadLetter `shouldSatisfy` \case-        [AckDeadLetter reason] -> deadLetterCodeText (deadLetterReasonCode reason) == "keiro.router.selection.empty"-        _ -> False-      emptyHalt <- runCase EmptyHalt FailureRetry (Right [])-      emptyHalt `shouldSatisfy` \case [AckHalt {}] -> True; _ -> False-      runCase EmptyAck FailureRetry (Left (SelectionQueryFailed "private")) `shouldReturn` [AckRetry (RetryDelay 5)]-      failureDeadLetter <- runCase EmptyAck FailureDeadLetter (Left (SelectionEvaluationFailed "private"))-      failureDeadLetter `shouldSatisfy` \case-        [AckDeadLetter reason] -> deadLetterCodeText (deadLetterReasonCode reason) == "keiro.router.selection.evaluation_failed"-        _ -> False-      failureHalt <- runCase EmptyAck FailureHalt (Left (SelectionQueryFailed "private"))-      failureHalt `shouldSatisfy` \case [AckHalt {}] -> True; _ -> False--    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--    it "bridges a pre-UTF-8 positional router redelivery with a non-ASCII key" $ \(storeHandle, StoreRunner _runner) -> do-      Right () <--        _runner $-          initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable-      let correlationId = "g-\x4E2D\x6587"-          targetStreamName = StreamName "transition-unicode-target"-          sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)-          legacyId = legacyDeterministicCommandId "demo-router" correlationId (sourceEvent ^. #eventId) 0-      Right () <--        _runner $-          Store.runTransaction (Tx.statement (correlationId, "transition-unicode-target") insertRouterTargetStmt)-      appendCounterEventWithId storeHandle targetStreamName legacyId (CounterAdded 1)-      Right (RouterResult results) <--        _runner $-          runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup correlationId)-      Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10-      (results, Vector.length targetEvents)-        `shouldBe` ([PMCommandDuplicate legacyId], 1)--    it "bridges a pre-UTF-8 domain router redelivery with a non-ASCII key" $ \(storeHandle, StoreRunner _runner) -> do-      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)-          correlationId = "\x4E2D\x6587-9"-          targetStreamName = StreamName ("domain-router-target:" <> correlationId <> ":0")-          legacyId = legacyDeterministicCommandId "domain-router" correlationId (sourceEvent ^. #eventId) 0-          input = DomainDispatchInput correlationId [CoordinatorAccept 9]-      appendCounterEventWithId storeHandle targetStreamName legacyId (CounterAdded 9)-      Right (DomainRouterResult results) <--        _runner $-          runDomainRouterOnce defaultRunCommandOptions domainRouter sourceEvent input-      Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10-      (results, Vector.length targetEvents)-        `shouldBe` ([DomainPMCommandDuplicate legacyId], 1)--  describe "Keiro.Timer foreground consumer"-    $ around-      ( \action ->-          withFreshDatabase fixture $ \connection ->-            Store.withStore (Store.defaultConnectionSettings connection) $ \firstStore ->-              Store.withStore (Store.defaultConnectionSettings connection) $ \secondStore ->-                action (firstStore, secondStore)-      )-    $ do-      it "preflights original work and invokes one callback for competing authorized resumes" $ \(firstStore, secondStore) -> do-        let original = counterTimerRequest & #payload .~ object ["memorySpace" Aeson..= ("space-a" :: Text)]-            tid = original ^. #timerId-            owner = original ^. #processManagerName-            reason = "deferred: interactive session required"-        callbacks <- newIORef (0 :: Int)-        let foreground store allowed available = do-              Right _ <- Store.runStoreIO store recoverExpiredTimerResumes-              Right inspected <- Store.runStoreIO store $ lookupTimerInspection tid-              case inspected of-                Just inspection-                  | inspection ^. #lastError == Just reason,-                    inspection ^. #timer . #payload == object ["memorySpace" Aeson..= ("space-a" :: Text)],-                    allowed,-                    available -> do-                      Right (Right claimed) <- Store.runStoreIO store $ claimDeadTimer (DeadTimerClaimRequest tid owner reason 3 60)-                      forM_ claimed $ \_ -> atomicModifyIORef' callbacks (\n -> (n + 1, ()))-                      pure claimed-                _ -> pure Nothing-        Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ scheduleTimerTx original-        Right True <- Store.runStoreIO firstStore $ deadLetterTimer tid reason-        Right before <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt-        -- Revocation after listing and repeated unavailable-session preflights.-        Right (Right _) <- Store.runStoreIO firstStore $ findDeadTimers (DeadTimerFilter (Just owner) (ReasonExact reason)) (DeadTimerPageRequest 10 Nothing)-        denied <- foreground firstStore False True-        isNothing denied `shouldBe` True-        forM_ [1 .. 3 :: Int] $ \_ -> do-          unavailable <- foreground firstStore True False-          isNothing unavailable `shouldBe` True-        Store.runStoreIO firstStore (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before-        (a, b) <- timerRaceIO (foreground firstStore True True) (foreground secondStore True True)-        length (catMaybes [a, b]) `shouldBe` 1-        readIORef callbacks `shouldReturn` 1-        -- Crash, deterministic expiry, and recovery keep interactive work parked.-        Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx-        Store.runStoreIO secondStore recoverExpiredTimerResumes `shouldReturn` Right 1-        Store.runStoreIO firstStore (runTimerWorker Nothing dueTimerTime (\_ -> error "interactive work dispatched in background")) `shouldReturn` Right Nothing-        unavailable <- foreground firstStore True False-        isNothing unavailable `shouldBe` True-        Just next <- foreground secondStore True True-        resumeClaimTimer next ^. #timerId `shouldBe` tid-        resumeClaimTimer next ^. #attempts `shouldBe` 2-        -- A transient post-claim failure consumes the attempt and retains reason.-        Store.runStoreIO secondStore (parkTimerResume next) `shouldReturn` Right True-        Right (Just parked) <- Store.runStoreIO firstStore $ lookupTimerInspection tid-        parked ^. #lastError `shouldBe` Just reason-        parked ^. #timer . #attempts `shouldBe` 2-        -- Malformed work and ordinary dead letters are application refusals.-        Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.sql "UPDATE keiro.keiro_timers SET payload = '{}'::jsonb"-        malformed <- foreground firstStore True True-        isNothing malformed `shouldBe` True-        Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.sql "UPDATE keiro.keiro_timers SET last_error = 'ordinary dead letter'"-        ordinary <- foreground firstStore True True-        isNothing ordinary `shouldBe` True-        readIORef callbacks `shouldReturn` 2--      it "orders renewal and completion against recovery on independent stores" $ \(firstStore, secondStore) -> do-        let tid = counterTimerRequest ^. #timerId-            request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 3 60-        Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ scheduleTimerTx counterTimerRequest-        Right True <- Store.runStoreIO firstStore $ deadLetterTimer tid "deferred"-        Right (Right (Just claim)) <- Store.runStoreIO firstStore $ claimDeadTimer request-        (renewed, recovered) <--          timerRaceIO-            (Store.runStoreIO firstStore $ renewTimerResume claim 60)-            (Store.runStoreIO secondStore recoverExpiredTimerResumes)-        renewed `shouldBe` Right (Right True)-        recovered `shouldBe` Right 0-        Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx-        (expiredRenewal, expiredRecovery) <--          timerRaceIO-            (Store.runStoreIO firstStore $ renewTimerResume claim 60)-            (Store.runStoreIO secondStore recoverExpiredTimerResumes)-        expiredRenewal `shouldBe` Right (Right False)-        expiredRecovery `shouldBe` Right 1-        Right (Right (Just replacement)) <- Store.runStoreIO firstStore $ claimDeadTimer request-        Right before <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt-        forM_ [parkTimerResume claim, cancelTimerResume claim, completeTimerResume claim (EventId sampleUuid2)] $ \operation ->-          Store.runStoreIO firstStore operation `shouldReturn` Right False-        Store.runStoreIO firstStore (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before-        Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx-        (expiredCompletion, completionRecovery) <--          timerRaceIO-            (Store.runStoreIO firstStore $ completeTimerResume replacement (EventId sampleUuid2))-            (Store.runStoreIO secondStore recoverExpiredTimerResumes)-        expiredCompletion `shouldBe` Right False-        completionRecovery `shouldBe` Right 1-        Right (Right (Just finalClaim)) <- Store.runStoreIO firstStore $ claimDeadTimer request-        (completed, noRecovery) <--          timerRaceIO-            (Store.runStoreIO firstStore $ completeTimerResume finalClaim (EventId sampleUuid2))-            (Store.runStoreIO secondStore recoverExpiredTimerResumes)-        completed `shouldBe` Right True-        noRecovery `shouldBe` Right 0--  describe "Keiro.Timer" $ around (withFreshStore fixture) $ do-    it "guards dead resume ownership and retains attempts when parked" $ \storeHandle -> do-      let tid = counterTimerRequest ^. #timerId-          request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 2 60-      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest-      Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred"-      Right (Right (Just claim)) <- Store.runStoreIO storeHandle $ claimDeadTimer request-      resumeClaimTimer claim ^. #attempts `shouldBe` 1-      Store.runStoreIO storeHandle (claimDueTimer dueTimerTime) `shouldReturn` Right Nothing-      Store.runStoreIO storeHandle (markTimerFired tid (EventId sampleUuid2)) `shouldReturn` Right False-      Store.runStoreIO storeHandle (cancelTimer tid) `shouldReturn` Right False-      Store.runStoreIO storeHandle (deadLetterTimer tid "wrong") `shouldReturn` Right False-      Store.runStoreIO storeHandle (requeueStuckTimer tid) `shouldReturn` Right False-      Store.runStoreIO storeHandle (requeueStuckTimers 0 (resumeClaimLeaseUntil claim)) `shouldReturn` Right 0-      Store.runStoreIO storeHandle (renewTimerResume claim 60) `shouldReturn` Right (Right True)-      Store.runStoreIO storeHandle (parkTimerResume claim) `shouldReturn` Right True-      Right (Right (Just replacement)) <- Store.runStoreIO storeHandle $ claimDeadTimer request-      resumeClaimTimer replacement ^. #attempts `shouldBe` 2-      Store.runStoreIO storeHandle (completeTimerResume claim (EventId sampleUuid2)) `shouldReturn` Right False-      Store.runStoreIO storeHandle (parkTimerResume claim) `shouldReturn` Right False-      Store.runStoreIO storeHandle (cancelTimerResume claim) `shouldReturn` Right False-      Store.runStoreIO storeHandle (renewTimerResume claim 60) `shouldReturn` Right (Right False)-      Store.runStoreIO storeHandle (parkTimerResume replacement) `shouldReturn` Right True-      Right (Right refused) <- Store.runStoreIO storeHandle $ claimDeadTimer request-      isNothing refused `shouldBe` True-      Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid-      observed ^. #lastError `shouldBe` Just "deferred"-      observed ^. #timer . #attempts `shouldBe` 2--    it "refuses every ineligible claim without changing any persisted column" $ \storeHandle -> do-      let tid = counterTimerRequest ^. #timerId-          request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 1 60-          snapshot = Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt-          refused req = do-            before <- snapshot-            Right (Right result) <- Store.runStoreIO storeHandle $ claimDeadTimer req-            isNothing result `shouldBe` True-            snapshot `shouldReturn` before-      refused request-      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest-      refused request-      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime-      refused request-      Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred"-      refused (request & #processManagerName .~ "COUNTER")-      refused (request & #expectedReason .~ "Deferred")-      refused (request & #maxAttempts .~ 0)-      refused request -- ordinary claim already consumed the ceiling-      before <- snapshot-      Right (Left badMax) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #maxAttempts .~ (-1))-      badMax `shouldBe` InvalidTimerResumeMaxAttempts (-1)-      forM_ [0, -1, maxBound] $ \seconds -> do-        Right (Left badLease) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #leaseSeconds .~ seconds)-        badLease `shouldBe` InvalidTimerResumeLeaseSeconds seconds-      snapshot `shouldReturn` before-      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement (case tid of TimerId uuid -> uuid) legacyDeadTimerReasonStmt-      refused (request & #maxAttempts .~ 2)--    it "claims literal empty and Unicode reasons and preserves original work" $ \storeHandle -> do-      forM_ (zip [1 ..] ["", "延期: café 日本語 🌱", "a%_\\'雪"]) $ \(n, reason) -> do-        let original = counterTimerRequest & #timerId .~ TimerId (UUID.fromWords 0 0 0 n)-            tid = original ^. #timerId-            request = DeadTimerClaimRequest tid (original ^. #processManagerName) reason 1 60-        Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx original-        Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid reason-        Right (Just before) <- Store.runStoreIO storeHandle $ lookupTimer tid-        Right (Right (Just claim)) <- Store.runStoreIO storeHandle $ claimDeadTimer request-        resumeClaimTimer claim `shouldBe` (before & #status .~ Firing & #attempts .~ 1)-        Right (Right repeated) <- Store.runStoreIO storeHandle $ claimDeadTimer request-        isNothing repeated `shouldBe` True-        Store.runStoreIO storeHandle (completeTimerResume claim (EventId sampleUuid2)) `shouldReturn` Right True-        Right (Just inspection) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid-        inspection ^. #lastError `shouldBe` Just reason-        inspection ^. #timer . #firedEventId `shouldBe` Just (EventId sampleUuid2)-        Right (Right terminal) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #maxAttempts .~ 2)-        isNothing terminal `shouldBe` True--    it "expires without revival and re-parks independently of ordinary recovery" $ \storeHandle -> do-      let tid = counterTimerRequest ^. #timerId-          request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 3 60-      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest-      Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred"-      Right (Right (Just old)) <- Store.runStoreIO storeHandle $ claimDeadTimer request-      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction expireTimerResumesTx-      Right before <- Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt-      Store.runStoreIO storeHandle (renewTimerResume old 60) `shouldReturn` Right (Right False)-      Store.runStoreIO storeHandle (completeTimerResume old (EventId sampleUuid2)) `shouldReturn` Right False-      Store.runStoreIO storeHandle (parkTimerResume old) `shouldReturn` Right False-      Store.runStoreIO storeHandle (cancelTimerResume old) `shouldReturn` Right False-      Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before-      let options = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing-      Store.runStoreIO storeHandle (runTimerWorkerWith Nothing options dueTimerTime (\_ -> error "foreground work reached background")) `shouldReturn` Right Nothing-      Store.runStoreIO storeHandle recoverExpiredTimerResumes `shouldReturn` Right 0-      Right (Just parked) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid-      parked ^. #timer . #status `shouldBe` Dead-      parked ^. #timer . #attempts `shouldBe` 1-      parked ^. #lastError `shouldBe` Just "deferred"-      Right (Right (Just replacement)) <- Store.runStoreIO storeHandle $ claimDeadTimer request-      Store.runStoreIO storeHandle (completeTimerResume old (EventId sampleUuid2)) `shouldReturn` Right False-      Store.runStoreIO storeHandle (renewTimerResume old 60) `shouldReturn` Right (Right False)-      Store.runStoreIO storeHandle (cancelTimerResume replacement) `shouldReturn` Right True-      Right (Right cancelled) <- Store.runStoreIO storeHandle $ claimDeadTimer request-      isNothing cancelled `shouldBe` True--    it "inspects absent timers and preserves legacy metadata through every lifecycle" $ \storeHandle -> do-      let tid = counterTimerRequest ^. #timerId-          inspect reason = do-            Right old <- Store.runStoreIO storeHandle $ lookupTimer tid-            Right observed <- Store.runStoreIO storeHandle $ lookupTimerInspection tid-            fmap (^. #timer) observed `shouldBe` old-            fmap (^. #lastError) observed `shouldBe` Just reason-      Store.runStoreIO storeHandle (lookupTimerInspection tid) `shouldReturn` Right Nothing-      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest-      inspect Nothing-      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime-      inspect Nothing-      Right True <- Store.runStoreIO storeHandle $ markTimerFired tid (EventId sampleUuid2)-      inspect Nothing-      Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid-      observed ^. #timer . #firedEventId `shouldBe` Just (EventId sampleUuid2)-      observed ^. #timer . #attempts `shouldBe` 1--    it "preserves empty, populated, and Unicode dead reasons verbatim" $ \storeHandle -> do-      forM_ (zip [1 ..] ["", " retry exhausted ", "延期: café 日本語 🌱"]) $ \(n, reason) -> do-        let request = counterTimerRequest & #timerId .~ TimerId (UUID.fromWords 0 0 0 n)-        Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request-        Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (request ^. #timerId) reason-        Right old <- Store.runStoreIO storeHandle $ lookupTimer (request ^. #timerId)-        Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection (request ^. #timerId)-        Just (observed ^. #timer) `shouldBe` old-        observed ^. #lastError `shouldBe` Just reason--    it "filters dead timers by exact owner and literal reason, preserving NULL" $ \storeHandle -> do-      let fixtures =-            [ (1, "A", Just "deferred: one"),-              (2, "A", Just "deferred: 二"),-              (3, "B", Just "deferred: three"),-              (4, "A", Just "ordinary"),-              (5, "A", Nothing),-              (6, "A", Just ""),-              (7, "A", Just "a%_\\'雪 tail"),-              (8, "A", Just "aXX雪 tail"),-              (9, "a", Just "Deferred: one")-            ]-          tid n = TimerId (UUID.fromWords 0 0 0 n)-          check owner reason expected = do-            Right (Right page) <--              Store.runStoreIO storeHandle $-                findDeadTimers (DeadTimerFilter owner reason) (DeadTimerPageRequest 100 Nothing)-            fmap (^. #timer . #timerId) (page ^. #timers) `shouldBe` fmap tid expected-            page ^. #nextAfterTimerId `shouldBe` Nothing-      forM_ fixtures $ \(n, owner, reason) -> do-        let request = counterTimerRequest & #timerId .~ tid n & #processManagerName .~ owner-        Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request-        Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (tid n) (fromMaybe "legacy" reason)-        when (isNothing reason) $ do-          Right () <--            Store.runStoreIO storeHandle $-              Store.runTransaction $-                Tx.statement (UUID.fromWords 0 0 0 n) legacyDeadTimerReasonStmt-          Right (Just inspection) <- Store.runStoreIO storeHandle $ lookupTimerInspection (tid n)-          inspection ^. #lastError `shouldBe` Nothing-      -- Include every non-dead lifecycle in the same manager/reason search space.-      forM_ [10 .. 13] $ \n -> do-        Right () <--          Store.runStoreIO storeHandle $-            Store.runTransaction $-              scheduleTimerTx (counterTimerRequest & #timerId .~ tid n & #processManagerName .~ "A")-        pure ()-      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime-      Right True <- Store.runStoreIO storeHandle $ markTimerFired (tid 10) (EventId sampleUuid2)-      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime-      Right True <- Store.runStoreIO storeHandle $ cancelTimer (tid 12)-      Right (Just cancelled) <- Store.runStoreIO storeHandle $ lookupTimerInspection (tid 12)-      cancelled ^. #timer . #status `shouldBe` Timer.Cancelled-      check Nothing AnyTimerReason [1 .. 9]-      check (Just "A") (ReasonPrefix "deferred:") [1, 2]-      check Nothing (ReasonPrefix "deferred:") [1, 2, 3]-      check (Just "a") AnyTimerReason [9]-      check Nothing ReasonAbsent [5]-      check Nothing (ReasonExact "") [6]-      check Nothing (ReasonPrefix "") [1, 2, 3, 4, 6, 7, 8, 9]-      check Nothing (ReasonExact "deferred: 二") [2]-      check Nothing (ReasonPrefix "a%_\\'雪") [7]-      check Nothing (ReasonExact "a%_\\'雪 tail") [7]-      check Nothing (ReasonExact "DEFERRED: one") []-      check (Just "A' OR TRUE --") AnyTimerReason []--    it "bounds pages, traverses UUID order, and leaves every stored column unchanged" $ \storeHandle -> do-      forM_ [1 .. 101] $ \n -> do-        let request = plainTimerRequest n-        Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request-        Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (request ^. #timerId) "deferred"-        pure ()-      let snapshot = Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt-          readPage size cursor = Store.runStoreIO storeHandle $ findDeadTimers anyDeadTimer (DeadTimerPageRequest size cursor)-      storedBefore <- snapshot-      forM_ [-1, 0, 101, maxBound] $ \size ->-        readPage size Nothing `shouldReturn` Right (Left (InvalidDeadTimerPageSize size))-      Right (Right first) <- readPage 100 Nothing-      length (first ^. #timers) `shouldBe` 100-      first ^. #nextAfterTimerId `shouldBe` Just (plainTimerRequest 100 ^. #timerId)-      readPage 100 Nothing `shouldReturn` Right (Right first)-      Right (Right finalPage) <- readPage 100 (first ^. #nextAfterTimerId)-      fmap (^. #timer . #timerId) (finalPage ^. #timers) `shouldBe` [plainTimerRequest 101 ^. #timerId]-      finalPage ^. #nextAfterTimerId `shouldBe` Nothing-      readPage 1 (Just (plainTimerRequest 101 ^. #timerId)) `shouldReturn` Right (Right (DeadTimerPage [] Nothing))-      let walk cursor = do-            Right (Right page) <- readPage 1 cursor-            let ids = fmap (^. #timer . #timerId) (page ^. #timers)-            case page ^. #nextAfterTimerId of-              Nothing -> pure ids-              next -> (ids <>) <$> walk next-      walk Nothing `shouldReturn` fmap ((^. #timerId) . plainTimerRequest) [1 .. 101]-      Right (Just _) <- Store.runStoreIO storeHandle $ lookupTimerInspection (plainTimerRequest 1 ^. #timerId)-      snapshot `shouldReturn` storedBefore-      Store.runStoreIO storeHandle (runTimerWorker Nothing dueTimerTime (\_ -> pure (Just (EventId sampleUuid2))))-        `shouldReturn` Right Nothing-      snapshot `shouldReturn` storedBefore--    it "continues after a deleted cursor and observes new eligibility only above it" $ \storeHandle -> do-      let add n = do-            Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx (plainTimerRequest n)-            Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (plainTimerRequest n ^. #timerId) "deferred"-            pure ()-          readPage cursor = Store.runStoreIO storeHandle $ findDeadTimers anyDeadTimer (DeadTimerPageRequest 1 cursor)-      mapM_ add [20, 40, 60]-      Right (Right first) <- readPage Nothing-      first ^. #nextAfterTimerId `shouldBe` Just (plainTimerRequest 20 ^. #timerId)-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.sql-              "DELETE FROM keiro.keiro_timers WHERE correlation_id = 'drain-20'; UPDATE keiro.keiro_timers SET status = 'cancelled' WHERE correlation_id = 'drain-40'"-      mapM_ add [10, 30]-      Right (Right second) <- readPage (first ^. #nextAfterTimerId)-      fmap (^. #timer . #timerId) (second ^. #timers) `shouldBe` [plainTimerRequest 30 ^. #timerId]-      Right (Right third) <- readPage (second ^. #nextAfterTimerId)-      fmap (^. #timer . #timerId) (third ^. #timers) `shouldBe` [plainTimerRequest 60 ^. #timerId]-      third ^. #nextAfterTimerId `shouldBe` Nothing--    it "renders authorized original work beyond empty pages and rechecks revoked permissions" $ \storeHandle -> do-      let reason = "kioku:deferred:interactive-unavailable feature=summary details=保持"-          deadFilter = DeadTimerFilter (Just "drain-pm") (ReasonPrefix "kioku:deferred:interactive-unavailable feature=")-          entries =-            [ (1, object ["space" Aeson..= ("hidden" :: Text), "work" Aeson..= ("secret" :: Text)]),-              (2, object ["invalid" Aeson..= ("never render" :: Text)]),-              (3, object ["space" Aeson..= ("allowed" :: Text), "work" Aeson..= ("original work" :: Text)]),-              (4, object ["space" Aeson..= ("allowed" :: Text), "work" Aeson..= ("revoked work" :: Text)])-            ]-      forM_ entries $ \(n, payload) -> do-        Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx (plainTimerRequest n & #payload .~ payload)-        Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (plainTimerRequest n ^. #timerId) reason-        pure ()-      permissions <- newIORef (Set.singleton ("allowed" :: Text))-      let renderPage cursor = do-            Right (Right page) <- Store.runStoreIO storeHandle $ findDeadTimers deadFilter (DeadTimerPageRequest 1 cursor)-            fresh <- readIORef permissions-            rendered <- fmap catMaybes $ forM (page ^. #timers) $ \listed -> do-              Right inspected <- Store.runStoreIO storeHandle $ lookupTimerInspection (listed ^. #timer . #timerId)-              pure $ do-                inspection <- inspected-                (space, work) <--                  either (const Nothing) Just $-                    parseEither (withObject "work" (\o -> (,) <$> o .: "space" <*> o .: "work")) (inspection ^. #timer . #payload)-                if Set.member space fresh then Just (work :: Text, inspection ^. #lastError) else Nothing-            pure (rendered, page ^. #nextAfterTimerId)-      (hidden, next1) <- renderPage Nothing-      hidden `shouldBe` []-      next1 `shouldSatisfy` isJust-      (malformed, next2) <- renderPage next1-      malformed `shouldBe` []-      next2 `shouldSatisfy` isJust-      (allowed, next3) <- renderPage next2-      allowed `shouldBe` [("original work", Just reason)]-      writeIORef permissions Set.empty-      renderPage next3 `shouldReturn` ([], Nothing)--    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)-      Right lookedUp <--        Store.runStoreIO storeHandle $-          lookupTimer (counterTimerRequest ^. #timerId)-      fmap (^. #status) lookedUp `shouldBe` Just Firing-      -- 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 terminal publication rejection data at its public boundary" $ \_storeHandle -> do-      let validCode64 = "a" <> Text.replicate 63 "z"-          validDetail1024 = Text.replicate 1024 "x"-          validUtf8Detail = Text.replicate 512 "é"-      valid <- shouldBeRight (mkPublishRejection validCode64 (Just validDetail1024))-      publishRejectionCode valid `shouldBe` validCode64-      publishRejectionDetail valid `shouldBe` Just validDetail1024-      shouldBeRight_ (mkPublishRejection "authorization.denied_v2" Nothing)-      shouldBeRight_ (mkPublishRejection "invalid-destination" (Just validUtf8Detail))-      mkPublishRejection "" Nothing-        `shouldBeLeft` InvalidPublishRejectionCode ""-      mkPublishRejection "Uppercase" Nothing-        `shouldBeLeft` InvalidPublishRejectionCode "Uppercase"-      mkPublishRejection "1leading-digit" Nothing-        `shouldBeLeft` InvalidPublishRejectionCode "1leading-digit"-      mkPublishRejection "contains/slash" Nothing-        `shouldBeLeft` InvalidPublishRejectionCode "contains/slash"-      mkPublishRejection ("a" <> Text.replicate 64 "z") Nothing-        `shouldBeLeft` InvalidPublishRejectionCode ("a" <> Text.replicate 64 "z")-      mkPublishRejection "invalid-destination" (Just "")-        `shouldBeLeft` PublishRejectionDetailEmpty-      mkPublishRejection "invalid-destination" (Just (Text.replicate 513 "é"))-        `shouldBeLeft` PublishRejectionDetailTooLong 1026--    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 "finalizes rejection exactly once with durable typed audit data" $ \storeHandle -> do-      let oid = OutboxId outboxUuid1-      rejection <- shouldBeRight (mkPublishRejection "authorization.denied" (Just "sink policy refused this message"))-      replacement <- shouldBeRight (mkPublishRejection "invalid.destination" Nothing)-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)-      firstClaimAt <- getCurrentTime-      Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 firstClaimAt)-      Right (Just OutboxFailed) <--        Store.runStoreIO storeHandle $-          Store.runTransaction (markOutboxFailedTx oid "transient predecessor" 5 0 firstClaimAt)-      secondClaimAt <- getCurrentTime-      Right [claimed] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 secondClaimAt)-      rejectedAt <- getCurrentTime-      Right True <--        Store.runStoreIO storeHandle $-          Store.runTransaction (markOutboxRejectedTx oid rejection rejectedAt)-      Right False <--        Store.runStoreIO storeHandle $-          Store.runTransaction (markOutboxRejectedTx oid replacement (addUTCTime 60 rejectedAt))-      Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)-      row ^. #status `shouldBe` OutboxRejected-      row ^. #attemptCount `shouldBe` 2-      row ^. #nextAttemptAt `shouldBe` claimed ^. #nextAttemptAt-      row ^. #lastError `shouldBe` Nothing-      row ^. #publishedAt `shouldBe` Nothing-      row ^. #rejectedAt `shouldBe` Just rejectedAt-      row ^. #rejection `shouldBe` Just rejection--    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 "finalizes a mid-run rejection and continues the same-key suffix" $ \storeHandle -> do-      let row1Id = outboxIdFromOrdinal 1-          row2Id = outboxIdFromOrdinal 2-          row3Id = outboxIdFromOrdinal 3-          rows =-            [ (row1Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-1" & #key .~ Just "reject-run-key"),-              (row2Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-2" & #key .~ Just "reject-run-key"),-              (row3Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-3" & #key .~ Just "reject-run-key")-            ]-      rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" (Just "the configured sink cannot accept this event type"))-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            traverse_ (uncurry enqueueIntegrationEventTx) rows-      let publish claimed =-            pure-              [ ( row ^. #outboxId,-                  if row ^. #outboxId == row2Id-                    then PublishRejected rejection-                    else PublishSucceeded-                )-              | row <- claimed-              ]-      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)-      summary ^. #claimed `shouldBe` 3-      summary ^. #published `shouldBe` 2-      summary ^. #rejected `shouldBe` 1-      summary ^. #retried `shouldBe` 0-      Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id)-      Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id)-      Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id)-      row1 ^. #status `shouldBe` OutboxSent-      row2 ^. #status `shouldBe` OutboxRejected-      row2 ^. #rejection `shouldBe` Just rejection-      row3 ^. #status `shouldBe` OutboxSent--    it "redelivers callbacks after a pre-commit finalization failure" $ \storeHandle -> do-      let sentId = outboxIdFromOrdinal 1-          rejectedId = outboxIdFromOrdinal 2-          rows =-            [ (sentId, sampleIntegrationEnvelope & #messageId .~ "precommit-sent" & #key .~ Just "precommit-key"),-              (rejectedId, sampleIntegrationEnvelope & #messageId .~ "precommit-rejected" & #key .~ Just "precommit-key")-            ]-      rejection <- shouldBeRight (mkPublishRejection "invalid.destination" Nothing)-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            traverse_ (uncurry enqueueIntegrationEventTx) rows-      callbackInvocations <- newIORef []-      let publish claimed = do-            liftIO (modifyIORef' callbackInvocations (fmap (^. #outboxId) claimed :))-            pure-              [ (row ^. #outboxId, if row ^. #outboxId == rejectedId then PublishRejected rejection else PublishSucceeded)-              | row <- claimed-              ]-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.sql-              "ALTER TABLE keiro.keiro_outbox ADD CONSTRAINT keiro_outbox_test_rejection_block CHECK (status <> 'rejected')"-      first <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)-      first `shouldSatisfy` \case-        Left _ -> True-        Right _ -> False-      Right (Just stillPublishingSent) <- Store.runStoreIO storeHandle (lookupOutbox sentId)-      Right (Just stillPublishingRejected) <- Store.runStoreIO storeHandle (lookupOutbox rejectedId)-      stillPublishingSent ^. #status `shouldBe` OutboxPublishing-      stillPublishingRejected ^. #status `shouldBe` OutboxPublishing-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.sql "ALTER TABLE keiro.keiro_outbox DROP CONSTRAINT keiro_outbox_test_rejection_block"-      now <- getCurrentTime-      let strandedAt = addUTCTime (-3600) now-          maintenanceOptions = defaultMaintenanceOptions & #publishingTimeout .~ 1-      Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt sentId strandedAt)-      Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt rejectedId strandedAt)-      Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass maintenanceOptions Nothing)-      maintenance ^. #requeued `shouldBe` 2-      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)-      summary ^. #published `shouldBe` 1-      summary ^. #rejected `shouldBe` 1-      Right (Just sentRow) <- Store.runStoreIO storeHandle (lookupOutbox sentId)-      Right (Just rejectedRow) <- Store.runStoreIO storeHandle (lookupOutbox rejectedId)-      sentRow ^. #status `shouldBe` OutboxSent-      rejectedRow ^. #status `shouldBe` OutboxRejected-      invocations <- readIORef callbackInvocations-      invocations `shouldBe` replicate 2 [sentId, rejectedId]--    it "treats rejection as terminal for per-source ordering" $ \storeHandle -> do-      let row1Id = outboxIdFromOrdinal 1-          row2Id = outboxIdFromOrdinal 2-          row3Id = outboxIdFromOrdinal 3-          sourceEvent oid messageId =-            (oid, sampleIntegrationEnvelope & #messageId .~ messageId & #source .~ "reject-source" & #key .~ Nothing)-          rows =-            [ sourceEvent row1Id "reject-source-1",-              sourceEvent row2Id "reject-source-2",-              sourceEvent row3Id "reject-source-3"-            ]-      rejection <- shouldBeRight (mkPublishRejection "authorization.denied" Nothing)-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            traverse_ (uncurry enqueueIntegrationEventTx) rows-      let publish claimed =-            pure-              [ (row ^. #outboxId, if row ^. #outboxId == row2Id then PublishRejected rejection else PublishSucceeded)-              | row <- claimed-              ]-          opts = defaultPublishOptions & #orderingPolicy .~ PerSourceStream-      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish opts Nothing)-      summary ^. #published `shouldBe` 2-      summary ^. #rejected `shouldBe` 1-      Right (Just successor) <- Store.runStoreIO storeHandle (lookupOutbox row3Id)-      successor ^. #status `shouldBe` OutboxSent--    it "counts only a rejection finalization that wins the publishing-state race" $ \storeHandle -> do-      let oid = OutboxId outboxUuid1-      rejection <- shouldBeRight (mkPublishRejection "authorization.denied" Nothing)-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)-      now <- getCurrentTime-      let strandedAt = addUTCTime (-3600) now-          maintenanceOptions = defaultMaintenanceOptions & #publishingTimeout .~ 1-          publish _ = do-            backdateOutboxUpdatedAt oid strandedAt-            _ <- outboxMaintenancePass maintenanceOptions Nothing-            pure (PublishRejected rejection)-      Right summary <--        Store.runStoreIO storeHandle $-          publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing-      summary ^. #claimed `shouldBe` 1-      summary ^. #published `shouldBe` 0-      summary ^. #rejected `shouldBe` 0-      summary ^. #retried `shouldBe` 0-      summary ^. #dead `shouldBe` 0-      Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)-      row ^. #status `shouldBe` OutboxFailed-      row ^. #rejection `shouldBe` Nothing--    it "excludes rejected rows from claims, maintenance, backlog, and sent garbage collection" $ \storeHandle -> do-      let oid = OutboxId outboxUuid1-      rejection <- shouldBeRight (mkPublishRejection "invalid.destination" (Just "destination was removed"))-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)-      Right summary <--        Store.runStoreIO storeHandle $-          publishClaimedOutbox (perRow (const (pure (PublishRejected rejection)))) defaultPublishOptions Nothing-      summary ^. #rejected `shouldBe` 1-      now <- getCurrentTime-      Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid (addUTCTime (-3600) now))-      Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now)-      claimed `shouldBe` []-      Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing)-      maintenance ^. #requeued `shouldBe` 0-      maintenance ^. #deadLettered `shouldBe` 0-      maintenance ^. #backlog `shouldBe` 0-      Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 0 now)-      deleted `shouldBe` 0-      Right (Just retained) <- Store.runStoreIO storeHandle (lookupOutbox oid)-      retained ^. #status `shouldBe` OutboxRejected--    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 lateResult <--        Store.runStoreIO storeHandle $-          Store.runTransaction (markOutboxFailedTx oid "late failure from a timed-out worker" 5 60 now)-      lateResult `shouldBe` Nothing-      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 "StopTheLine continues after rejection and halts only on transient failure" $ \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-reject-" <> Text.pack (show i)) & #key .~ Just "stop-reject-key")-            | (i, oid) <- zip [1 .. 4 :: Int] ids-            ]-      rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" Nothing)-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            traverse_ (uncurry enqueueIntegrationEventTx) rows-      seenRef <- newIORef []-      let publish claimed = do-            liftIO (modifyIORef' seenRef (<> fmap (^. #outboxId) claimed))-            pure-              [ ( row ^. #outboxId,-                  if row ^. #outboxId == row1Id-                    then PublishRejected rejection-                    else-                      if row ^. #outboxId == row3Id-                        then PublishFailed "stop after rejection"-                        else PublishSucceeded-                )-              | row <- claimed-              ]-          opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0-      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish opts Nothing)-      summary ^. #published `shouldBe` 1-      summary ^. #rejected `shouldBe` 1-      summary ^. #retried `shouldBe` 2-      summary ^. #haltedOn `shouldBe` Just row3Id-      readIORef seenRef `shouldReturn` take 3 ids-      Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id)-      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 "does not mark a terminal rejection span as an error" $ \storeHandle -> do-      (processor, spansRef) <- inMemoryListExporter-      provider <- createTracerProvider [processor] emptyTracerProviderOptions-      rejection <- shouldBeRight (mkPublishRejection "authorization.denied" (Just "operator policy"))-      let tracer = makeTracer provider "keiro-test" tracerOptions-          oid = OutboxId outboxUuid1-          opts = defaultPublishOptions & #tracer ?~ tracer-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)-      Right summary <--        Store.runStoreIO storeHandle $-          publishClaimedOutbox (perRow (const (pure (PublishRejected rejection)))) opts Nothing-      summary ^. #rejected `shouldBe` 1-      _ <- shutdownTracerProvider provider Nothing-      spans <- traverse captureSpan =<< readIORef spansRef-      case spans of-        [batchSpan] -> do-          textAttr (csAttributes batchSpan) "error.type" `shouldBe` Nothing-          case csStatus batchSpan of-            Unset -> pure ()-            Ok -> pure ()-            other -> expectationFailure ("expected rejection span to be Unset/Ok, got " <> show other)-        other -> expectationFailure ("expected one rejection 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-          rejectId = OutboxId outboxUuid3-          okEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-ok" & #key .~ Nothing-          failEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-fail" & #key .~ Nothing-          rejectEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-reject" & #key .~ Nothing-      rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" (Just "not routed"))-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction (enqueueIntegrationEventTx okId okEvent)-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction (enqueueIntegrationEventTx failId failEvent)-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction (enqueueIntegrationEventTx rejectId rejectEvent)-      let publish row-            | row ^. #outboxId == okId = pure PublishSucceeded-            | row ^. #outboxId == rejectId = pure (PublishRejected rejection)-            | 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 ^. #rejected `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.rejected" 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--    -- Discovery is exact. A completed workflow is finished, and a workflow-    -- parked on an unresolved await has nothing to do until its wake source-    -- resolves — the wake's own append is what makes it discoverable again.-    it "discovers a parked workflow only once its awaited step is journaled" $ \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)-      parkedAt <- getCurrentTime-      Right whileParked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt)-      whileParked `shouldBe` []-      Right () <- Store.runStoreIO storeHandle $ do-        now <- liftIO getCurrentTime-        appendJournalEntry-          (WorkflowName "pending")-          (WorkflowId "p-1")-          (StepRecorded "awk:wait" (toJSON (7 :: Int)) now)-      wokenAt <- getCurrentTime-      Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)-      unfinished `shouldBe` [("p-1", "pending")]--  describe "Keiro.Workflow instance table" $ around (withFreshStore fixture) $ do-    it "lists workflow instances with filters and stable keyset pages" $ \storeHandle -> do-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $ do-            Instance.upsertInstanceTx "b-2" "beta" 0 Instance.WfFailed (Just "boom")-            Instance.upsertInstanceTx "a-2" "alpha" 0 Instance.WfCompleted Nothing-            Instance.upsertInstanceTx "b-1" "beta" 0 Instance.WfRunning Nothing-            Instance.upsertInstanceTx "a-1" "alpha" 0 Instance.WfFailed (Just "bad")--      let firstPageFilter =-            Instance.defaultWorkflowInstanceFilter-              { Instance.pageSize = 2-              }-      Right firstPage <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances firstPageFilter-      fmap (\row -> (row ^. #workflowName, row ^. #workflowId)) firstPage-        `shouldBe` [("alpha", "a-1"), ("alpha", "a-2")]--      let secondPageFilter =-            firstPageFilter-              { Instance.afterKey = Just ("alpha", "a-2")-              }-      Right secondPage <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances secondPageFilter-      fmap (\row -> (row ^. #workflowName, row ^. #workflowId)) secondPage-        `shouldBe` [("beta", "b-1"), ("beta", "b-2")]--      let failedBetaFilter =-            Instance.defaultWorkflowInstanceFilter-              { Instance.statuses = Just (Instance.WfFailed :| []),-                Instance.workflowName = Just "beta"-              }-      Right failedBeta <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances failedBetaFilter-      fmap (\row -> (row ^. #workflowName, row ^. #workflowId, row ^. #status)) failedBeta-        `shouldBe` [("beta", "b-2", Instance.WfFailed)]--    it "cancels active workflows idempotently without minting unknown state" $ \storeHandle -> do-      counter <- newIORef (0 :: Int)-      let name = WorkflowName "operator-cancel"-          wid = WorkflowId "operator-cancel-1"-          completedName = WorkflowName "operator-completed"-          completedId = WorkflowId "operator-completed-1"-      Left (_ :: SimulatedCrash) <--        try $-          Store.runStoreIO storeHandle $-            runWorkflow name wid (crashAfterStep1 counter)--      Right Instance.WorkflowCancelRecorded <--        Store.runStoreIO storeHandle $-          Instance.cancelWorkflow name wid-      Right Keiro.Workflow.Cancelled <--        Store.runStoreIO storeHandle $-          runWorkflow name wid (threeStep counter)-      readIORef counter `shouldReturn` 1-      Right (Instance.WorkflowAlreadyTerminal Instance.WfCancelled) <--        Store.runStoreIO storeHandle $-          Instance.cancelWorkflow name wid--      Right (Completed _) <--        Store.runStoreIO storeHandle $-          runWorkflow completedName completedId (demoWorkflow counter)-      Right (Instance.WorkflowAlreadyTerminal Instance.WfCompleted) <--        Store.runStoreIO storeHandle $-          Instance.cancelWorkflow completedName completedId--      Right Instance.WorkflowCancelUnknown <--        Store.runStoreIO storeHandle $-          Instance.cancelWorkflow (WorkflowName "missing") (WorkflowId "missing-1")-      Right Nothing <--        Store.runStoreIO storeHandle $-          Instance.lookupInstance (WorkflowName "missing") (WorkflowId "missing-1")-      pure ()--    it "cancels suspended and linked-child workflows through supported paths" $ \storeHandle -> do-      let suspendedName = WorkflowName "operator-suspended"-          suspendedId = WorkflowId "operator-suspended-1"-          parentName = WorkflowName "operator-parent"-          parentId = WorkflowId "operator-parent-1"-          childName = WorkflowName "ship"-          childId = WorkflowId "operator-child-1"-      Right Suspended <--        Store.runStoreIO storeHandle $-          runWorkflow suspendedName suspendedId neverArmingWorkflow-      Right Instance.WorkflowCancelRecorded <--        Store.runStoreIO storeHandle $-          Instance.cancelWorkflow suspendedName suspendedId-      now <- getCurrentTime-      Right discovered <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)-      discovered `shouldNotContain` [("operator-suspended-1", "operator-suspended")]--      Right Suspended <--        Store.runStoreIO storeHandle $-          runWorkflow parentName parentId (parentWorkflow childId)-      Right Instance.WorkflowCancelRecorded <--        Store.runStoreIO storeHandle $-          Instance.cancelWorkflow childName childId-      Store.runStoreIO storeHandle (runWorkflow parentName parentId (parentWorkflow childId))-        `shouldThrow` (== WorkflowChildCancelled childName childId)--    it "serializes cancellation against completion so exactly one marker wins" $ \storeHandle -> do-      let name = WorkflowName "operator-terminal-race"-          wid = WorkflowId "operator-terminal-race-1"-      seededAt <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt)-      start <- newEmptyMVar-      cancelDone <- newEmptyMVar-      completeDone <- newEmptyMVar-      _ <- forkIO $ do-        takeMVar start-        result <- Store.runStoreIO storeHandle $ Instance.cancelWorkflow name wid-        putMVar cancelDone result-      _ <- forkIO $ do-        takeMVar start-        completedAt <- getCurrentTime-        result <- Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCompleted completedAt)-        putMVar completeDone result-      putMVar start ()-      putMVar start ()-      _ <- takeMVar cancelDone-      _ <- takeMVar completeDone-      Right hasCancelled <- Store.runStoreIO storeHandle $ stepExists name wid 0 cancelledStepName-      Right hasCompleted <- Store.runStoreIO storeHandle $ stepExists name wid 0 completedStepName-      (hasCancelled, hasCompleted) `shouldSatisfy` \case-        (True, False) -> True-        (False, True) -> True-        _ -> False--    it "force-releases leases and makes the old owner stop at its next boundary" $ \storeHandle -> do-      firstEffect <- newIORef (0 :: Int)-      secondEffect <- newIORef (0 :: Int)-      let name = WorkflowName "operator-force-release"-          wid = WorkflowId "operator-force-release-1"-          options owner =-            defaultWorkflowRunOptions-              & #leaseHeartbeat-              .~ Just LeaseHeartbeat {owner, ttl = 60}-          body = do-            first <--              step (StepName "first") $ do-                value <- liftIO (incrementAndRead firstEffect)-                released <- Instance.forceReleaseInstanceLease name wid-                liftIO (released `shouldBe` True)-                pure value-            second <- step (StepName "second") (liftIO (incrementAndRead secondEffect))-            pure (first, second)-      Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 60 name wid-      claimedA `shouldBe` Instance.ClaimAcquired-      lost <--        try-          ( Store.runStoreIO storeHandle $-              runWorkflowWith (options "owner-a") name wid body-          ) ::-          IO-            ( Either-                WorkflowLeaseLost-                (Either Store.StoreError (WorkflowOutcome (Int, Int)))-            )-      lost `shouldBe` Left WorkflowLeaseLost-      readIORef firstEffect `shouldReturn` 1-      readIORef secondEffect `shouldReturn` 0-      Right releasedAgain <- Store.runStoreIO storeHandle $ Instance.forceReleaseInstanceLease name wid-      releasedAgain `shouldBe` False--      Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 60 name wid-      claimedB `shouldBe` Instance.ClaimAcquired-      Right (Completed (1, 1)) <--        Store.runStoreIO storeHandle $-          runWorkflowWith (options "owner-b") name wid body-      readIORef firstEffect `shouldReturn` 1-      readIORef secondEffect `shouldReturn` 1--    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 discovery index" $ around (withFreshStore fixture) $ do-    -- The discovery predicate must be stated as the positive active set-    -- (status IN ('running','suspended')) rather than as the complement of the-    -- terminal trio: Postgres proves partial-index applicability from the query-    -- predicate alone and never consults the table's CHECK constraint, so the-    -- complement form cannot use keiro_workflows_active_idx and seq-scans-    -- keiro_workflows on every resume pass. With seq scans discouraged, a plan-    -- that names the index is proof the planner can match it.-    it "plans the discovery predicate through keiro_workflows_active_idx" $ \storeHandle -> do-      now <- getCurrentTime-      Right () <- Store.runStoreIO storeHandle $-        Store.runTransaction $-          for_ (discoveryFixtureRows now) $ \row ->-            Tx.statement row insertWorkflowInstanceStmt-      Right planLines <- Store.runStoreIO storeHandle $-        Store.runTransaction $ do-          Tx.sql "SET LOCAL enable_seqscan = off"-          Tx.statement () explainDiscoveryStmt-      Text.unpack (Text.intercalate "\n" planLines)-        `shouldSatisfy` isInfixOf "keiro_workflows_active_idx"--    -- Exact discovery: 'running' always, 'suspended' only with a due wake hint.-    -- A suspended instance with no hint is parked on a wake source that will-    -- flip the row itself, so returning it would be pure waste.-    it "returns exactly the runnable and wake-due instances" $ \storeHandle -> do-      now <- getCurrentTime-      Right () <- Store.runStoreIO storeHandle $-        Store.runTransaction $-          for_ (discoveryFixtureRows now) $ \row ->-            Tx.statement row insertWorkflowInstanceStmt-      Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)-      unfinished-        `shouldBe` [ ("a-running", "discovery-index"),-                     ("c-due-sleep", "discovery-index")-                   ]--  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 snapshot wake-safety" $ around (withFreshStore fixture) $ do-    it "keeps a genuinely unresolved awakeable pending under Every 1" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "snapshot-unsignalled"-          wid = WorkflowId "wf1"-          opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1-          run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef)-      first <- run-      first `shouldBe` Right Suspended-      aid <- readRequiredAwakeableId aidRef-      Right (Just rowAfterFirst) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)-      rowAfterFirst ^. #status `shouldBe` Awk.Pending-      rowAfterFirst ^. #payload `shouldBe` Nothing-      second <- run-      second `shouldBe` Right Suspended-      Right (Just rowAfterSecond) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)-      rowAfterSecond ^. #status `shouldBe` Awk.Pending-      rowAfterSecond ^. #payload `shouldBe` Nothing--    it "delivers an awakeable signalled mid-run despite the stale in-memory map" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "snapshot-midrun-awakeable"-          wid = WorkflowId "wf1"-          opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1-          run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid snapshotShadowedAwakeable-      armed <--        Store.runStoreIO storeHandle $-          runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef)-      armed `shouldBe` Right Suspended-      first <- run-      first `shouldBe` Right (Completed "payload")-      second <- run-      second `shouldBe` Right (Completed "payload")--    it "delivers an awakeable shadowed by a snapshot on a later run" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "snapshot-stale-awakeable"-          wid = WorkflowId "wf1"-          opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1-      armed <--        Store.runStoreIO storeHandle $-          runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef)-      armed `shouldBe` Right Suspended-      first <--        Store.runStoreIO storeHandle $-          runWorkflowWith opts name wid (snapshotStaleAwakeablePhaseOne aidRef)-      first `shouldBe` Right Suspended-      aid <- readRequiredAwakeableId aidRef-      Right (Just (staleSeed, _)) <--        Store.runStoreIO storeHandle $-          loadWorkflowSnapshot (workflowGenerationStreamName name wid 0)-      staleSeed `shouldSatisfy` Map.notMember ("awk:" <> awakeableIdText aid)-      second <--        Store.runStoreIO storeHandle $-          runWorkflowWith opts name wid snapshotStaleAwakeablePhaseTwo-      second `shouldBe` Right (Completed "payload")--    it "delivers a child completion shadowed by a snapshot on a later run" $ \storeHandle -> do-      let name = WorkflowName "snapshot-stale-child-parent"-          wid = WorkflowId "wf1"-          childWid = WorkflowId "child1"-          opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1-      first <--        Store.runStoreIO storeHandle $-          runWorkflowWith opts name wid (snapshotStaleChildPhaseOne childWid)-      first `shouldBe` Right Suspended-      Right (Just (staleSeed, _)) <--        Store.runStoreIO storeHandle $-          loadWorkflowSnapshot (workflowGenerationStreamName name wid 0)-      staleSeed `shouldSatisfy` Map.notMember (childResultStepName childWid)-      second <--        Store.runStoreIO storeHandle $-          runWorkflowWith opts name wid (snapshotStaleChildPhaseTwo childWid)-      second `shouldBe` Right (Completed "packed+labelled")--  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,-            advanced = 1,-            resumed = 1,-            completed = 1,-            stillSuspended = 0,-            unknownName = 0,-            failed = 0,-            transientErrors = 0,-            leaseSkipped = 0,-            paced = 0,-            sleepDue = 0,-            unregisteredNames = Set.empty-          }-      -- 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,-            advanced = 1,-            resumed = 1,-            completed = 1,-            stillSuspended = 0,-            unknownName = 0,-            failed = 0,-            transientErrors = 0,-            leaseSkipped = 0,-            paced = 0,-            sleepDue = 0,-            unregisteredNames = Set.empty-          }-      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,-            advanced = 0,-            resumed = 0,-            completed = 0,-            stillSuspended = 0,-            unknownName = 1,-            failed = 0,-            transientErrors = 0,-            leaseSkipped = 0,-            paced = 0,-            sleepDue = 0,-            unregisteredNames = Set.singleton "orphan"-          }-      -- 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,-            advanced = 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--    -- Concurrency is opt-in and observable. Two workflows whose step actions-    -- take ~300 ms run in overlapping windows under `maxConcurrentAdvances = 2`-    -- and in disjoint windows under the default, so one slow step body no-    -- longer delays every other workflow in the pass.-    it "advances candidates concurrently only when the option allows it" $ \storeHandle -> do-      let slowStep windows label = do-            start <- liftIO getCurrentTime-            liftIO (threadDelay 300_000)-            end <- liftIO getCurrentTime-            liftIO (modifyMVar windows (\ws -> pure ((label, start, end) : ws, ())))-            pure (1 :: Int)-          runPass concurrency prefix = do-            windows <- newMVar []-            let nameA = WorkflowName (prefix <> "-a")-                nameB = WorkflowName (prefix <> "-b")-                widA = WorkflowId (prefix <> "-1")-                widB = WorkflowId (prefix <> "-2")-                opts =-                  defaultWorkflowResumeOptions-                    & #maxConcurrentAdvances-                    .~ concurrency-                    & #logEvent-                    .~ const (pure ())-                registry =-                  Map.fromList-                    [ (nameA, WorkflowDef (\_ -> step (StepName "slow") (slowStep windows ("a" :: Text)))),-                      (nameB, WorkflowDef (\_ -> step (StepName "slow") (slowStep windows "b")))-                    ]-            now <- getCurrentTime-            Right () <--              Store.runStoreIO storeHandle $-                appendJournalEntry nameA widA (StepRecorded "seed" (toJSON True) now)-            Right () <--              Store.runStoreIO storeHandle $-                appendJournalEntry nameB widB (StepRecorded "seed" (toJSON True) now)-            Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-            completed summary `shouldBe` 2-            readMVar windows-      concurrentWindows <- runPass 2 "overlap"-      windowsOverlap concurrentWindows `shouldBe` True-      serialWindows <- runPass 1 "serial"-      windowsOverlap serialWindows `shouldBe` False--    -- Concurrency must not change what a pass reports or how it isolates a bad-    -- candidate: the deltas are added at the end, so the summary cannot depend-    -- on the order candidates finish in. Each phase runs against its own fresh-    -- store, because an unknown-name candidate stays discoverable and would-    -- otherwise carry into the next phase's counts.-    it "reports a mixed pass the same way when advancing sequentially" $ \storeHandle -> do-      summary <- runMixedResumePass storeHandle 1-      summary `shouldBe` expectedMixedResumeSummary--    it "reports a mixed pass the same way when advancing concurrently" $ \storeHandle -> do-      summary <- runMixedResumePass storeHandle 3-      summary `shouldBe` expectedMixedResumeSummary--    it "records no crash attempt against a workflow that already went terminal" $ \storeHandle -> do-      let name = WorkflowName "crash-race"-          wid = WorkflowId "cr-1"-      now <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now)-      -- A live instance paces normally.-      Right live <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Instance.recordCrashTx "cr-1" "crash-race" "boom"-      live `shouldBe` Just 1-      -- Once terminal, the UPDATE's status guard matches no row. That is the-      -- answer, not an error: there is no live instance left to pace.-      cancelledAt <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry name wid (WorkflowCancelled cancelledAt)-      Right afterTerminal <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Instance.recordCrashTx "cr-1" "crash-race" "boom"-      afterTerminal `shouldBe` Nothing--    -- The race the arm above exists for. Workflow A goes terminal inside its own-    -- run and then crashes, so the pass records its crash against a cancelled-    -- instance. The zero-row result used to fail a single-row decoder, and-    -- because the crash record sits outside the per-advance catches, the store-    -- error escaped the whole pass: `resumeWorkflowsOnce` returned Left and-    -- every remaining candidate was skipped until the next tick.-    it "survives a crash recorded against a just-cancelled workflow" $ \storeHandle -> do-      healthyCounter <- newIORef (0 :: Int)-      events <- newIORef ([] :: [ResumeLogEvent])-      let raceName = WorkflowName "crash-race-pass"-          raceId = WorkflowId "crp-1"-          healthyName = WorkflowName "crash-race-healthy"-          healthyId = WorkflowId "crh-1"-          opts =-            defaultWorkflowResumeOptions-              & #maxAttempts-              .~ 1-              & #logEvent-              .~ (\event -> modifyIORef' events (event :))-          registry =-            Map.fromList-              [ ( raceName,-                  WorkflowDef-                    ( \_ -> do-                        cancelledAt <- liftIO getCurrentTime-                        appendJournalEntry raceName raceId (WorkflowCancelled cancelledAt)-                        liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)-                    )-                ),-                (healthyName, WorkflowDef (\_ -> threeStep healthyCounter))-              ]-      now <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry raceName raceId (StepRecorded "seed" (toJSON True) now)-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry healthyName healthyId (StepRecorded "seed" (toJSON True) now)-      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-      summary-        `shouldBe` emptyResumeSummary-          { discovered = 2,-            advanced = 1,-            resumed = 2,-            completed = 1,-            transientErrors = 1-          }-      -- The healthy workflow ran to completion regardless of which candidate-      -- discovery returned first, and nothing was marked failed: a workflow that-      -- is already cancelled must not also be condemned.-      readIORef healthyCounter `shouldReturn` 3-      logged <- readIORef events-      logged `shouldContain` [ResumeCrashRecordSkipped "crash-race-pass" "crp-1"]-      Right (Just raceRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance raceName raceId-      raceRow ^. #status `shouldBe` Instance.WfCancelled-      raceRow ^. #attempts `shouldBe` 0--    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 "resurrects a failed workflow and completes without rerunning its journaled prefix" $ \storeHandle -> do-      shouldCrash <- newIORef True-      counter <- newIORef (0 :: Int)-      let name = WorkflowName "resurrect-complete"-          wid = WorkflowId "rc-1"-          opts =-            defaultWorkflowResumeOptions-              & #maxAttempts-              .~ 1-              & #logEvent-              .~ const (pure ())-          registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter))-      crashed <--        try-          ( Store.runStoreIO storeHandle $-              runWorkflow name wid (recoverableWorkflow shouldCrash counter)-          ) ::-          IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int)))-      case crashed of-        Left _ -> pure ()-        Right other -> expectationFailure ("expected a simulated crash, got " <> show other)-      readIORef counter `shouldReturn` 1--      Right failedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-      failed failedPass `shouldBe` 1-      Right (Just failedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      failedRow ^. #status `shouldBe` Instance.WfFailed--      writeIORef shouldCrash False-      resurrected <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid-      resurrected `shouldBe` Right Instance.WorkflowResurrected-      Right (Just revivedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      revivedRow ^. #status `shouldBe` Instance.WfRunning-      revivedRow ^. #attempts `shouldBe` 0-      revivedRow ^. #lastError `shouldBe` Nothing-      revivedRow ^. #nextAttemptAt `shouldBe` Nothing--      Right completedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-      completed completedPass `shouldBe` 1-      readIORef counter `shouldReturn` 2-      Right (Just completedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      completedRow ^. #status `shouldBe` Instance.WfCompleted--    it "can fail again in the same generation after resurrection" $ \storeHandle -> do-      shouldCrash <- newIORef True-      counter <- newIORef (0 :: Int)-      let name = WorkflowName "resurrect-refail"-          wid = WorkflowId "rr-1"-          opts =-            defaultWorkflowResumeOptions-              & #maxAttempts-              .~ 1-              & #logEvent-              .~ const (pure ())-          registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter))-      crashed <--        try-          ( Store.runStoreIO storeHandle $-              runWorkflow name wid (recoverableWorkflow shouldCrash counter)-          ) ::-          IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int)))-      case crashed of-        Left _ -> pure ()-        Right other -> expectationFailure ("expected a simulated crash, got " <> show other)--      Right firstFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-      failed firstFailedPass `shouldBe` 1-      firstRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid-      firstRevival `shouldBe` Right Instance.WorkflowResurrected-      Right secondFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-      failed secondFailedPass `shouldBe` 1-      Right (Just refailedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      refailedRow ^. #status `shouldBe` Instance.WfFailed--      Right recorded <--        Store.runStoreIO storeHandle $-          Store.readStreamForward-            (workflowGenerationStreamName name wid 0)-            (StreamVersion 0)-            10-      let failureIds =-            [ event ^. #eventId-            | event <- Vector.toList recorded,-              Right decoded <- [decodeRecorded workflowJournalCodec event],-              WorkflowFailed {} <- [decoded]-            ]-      case failureIds of-        [firstFailureId, secondFailureId] ->-          firstFailureId `shouldNotBe` secondFailureId-        other ->-          expectationFailure ("expected two failure events, got " <> show other)--      secondRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid-      secondRevival `shouldBe` Right Instance.WorkflowResurrected--    it "guards resurrection and revives a failed child link transactionally" $ \storeHandle -> do-      let runningName = WorkflowName "resurrect-running"-          runningId = WorkflowId "running-1"-          missingName = WorkflowName "resurrect-missing"-          missingId = WorkflowId "missing-1"-          childName = WorkflowName "resurrect-child"-          childId = WorkflowId "child-1"-      now <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry runningName runningId (StepRecorded "seed" (toJSON True) now)-      runningOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow runningName runningId-      runningOutcome `shouldBe` Right Instance.WorkflowNotFailed-      missingOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow missingName missingId-      missingOutcome `shouldBe` Right Instance.WorkflowNotFound--      Right childMarkedFailed <--        Store.runStoreIO storeHandle $-          Store.runTransaction $ do-            Child.registerChildTx-              "child-1"-              "resurrect-child"-              "parent-1"-              "resurrect-parent"-              "child:child-1:result"-            Child.markChildFailedTx "child-1" "resurrect-child" "simulated terminal failure"-      childMarkedFailed `shouldBe` True-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry childName childId (WorkflowFailed "simulated terminal failure" now)--      childOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow childName childId-      childOutcome `shouldBe` Right Instance.WorkflowResurrected-      Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "child-1" "resurrect-child"-      childRow ^. #status `shouldBe` Child.Running-      childRow ^. #result `shouldBe` Nothing-      childRow ^. #failureReason `shouldBe` Nothing-      childRow ^. #completedAt `shouldBe` Nothing--    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` Instance.ClaimAcquired-      Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid-      claimedB `shouldBe` Instance.ClaimLeaseHeld-      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` Instance.ClaimAcquired--    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` Instance.ClaimAcquired-      Right attempt <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Instance.recordCrashTx "le-1" "lease-expire" "boom"-      attempt `shouldBe` Just 1-      Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid-      Right pacedClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid-      pacedClaim `shouldBe` Instance.ClaimPaced-      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` Instance.ClaimAcquired-      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` Instance.ClaimAcquired-      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 lease renewal" $ around (withFreshStore fixture) $ do-    it "renews before a slow fresh step so the original lease cannot be stolen" $ \storeHandle -> do-      attemptedClaim <- newIORef Nothing-      let name = WorkflowName "lease-heartbeat"-          wid = WorkflowId "heartbeat-1"-          runOpts =-            defaultWorkflowRunOptions-              & #leaseHeartbeat-              .~ Just LeaseHeartbeat {owner = "owner-a", ttl = 60}-          body =-            step (StepName "slow-boundary") $ do-              liftIO (threadDelay 300_000)-              claimed <--                Instance.claimInstance-                  "owner-b"-                  60-                  name-                  wid-              liftIO (writeIORef attemptedClaim (Just claimed))-              pure (claimed == Instance.ClaimAcquired)-      Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 0.2 name wid-      claimedA `shouldBe` Instance.ClaimAcquired-      outcome <- Store.runStoreIO storeHandle $ runWorkflowWith runOpts name wid body-      outcome `shouldBe` Right (Completed False)-      readIORef attemptedClaim `shouldReturn` Just Instance.ClaimLeaseHeld-      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      row ^. #leasedBy `shouldBe` Just "owner-a"--    it "stops at a lost lease boundary and the resume worker records no crash" $ \storeHandle -> do-      let directName = WorkflowName "lease-lost-direct"-          directId = WorkflowId "lost-direct-1"-          directOpts =-            defaultWorkflowRunOptions-              & #leaseHeartbeat-              .~ Just LeaseHeartbeat {owner = "owner-a", ttl = 60}-      now <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry directName directId (StepRecorded "seed" (toJSON True) now)-      Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 60 directName directId-      claimedA `shouldBe` Instance.ClaimAcquired-      leaseUntil <- addUTCTime 60 <$> getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement-              ("lost-direct-1", "lease-lost-direct", "owner-b", leaseUntil)-              forceWorkflowLeaseStmt-      firstDirectEffect <- newIORef (0 :: Int)-      secondDirectEffect <- newIORef (0 :: Int)-      direct <--        try-          ( Store.runStoreIO storeHandle $-              runWorkflowWith directOpts directName directId $ do-                _ <- step (StepName "first") (liftIO (incrementAndRead firstDirectEffect))-                step (StepName "second") (liftIO (incrementAndRead secondDirectEffect))-          ) ::-          IO-            ( Either-                WorkflowLeaseLost-                (Either Store.StoreError (WorkflowOutcome Int))-            )-      direct `shouldBe` Left WorkflowLeaseLost-      readIORef firstDirectEffect `shouldReturn` 0-      readIORef secondDirectEffect `shouldReturn` 0-      directFinishedAt <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry directName directId (WorkflowCompleted directFinishedAt)--      firstWorkerEffect <- newIORef (0 :: Int)-      secondWorkerEffect <- newIORef (0 :: Int)-      let workerName = WorkflowName "lease-lost-worker"-          workerId = WorkflowId "lost-worker-1"-          workerOpts =-            defaultWorkflowResumeOptions-              & #logEvent-              .~ const (pure ())-          registry =-            Map.singleton workerName $-              WorkflowDef $ \_ -> do-                _ <--                  step (StepName "first") $ do-                    value <- liftIO (incrementAndRead firstWorkerEffect)-                    expires <- liftIO (addUTCTime 60 <$> getCurrentTime)-                    Store.runTransaction $-                      Tx.statement-                        ("lost-worker-1", "lease-lost-worker", "owner-b", expires)-                        forceWorkflowLeaseStmt-                    pure value-                step (StepName "second") (liftIO (incrementAndRead secondWorkerEffect))-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry workerName workerId (StepRecorded "seed" (toJSON True) now)-      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce workerOpts registry-      summary-        `shouldBe` emptyResumeSummary-          { discovered = 1,-            leaseSkipped = 1-          }-      readIORef firstWorkerEffect `shouldReturn` 1-      readIORef secondWorkerEffect `shouldReturn` 0-      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance workerName workerId-      row ^. #attempts `shouldBe` 0-      row ^. #leasedBy `shouldBe` Just "owner-b"--  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.Workflow patch recording at rotation" $ around (withFreshStore fixture) $ do-    it "keeps the active patch after a wake append lands before the first rotated run" $ \storeHandle -> do-      let name = WorkflowName "patch-rotation-race"-          wid = WorkflowId "prr-1"-          patchOptions =-            defaultWorkflowRunOptions-              & #activePatches-              .~ Set.singleton fraudPatchId-          generationOneStream = workflowGenerationStreamName name wid 1--      first <--        Store.runStoreIO storeHandle $-          runWorkflowWith patchOptions name wid rotatingPatchWorkflow-      first `shouldBe` Right ContinuedAsNew-      Right patchSetRecorded <--        Store.runStoreIO storeHandle $-          stepExists name wid 1 patchSetStepName-      patchSetRecorded `shouldBe` True--      now <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry-            name-            wid-            ( StepRecorded-                "awk:11111111-1111-1111-1111-111111111111"-                (toJSON True)-                now-            )--      second <--        Store.runStoreIO storeHandle $-          runWorkflowWith patchOptions name wid rotatingPatchWorkflow-      second `shouldBe` Right (Completed "new-branch")-      replayed <--        Store.runStoreIO storeHandle $-          runWorkflowWith patchOptions name wid rotatingPatchWorkflow-      replayed `shouldBe` Right (Completed "new-branch")--      Right generationOneJournal <--        Store.runStoreIO storeHandle $-          Store.readStreamForward generationOneStream (StreamVersion 0) 20-      let decoded =-            map (decodeRecorded workflowJournalCodec) (Vector.toList generationOneJournal)-          patchSets =-            [ value-            | Right (StepRecorded key value _) <- decoded,-              key == patchSetStepName-            ]-          decisions =-            [ value-            | Right (StepRecorded key value _) <- decoded,-              key == patchStepName fraudPatchId-            ]-      patchSets `shouldBe` [toJSON [unPatchId fraudPatchId]]-      decisions `shouldBe` [toJSON True]--  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-      -- Break the table discovery itself reads, so every pass fails outright.-      -- (Hiding keiro_workflow_steps no longer suffices: under exact discovery-      -- the parked workflow is not returned, so a pass never reaches it.)-      Right () <--        Store.runStoreIO store $-          Store.runTransaction $-            Tx.sql "ALTER TABLE keiro.keiro_workflows RENAME TO keiro_workflows_hidden"-      worker <- forkIO (runWorkflowResumeWorkerPush store opts registry)-      logged <- waitForPassFailure-      logged `shouldBe` Just ()-      Right () <--        Store.runStoreIO store $-          Store.runTransaction $-            Tx.sql "ALTER TABLE keiro.keiro_workflows_hidden RENAME TO keiro_workflows"-      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"-      -- Park a workflow on the first of two gates, then journal that gate's-      -- result. The append flips the instance row to running, which is what-      -- makes exact discovery return it; the re-invocation then parks on the-      -- second gate and stays Suspended, which still counts as a re-invocation.-      suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (twoGateWorkflow counter)-      suspended `shouldBe` Right Suspended-      gateAt <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry name wid (StepRecorded "awk:first" (toJSON ()) gateAt)-      -- Register one pending awakeable (independent of the suspended workflow's-      -- own await) so the pending gauge has something to count.-      let aid = awakeableIdToUuid (generation0AwakeableId (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 -> twoGateWorkflow counter))-          resumeOpts =-            defaultWorkflowResumeOptions-              & #runOptions-              .~ (defaultWorkflowRunOptions & #metrics .~ Just metrics)-      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce resumeOpts registry-      (discovered summary, resumed summary, stillSuspended summary) `shouldBe` (1, 1, 1)-      _ <- 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 ^. #stateShapeHash) `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 deterministic id derivation" $ do-    -- Deterministic ids are replay identity: the same seed must yield the same-    -- id on every deploy, forever (ADR 24). Every literal below was captured-    -- from the *previous* derivation — which hashed each character's codepoint-    -- modulo 256 — before it was replaced by UTF-8 seed bytes. For ASCII seeds-    -- the two encodings agree byte for byte, so a failure here means a-    -- deployed id moved. Regenerate a literal only alongside a versioned-    -- derivation and a migration story, never to make the suite green.-    let name = WorkflowName "orderFulfillment"-        wid = WorkflowId "wf-1"-        sourceEventId = EventId (uuidLiteral "3f2504e0-4f89-51d3-9a0c-0305e82c3301")--    it "freezes the ASCII journal-event ids, reserved step names included" $ do-      deterministicJournalId name wid 0 "charge-card"-        `shouldBe` EventId (uuidLiteral "1618b21a-5321-536f-998b-99f88f078148")-      deterministicJournalId name wid 1 "charge-card"-        `shouldBe` EventId (uuidLiteral "ddbf5d19-df0d-50f7-9aa2-9c8214bfde00")-      deterministicJournalId name wid 0 completedStepName-        `shouldBe` EventId (uuidLiteral "5ac985e8-4168-5705-91bc-5523833d3f60")-      deterministicJournalId name wid 0 cancelledStepName-        `shouldBe` EventId (uuidLiteral "52493d94-d35a-5a7e-8ce9-40e1111c45f9")-      deterministicJournalId name wid 0 failedStepName-        `shouldBe` EventId (uuidLiteral "b7ed900d-0fac-54dd-87b1-a01f6782a298")-      deterministicJournalId name wid 0 continuedAsNewStepName-        `shouldBe` EventId (uuidLiteral "338f8962-ef47-5992-a4e0-c314358a2f05")-      deterministicJournalId name wid 0 continueSeedStepName-        `shouldBe` EventId (uuidLiteral "268c2031-b026-564a-be24-85cab59c3ce7")-      deterministicJournalId name wid 0 patchSetStepName-        `shouldBe` EventId (uuidLiteral "c188a7f9-617d-59e5-8e09-4498d7daf477")-      deterministicJournalId name wid 0 (patchStepName (PatchId "new-tax"))-        `shouldBe` EventId (uuidLiteral "64de4580-0a2d-522b-b397-e25c6ee3eacc")-      deterministicJournalId name wid 0 (sleepStepName (StepName "cool"))-        `shouldBe` EventId (uuidLiteral "e3a009bd-f287-5331-9f72-8e273f0040cf")--    it "freezes the ASCII sleep, awakeable, and process-manager ids" $ do-      sleepTimerId name wid 0 "sleep:cool"-        `shouldBe` TimerId (uuidLiteral "cfebe58e-b34c-5031-af98-18e71e6f4cfa")-      sleepTimerId name wid 1 "sleep:cool"-        `shouldBe` TimerId (uuidLiteral "e9696450-3993-59da-902e-4e5ebcfd1ab0")-      sleepTimerId name wid 2 "sleep:cool"-        `shouldBe` TimerId (uuidLiteral "6affc998-5cf2-51d0-9bbb-22e792581433")-      generation0AwakeableId name wid "approval"-        `shouldBe` AwakeableId (uuidLiteral "f677231c-8a27-51b6-9a5e-69015262b26f")-      deterministicCommandId "counter-pm" "order-1" sourceEventId 0-        `shouldBe` EventId (uuidLiteral "ff20892c-6665-5e92-8c99-d1569d2ce629")-      deterministicCommandId "counter-pm" "order-1" sourceEventId (-1)-        `shouldBe` EventId (uuidLiteral "4f3aa6bc-b12c-5dae-8eb5-81f6364f41ef")--    -- Each pair below produced one shared id under the old derivation, because-    -- U+0101 and U+0001 (and U+4E2D/U+2E2D, U+6587/U+2587) agree modulo 256.-    it "separates seeds the codepoint-truncating derivation collapsed" $ do-      deterministicJournalId name wid 0 "\x0101"-        `shouldNotBe` deterministicJournalId name wid 0 "\SOH"-      deterministicJournalId name wid 0 "\x4E2D\x6587"-        `shouldNotBe` deterministicJournalId name wid 0 "\x2E2D\x2587"-      sleepTimerId name wid 0 "\x0101"-        `shouldNotBe` sleepTimerId name wid 0 "\SOH"-      generation0AwakeableId name wid "\x0101"-        `shouldNotBe` generation0AwakeableId name wid "\SOH"-      deterministicCommandId "counter-pm" "\x0101" sourceEventId 0-        `shouldNotBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0--    it "keeps the seed components positional" $ do-      deterministicJournalId (WorkflowName "a") (WorkflowId "b") 0 "s"-        `shouldNotBe` deterministicJournalId (WorkflowName "b") (WorkflowId "a") 0 "s"-      deterministicCommandId "a" "b" sourceEventId 0-        `shouldNotBe` deterministicCommandId "b" "a" sourceEventId 0--    around (withFreshStore fixture) $-      -- End to end: under the old derivation both step names hashed to one-      -- event id, so the second append lost to the store's global event-id-      -- uniqueness and this example returned @Left (DuplicateEvent Nothing)@ —-      -- deterministically, on every retry, until the resume worker's-      -- crash-backoff ladder marked the workflow failed. Now both steps-      -- journal and the workflow completes.-      it "runs a workflow whose step names collided under the old derivation" $ \storeHandle -> do-        counter <- newIORef (0 :: Int)-        let wfName = WorkflowName "unicodeSteps"-            wfId = WorkflowId "us-1"-        outcome <--          Store.runStoreIO storeHandle $-            runWorkflow wfName wfId (collidingStepWorkflow counter)-        outcome `shouldBe` Right (Completed (1, 2))-        readIORef counter `shouldReturn` 2-        Right firstRecorded <- Store.runStoreIO storeHandle $ stepExists wfName wfId 0 "\x0101"-        firstRecorded `shouldBe` True-        Right secondRecorded <- Store.runStoreIO storeHandle $ stepExists wfName wfId 0 "\SOH"-        secondRecorded `shouldBe` True--  describe "Keiro deterministic id legacy-encoding bridge" $ do-    -- These values were captured by running the pre-UTF-8 implementation at-    -- 7d7a200b in an isolated worktree. Do not regenerate them from the bridge-    -- implementation: they are the independent evidence that it reproduces-    -- deployed identity.-    let sourceEventId = EventId (uuidLiteral "3f2504e0-4f89-51d3-9a0c-0305e82c3301")-        name = WorkflowName "legacy-awake"-        wid = WorkflowId "la-1"--    it "reproduces every captured process-manager command id" $ do-      let commandGoldens =-            [ ("order-1", 0, "ff20892c-6665-5e92-8c99-d1569d2ce629"),-              ("order-1", -1, "4f3aa6bc-b12c-5dae-8eb5-81f6364f41ef"),-              ("Jos\x00E9", 0, "78cbd6e1-c15f-58c3-be0e-14c861de6c85"),-              ("\x4E2D\x6587", 0, "58e6ef7b-a2c9-5e46-b580-db8df2ce72c7"),-              ("\x4E2D\x6587", -1, "f276cf1b-0f5c-5427-a27a-f6d4ad2ca577"),-              ("\x1F600", 0, "ddc163fc-3563-5ae6-a7f8-fbe1af2712b2"),-              ("\x0101", 0, "cfa5de78-8cc7-5eb2-8edd-da847221541d"),-              ("\SOH", 0, "cfa5de78-8cc7-5eb2-8edd-da847221541d"),-              ("\x0169ser", 0, "4fb869b4-d5b7-5c99-8c5d-c4552c5d4115"),-              ("iser", 0, "4fb869b4-d5b7-5c99-8c5d-c4552c5d4115")-            ]-      for_ commandGoldens $ \(correlation, emitIndex, golden) ->-        legacyDeterministicCommandId "counter-pm" correlation sourceEventId emitIndex-          `shouldBe` EventId (uuidLiteral golden)-      legacyDeterministicCommandId "demo-router" "g-\x4E2D\x6587" sourceEventId 0-        `shouldBe` EventId (uuidLiteral "379ebaad-62e1-5265-9605-340789ae6af7")--    it "reproduces every captured deterministic awakeable id" $ do-      preUtf8Generation0AwakeableId name wid "\x627F\x8A8D"-        `shouldBe` AwakeableId (uuidLiteral "c4eb4dfa-4108-577d-8e92-84edb337a48b")-      preUtf8Generation0AwakeableId name wid "caf\x00E9"-        `shouldBe` AwakeableId (uuidLiteral "446e5258-0697-525d-af06-0c2c3911ded7")-      preUtf8Generation0AwakeableId name wid "\x4E2D"-        `shouldBe` AwakeableId (uuidLiteral "7b252ef4-c7c0-579e-8f15-8f26c73196de")-      preUtf8Generation0AwakeableId name wid "-"-        `shouldBe` AwakeableId (uuidLiteral "7b252ef4-c7c0-579e-8f15-8f26c73196de")--    it "keeps ASCII identity stable and moves every non-ASCII capture" $ do-      legacyDeterministicCommandId "counter-pm" "order-1" sourceEventId 0-        `shouldBe` deterministicCommandId "counter-pm" "order-1" sourceEventId 0-      legacyDeterministicCommandId "counter-pm" "\SOH" sourceEventId 0-        `shouldBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0-      legacyDeterministicCommandId "counter-pm" "iser" sourceEventId 0-        `shouldBe` deterministicCommandId "counter-pm" "iser" sourceEventId 0-      for_ ["Jos\x00E9", "\x4E2D\x6587", "\x1F600", "\x0101", "\x0169ser"] $ \correlation ->-        legacyDeterministicCommandId "counter-pm" correlation sourceEventId 0-          `shouldNotBe` deterministicCommandId "counter-pm" correlation sourceEventId 0-      legacyDeterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId (-1)-        `shouldNotBe` deterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId (-1)-      preUtf8Generation0AwakeableId name wid "legacy"-        `shouldBe` generation0AwakeableId name wid "legacy"-      preUtf8Generation0AwakeableId name wid "-"-        `shouldBe` generation0AwakeableId name wid "-"-      for_ ["\x627F\x8A8D", "caf\x00E9", "\x4E2D"] $ \label ->-        preUtf8Generation0AwakeableId name wid label-          `shouldNotBe` generation0AwakeableId name wid label--    it "documents the historical truncation collisions and their UTF-8 separation" $ do-      legacyDeterministicCommandId "counter-pm" "\x0101" sourceEventId 0-        `shouldBe` legacyDeterministicCommandId "counter-pm" "\SOH" sourceEventId 0-      deterministicCommandId "counter-pm" "\x0101" sourceEventId 0-        `shouldNotBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0-      legacyDeterministicCommandId "counter-pm" "\x0169ser" sourceEventId 0-        `shouldBe` legacyDeterministicCommandId "counter-pm" "iser" sourceEventId 0-      deterministicCommandId "counter-pm" "\x0169ser" sourceEventId 0-        `shouldNotBe` deterministicCommandId "counter-pm" "iser" sourceEventId 0-      preUtf8Generation0AwakeableId name wid "\x4E2D"-        `shouldBe` preUtf8Generation0AwakeableId name wid "-"-      generation0AwakeableId name wid "\x4E2D"-        `shouldNotBe` generation0AwakeableId name wid "-"--    it "adds a legacy command probe only when the seed moved" $ do-      NonEmpty.toList (deterministicCommandIdProbes "counter-pm" "order-1" sourceEventId 0)-        `shouldBe` [deterministicCommandId "counter-pm" "order-1" sourceEventId 0]-      NonEmpty.toList (deterministicCommandIdProbes "counter-pm" "\x4E2D\x6587" sourceEventId 0)-        `shouldBe` [ deterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId 0,-                     legacyDeterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId 0-                   ]--    it "builds one current probe for an ASCII seed" $ do-      let seed = "keiro:probe:ascii"-      NonEmpty.toList (deterministicIdProbes seed)-        `shouldBe` [UUID.V5.generateNamed UUID.V5.namespaceURL (identitySeedBytes seed)]--    it "orders the current and legacy probes for a non-ASCII seed" $ do-      let seed = "keiro:probe:\x4E2D"-      NonEmpty.toList (deterministicIdProbes seed)-        `shouldBe` [ UUID.V5.generateNamed UUID.V5.namespaceURL (identitySeedBytes seed),-                     UUID.V5.generateNamed UUID.V5.namespaceURL (legacySeedBytes seed)-                   ]--  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 2 "sleep:cool")-        `shouldBe` Just ("sleep:cool", Just 2)-      parseSleepPayload-        ( object-            [ "kind" Aeson..= ("keiro.workflow.sleep" :: Text),-              "step" Aeson..= ("sleep:legacy" :: Text)-            ]-        )-        `shouldBe` Just ("sleep:legacy", Nothing)-      parseSleepPayload (object ["kind" Aeson..= ("counter-timeout" :: Text)])-        `shouldBe` Nothing--    it "recovers a legacy payload's generation from its deterministic timer id" $ do-      let name = WorkflowName "wf"-          wid = WorkflowId "w-legacy"-          full = "sleep:cool"-      for_ [0 .. 2] $ \gen ->-        matchSleepTimerGeneration name wid 2 full (sleepTimerId name wid gen full)-          `shouldBe` Just gen--    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", Just 0)-          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 "keeps a due wake_after stable on re-arm and clears it on fire" $ \storeHandle -> do-        counter <- newIORef (0 :: Int)-        let name = WorkflowName "sleep-wake-stable"-            wid = WorkflowId "sws-1"-            registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 0))-        Right Suspended <--          Store.runStoreIO storeHandle $-            runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 0)-        Right (Just firstWakeAfter) <--          Store.runStoreIO storeHandle $-            workflowWakeAfter name wid--        Right rearmed <--          Store.runStoreIO storeHandle $-            resumeWorkflowsOnce defaultWorkflowResumeOptions registry-        discovered rearmed `shouldBe` 1-        Right (Just secondWakeAfter) <--          Store.runStoreIO storeHandle $-            workflowWakeAfter name wid-        secondWakeAfter `shouldBe` firstWakeAfter--        fireTime <- getCurrentTime-        Right (Just _) <--          Store.runStoreIO storeHandle $-            runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing)-        Right clearedWakeAfter <--          Store.runStoreIO storeHandle $-            workflowWakeAfter name wid-        clearedWakeAfter `shouldBe` Nothing--        Right resumed <--          Store.runStoreIO storeHandle $-            resumeWorkflowsOnce defaultWorkflowResumeOptions registry-        discovered resumed `shouldBe` 1-        completed resumed `shouldBe` 1-        readIORef counter >>= (`shouldBe` 2)--      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 whose instance row is missing after an arm crash" $ \storeHandle -> do-        let name = WorkflowName "sleep-missing-fire"-            wid = WorkflowId "smf-1"-            body = sleepNamed (StepName "wait") 0-        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body-        Right () <--          Store.runStoreIO storeHandle $-            Store.runTransaction $-              Tx.statement ("smf-1", "sleep-missing-fire") deleteWorkflowInstanceStmt-        fireTime <- getCurrentTime-        Right (Just _) <--          Store.runStoreIO storeHandle $-            runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing)-        Right resolved <--          Store.runStoreIO storeHandle $-            stepExists name wid 0 "sleep:wait"-        resolved `shouldBe` True-        Right (Just recovered) <--          Store.runStoreIO storeHandle $-            Instance.lookupInstance name wid-        recovered ^. #status `shouldBe` Instance.WfRunning-        Store.runStoreIO storeHandle (runWorkflow name wid body)-          `shouldReturn` Right (Completed ())--      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))-        Right Suspended <--          Store.runStoreIO storeHandle $-            runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1)-        threadDelay 1_200_000-        Right boundaryPass <--          Store.runStoreIO storeHandle $-            resumeWorkflowsOnce defaultWorkflowResumeOptions registry-        discovered boundaryPass `shouldBe` 1-        fireTime <- getCurrentTime-        Right (Just _) <--          Store.runStoreIO storeHandle $-            runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing)-        Right completionPass <--          Store.runStoreIO storeHandle $-            resumeWorkflowsOnce defaultWorkflowResumeOptions registry-        discovered completionPass `shouldBe` 1-        completed completionPass `shouldBe` 1-        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.Timer batched drain" $ around (withFreshStore fixture) $ do-    -- The single-claim worker drains a backlog at one timer per invocation, so-    -- ten due sleeps take ten poll ticks and the last workflow wakes ticks late.-    -- One drain pass wakes them all, with one requeue-and-gauge preamble instead-    -- of ten.-    it "drains a mixed backlog of sleeps and process-manager timers in one pass" $ \storeHandle -> do-      firedPm <- newIORef ([] :: [Text])-      let sleepers = [1 .. 4 :: Int]-          sleeperName = WorkflowName "drain-sleeper"-          sleeperId i = WorkflowId ("ds-" <> Text.pack (show i))-      for_ sleepers $ \i -> do-        outcome <--          Store.runStoreIO storeHandle $-            runWorkflow sleeperName (sleeperId i) (sleepNamed (StepName "wait") 0)-        outcome `shouldBe` Right Suspended-      for_ [1 .. 6 :: Int] $ \i ->-        Store.runStoreIO storeHandle (Store.runTransaction (scheduleTimerTx (plainTimerRequest i)))-          `shouldReturn` Right ()-      now <- addUTCTime 1 <$> getCurrentTime-      Right drained <--        Store.runStoreIO storeHandle $-          drainWorkflowSleepTimers Nothing now 20 $ \row -> do-            liftIO (modifyIORef' firedPm (row ^. #correlationId :))-            pure (Just (EventId sampleUuid2))-      drained `shouldBe` 10-      -- Every sleep actually woke: the completion is journaled, not merely-      -- claimed.-      for_ sleepers $ \i -> do-        Right woke <- Store.runStoreIO storeHandle $ stepExists sleeperName (sleeperId i) 0 "sleep:wait"-        woke `shouldBe` True-      readIORef firedPm >>= \fired -> length fired `shouldBe` 6-      -- Nothing is left claimable.-      Right leftovers <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 (\_ -> pure Nothing)-      leftovers `shouldBe` 0--    it "stops at the batch limit and leaves the rest claimable" $ \storeHandle -> do-      for_ [1 .. 10 :: Int] $ \i ->-        Store.runStoreIO storeHandle (Store.runTransaction (scheduleTimerTx (plainTimerRequest i)))-          `shouldReturn` Right ()-      now <- addUTCTime 1 <$> getCurrentTime-      let fireOne _ = pure (Just (EventId sampleUuid2))-      Right firstBatch <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 3 fireOne-      firstBatch `shouldBe` 3-      Right restBatch <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 fireOne-      restBatch `shouldBe` 7-      -- A limit of zero still runs the preamble but claims nothing, and an-      -- empty backlog costs exactly what a single-claim pass costs.-      Right noneLeft <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 fireOne-      noneLeft `shouldBe` 0--  describe "Keiro.Workflow sleep generation pinning" $ around (withFreshStore fixture) $ do-    it "keeps a stale re-fire on the generation that armed the sleep" $ \storeHandle -> do-      counter <- newIORef (0 :: Int)-      let name = WorkflowName "sleep-generation-pin"-          wid = WorkflowId "sgp-1"-          full = "sleep:cool"-          TimerId generationZeroTimerId = sleepTimerId name wid 0 full-          TimerId generationOneTimerId = sleepTimerId name wid 1 full-          body = do-            seed <- restoreSeed (0 :: Int)-            _ <- step (StepName "work") (liftIO (incrementAndRead counter))-            if seed == 0-              then sleepNamed (StepName "cool") 0 >> continueAsNew (1 :: Int)-              else sleepNamed (StepName "cool") 3600 >> pure seed--      Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body-      claimTime <- getCurrentTime-      Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime-      claimed ^. #timerId `shouldBe` TimerId generationZeroTimerId-      Right (Just _) <--        Store.runStoreIO storeHandle $-          workflowSleepFireAction claimed--      Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body-      Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body-      Right (Just generationOneFireAt) <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement generationOneTimerId sleepTimerFireAtStmt--      requeueTime <- getCurrentTime-      Right requeued <--        Store.runStoreIO storeHandle $-          requeueStuckTimers 0 (addUTCTime 1 requeueTime)-      requeued `shouldBe` 1-      Right (Just staleFire) <--        Store.runStoreIO storeHandle $-          runWorkflowTimerWorker Nothing (addUTCTime 2 requeueTime) (\_ -> pure Nothing)-      staleFire ^. #timerId `shouldBe` TimerId generationZeroTimerId--      Right generationOneResolved <--        Store.runStoreIO storeHandle $-          stepExists name wid 1 full-      generationOneResolved `shouldBe` False-      Right (Just instanceRow) <--        Store.runStoreIO storeHandle $-          Instance.lookupInstance name wid-      instanceRow ^. #status `shouldBe` Instance.WfSuspended-      Right generationZeroStatus <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement generationZeroTimerId sleepTimerStatusStmt-      fmap fst generationZeroStatus `shouldBe` Just "fired"-      Right generationOneStatus <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement generationOneTimerId sleepTimerStatusStmt-      fmap fst generationOneStatus `shouldBe` Just "scheduled"-      Right (Just generationOneFireAtAfter) <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement generationOneTimerId sleepTimerFireAtStmt-      generationOneFireAtAfter `shouldBe` generationOneFireAt-      readIORef counter >>= (`shouldBe` 2)--  describe "Keiro.Workflow wake-lifecycle visibility" $ around (withFreshStore fixture) $ do-    -- Cancelling an awakeable writes no journal entry, so it is the one-    -- wake-source lifecycle transition that would otherwise leave the owning-    -- instance row untouched. It must still leave the workflow discoverable, or-    -- the workflow can never reach its await arm to observe the cancellation.-    it "flips the owner instance to running when its awakeable is cancelled" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "cancel-visible"-          wid = WorkflowId "cv-1"-          opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ())-          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))-      Right Suspended <--        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-      aid <- readRequiredAwakeableId aidRef-      Right (Just parked) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      parked ^. #status `shouldBe` Instance.WfSuspended-      Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid-      cancelled `shouldBe` True-      Right (Just woken) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      woken ^. #status `shouldBe` Instance.WfRunning-      woken ^. #generation `shouldBe` 0-      now <- getCurrentTime-      Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)-      unfinished `shouldBe` [("cv-1", "cancel-visible")]-      -- The pass re-invokes the workflow; its await arm sees the cancelled row-      -- and throws, which the worker records as a crash attempt.-      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-      (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0)-      Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      crashed ^. #attempts `shouldBe` 1-      fmap Text.unpack (crashed ^. #lastError)-        `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled")--    -- Only the first arm writes wake_after, so a stale re-fire that clears it-    -- erases a hint nothing will rewrite. Only a fresh append is a successful-    -- fire in ADR 7's sense.-    it "leaves a newer sleep's wake hint intact when a stale timer re-fires" $ \storeHandle -> do-      counter <- newIORef (0 :: Int)-      let name = WorkflowName "sleep-refire"-          wid = WorkflowId "sr-2"-      Right Suspended <--        Store.runStoreIO storeHandle $ runWorkflow name wid (twoSleepWorkflow counter)-      claimTime <- getCurrentTime-      Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime-      claimed ^. #timerId `shouldBe` sleepTimerId name wid 0 (sleepStepName (StepName "first"))-      -- Fire the first sleep, then "crash" before the worker marks the timer-      -- fired: the row stays in `firing` and is requeued below.-      Right firstFire <- Store.runStoreIO storeHandle $ workflowSleepFireAction claimed-      firstFire `shouldSatisfy` isJust-      Right cleared <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid-      cleared `shouldBe` Nothing-      -- The next run replays past the first sleep and arms the second one,-      -- whose insert writes the live wake hint.-      Right Suspended <--        Store.runStoreIO storeHandle $ runWorkflow name wid (twoSleepWorkflow counter)-      Right (Just liveHint) <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid-      liveHint `shouldSatisfy` (> claimTime)-      requeueTime <- getCurrentTime-      Right requeued <--        Store.runStoreIO storeHandle $ requeueStuckTimers 0 (addUTCTime 1 requeueTime)-      requeued `shouldBe` 1-      Right (Just stale) <--        Store.runStoreIO storeHandle $ claimDueTimer (addUTCTime 2 requeueTime)-      (stale ^. #timerId) `shouldBe` (claimed ^. #timerId)-      Right staleFire <- Store.runStoreIO storeHandle $ workflowSleepFireAction stale-      -- Still idempotent: the re-fire reports the same deterministic event id.-      staleFire `shouldBe` firstFire-      Right hintAfter <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid-      hintAfter `shouldBe` Just liveHint-      readIORef counter >>= (`shouldBe` 1)--  describe "Keiro.Workflow exact discovery" $ around (withFreshStore fixture) $ do-    it "hides a workflow parked on an awakeable until it is signalled" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "quiet-awk"-          wid = WorkflowId "qa-1"-          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))-          pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)-      Right Suspended <--        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-      aid <- readRequiredAwakeableId aidRef-      parkedAt <- getCurrentTime-      Right parked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt)-      parked `shouldBe` []-      -- The whole point: a parked workflow costs a pass nothing at all.-      Right idle <- pass-      idle `shouldBe` emptyResumeSummary-      Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)-      signalled `shouldBe` True-      wokenAt <- getCurrentTime-      Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)-      woken `shouldBe` [("qa-1", "quiet-awk")]-      Right finish <- pass-      (discovered finish, completed finish) `shouldBe` (1, 1)-      doneAt <- getCurrentTime-      Right afterCompletion <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds doneAt)-      afterCompletion `shouldBe` []--    -- The parent is invisible while it waits, but the freshly spawned child is-    -- discovered from the instance row spawnChild writes in the spawn step's-    -- transaction — which is why the resume worker no longer needs a separate-    -- findRunningChildIds seed.-    it "hides a parent parked on a child while still discovering the zero-step child" $ \storeHandle -> do-      let parentName = WorkflowName "quiet-parent"-          parentWid = WorkflowId "qp-1"-          childName = WorkflowName "ship"-          childWid = WorkflowId "ship-quiet"-          registry = Map.singleton parentName (WorkflowDef (\_ -> parentWorkflow childWid))-      Right Suspended <--        Store.runStoreIO storeHandle $-          runWorkflow parentName parentWid (parentWorkflow childWid)-      parkedAt <- getCurrentTime-      Right parked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt)-      parked `shouldBe` [("ship-quiet", "ship")]-      Right (Completed _) <--        Store.runStoreIO storeHandle $-          runChildWorkflow defaultWorkflowRunOptions childName childWid shipWorkflow-      wokenAt <- getCurrentTime-      Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)-      woken `shouldBe` [("qp-1", "quiet-parent")]-      Right finish <--        Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)-      (discovered finish, completed finish) `shouldBe` (1, 1)--    -- Wake-wins ordering. markInstanceSuspendedAwaiting is exactly the write a-    -- run performs after its (now stale) index miss, so calling it directly-    -- after a signal reproduces the race deterministically.-    it "writes running when the wake landed before the suspend write" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "race-wake-first"-          wid = WorkflowId "rwf-1"-          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))-      Right Suspended <--        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-      aid <- readRequiredAwakeableId aidRef-      Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)-      Right () <--        Store.runStoreIO storeHandle $-          Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid)-      Right (Just arbitrated) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      arbitrated ^. #status `shouldBe` Instance.WfRunning-      wokenAt <- getCurrentTime-      Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)-      woken `shouldBe` [("rwf-1", "race-wake-first")]-      Right finish <--        Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)-      completed finish `shouldBe` 1--    -- Suspend-wins ordering: the wake, queued behind the suspend write on the-    -- same per-step lock, flips the instance itself.-    it "flips a suspended instance to running when the wake lands after the suspend write" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "race-suspend-first"-          wid = WorkflowId "rsf-1"-          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))-      Right Suspended <--        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-      aid <- readRequiredAwakeableId aidRef-      Right () <--        Store.runStoreIO storeHandle $-          Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid)-      Right (Just parkedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      parkedRow ^. #status `shouldBe` Instance.WfSuspended-      parkedAt <- getCurrentTime-      Right invisible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt)-      invisible `shouldBe` []-      Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)-      Right (Just wokenRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      wokenRow ^. #status `shouldBe` Instance.WfRunning-      Right finish <--        Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)-      completed finish `shouldBe` 1--    it "stays discoverable when a cancel lands before the stale suspend write" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "race-cancel-first"-          wid = WorkflowId "rcf-1"-          opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ())-          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))-      Right Suspended <--        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-      aid <- readRequiredAwakeableId aidRef-      Right True <- Store.runStoreIO storeHandle $ cancelAwakeable aid-      Right () <--        Store.runStoreIO storeHandle $-          Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid)-      Right (Just arbitrated) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      arbitrated ^. #status `shouldBe` Instance.WfRunning-      wokenAt <- getCurrentTime-      Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)-      woken `shouldBe` [("rcf-1", "race-cancel-first")]-      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-      (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0)-      Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      crashed ^. #attempts `shouldBe` 1-      fmap Text.unpack (crashed ^. #lastError)-        `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled")--    it "flips a suspended instance to running when the cancel lands after the suspend write" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "race-cancel-second"-          wid = WorkflowId "rcs-1"-          opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ())-          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))-      Right Suspended <--        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-      aid <- readRequiredAwakeableId aidRef-      Right () <--        Store.runStoreIO storeHandle $-          Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid)-      Right (Just parked) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      parked ^. #status `shouldBe` Instance.WfSuspended-      parkedAt <- getCurrentTime-      Right invisible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt)-      invisible `shouldBe` []-      Right True <- Store.runStoreIO storeHandle $ cancelAwakeable aid-      Right (Just woken) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      woken ^. #status `shouldBe` Instance.WfRunning-      wokenAt <- getCurrentTime-      Right discoveredNow <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)-      discoveredNow `shouldBe` [("rcs-1", "race-cancel-second")]-      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-      (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0)-      Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      crashed ^. #attempts `shouldBe` 1-      fmap Text.unpack (crashed ^. #lastError)-        `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled")--    it "surfaces a due sleep through the wake hint and a fired sleep through running" $ \storeHandle -> do-      counter <- newIORef (0 :: Int)-      let name = WorkflowName "quiet-sleep"-          wid = WorkflowId "qs-1"-      Right Suspended <--        Store.runStoreIO storeHandle $-          runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60)-      now <- getCurrentTime-      Right early <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)-      early `shouldBe` []-      -- Due, but the timer worker has not fired it yet: the suspended arm.-      let dueAt = addUTCTime 61 now-      Right due <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds dueAt)-      due `shouldBe` [("qs-1", "quiet-sleep")]-      Right (Just _) <--        Store.runStoreIO storeHandle $-          runWorkflowTimerWorker Nothing dueAt (\_ -> pure Nothing)-      Right (Just fired) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      fired ^. #status `shouldBe` Instance.WfRunning-      Right hint <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid-      hint `shouldBe` Nothing-      -- Now discovered through the running arm, with no hint left to expire.-      firedAt <- getCurrentTime-      Right visible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds firedAt)-      visible `shouldBe` [("qs-1", "quiet-sleep")]--    -- A crashed workflow stays 'running', so exact discovery keeps returning it;-    -- what paces the retry is claimInstance's next_attempt_at gate, which is-    -- reported distinctly from a live foreign lease.-    it "keeps a crashed workflow discovered while its backoff gate paces retries" $ \storeHandle -> do-      let name = WorkflowName "crash-visible"-          wid = WorkflowId "cvz-1"-          opts =-            defaultWorkflowResumeOptions-              & #maxAttempts-              .~ 3-              & #logEvent-              .~ const (pure ())-          registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))-          pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry)-      seededAt <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt)-      Right first <- pass-      (discovered first, resumed first, failed first) `shouldBe` (1, 1, 0)-      Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      crashed ^. #status `shouldBe` Instance.WfRunning-      crashed ^. #attempts `shouldBe` 1-      Right second <- pass-      (discovered second, paced second, leaseSkipped second) `shouldBe` (1, 1, 0)--    it "a bounded drain loop terminates over a pool that cannot advance" $ \storeHandle -> do-      let crashName = WorkflowName "drain-crash"-          crashWid = WorkflowId "drain-crash-1"-          ghostName = WorkflowName "drain-ghost"-          ghostWid = WorkflowId "drain-ghost-1"-          opts =-            defaultWorkflowResumeOptions-              & #maxAttempts-              .~ 3-              & #logEvent-              .~ const (pure ())-          registry =-            Map.singleton-              crashName-              (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))-          pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry)-          drain 0 acc = pure acc-          drain n acc = do-            Right summary <- pass-            if advanced summary > 0-              then drain (n - 1 :: Int) (acc <> [summary])-              else pure (acc <> [summary])-      seededAt <- getCurrentTime-      for_ [(crashName, crashWid), (ghostName, ghostWid)] $ \(name, wid) -> do-        Right () <--          Store.runStoreIO storeHandle $-            appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt)-        pure ()-      passes <- drain 10 []-      length passes `shouldBe` 1-      case passes of-        [summary] -> do-          (discovered summary, resumed summary, unknownName summary, advanced summary)-            `shouldBe` (2, 1, 1, 0)-          unregisteredNames summary `shouldBe` Set.singleton "drain-ghost"-        other -> expectationFailure ("expected one drain pass, got " <> show other)-      Right blocked <- pass-      (discovered blocked, paced blocked, unknownName blocked, advanced blocked)-        `shouldBe` (2, 1, 1, 0)-      unregisteredNames blocked `shouldBe` Set.singleton "drain-ghost"--    it "a bounded drain loop terminates over a due sleep with no timer worker" $ \storeHandle -> do-      counter <- newIORef (0 :: Int)-      let name = WorkflowName "drain-due-sleep"-          wid = WorkflowId "dds-1"-          opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ())-          registry =-            Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") (-1)))-          pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry)-          drain 0 acc = pure acc-          drain n acc = do-            Right summary <- pass-            if advanced summary > 0-              then drain (n - 1 :: Int) (acc <> [summary])-              else pure (acc <> [summary])-      -- Arm the sleep with an already-due fire time. No timer worker ever fires it.-      Right Suspended <--        Store.runStoreIO storeHandle $-          runWorkflow name wid (sleepDemoNamed counter (StepName "wait") (-1))-      readIORef counter `shouldReturn` 1-      passes <- drain 5 []-      length passes `shouldBe` 1-      case passes of-        [summary] ->-          (discovered summary, resumed summary, stillSuspended summary, advanced summary, sleepDue summary)-            `shouldBe` (1, 1, 1, 0, 1)-        other -> expectationFailure ("expected one drain pass, got " <> show other)-      Right blocked <- pass-      (discovered blocked, stillSuspended blocked, advanced blocked, sleepDue blocked)-        `shouldBe` (1, 1, 0, 1)-      -- Replay-only: neither step body re-ran.-      readIORef counter `shouldReturn` 1-      -- The candidate is still discoverable, blocked on the timer worker rather than lost.-      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      row ^. #status `shouldBe` Instance.WfSuspended-      Right hint <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid-      hint `shouldSatisfy` isJust--  describe "Keiro.Workflow terminal boundaries" $ around (withFreshStore fixture) $ do-    -- The asymmetry this closes: cancellation stopped a run at the next step-    -- boundary, terminal failure did not. Before the append transaction checked-    -- both markers, this workflow ran step "two" and reported Completed.-    it "stops at the next step boundary when a workflow is failed mid-run" $ \storeHandle -> do-      counter <- newIORef (0 :: Int)-      let name = WorkflowName "self-fail"-          wid = WorkflowId "sf-1"-      outcome <--        Store.runStoreIO storeHandle $-          runWorkflow name wid (selfFailingWorkflow name wid counter)-      outcome `shouldBe` Right Keiro.Workflow.Failed-      -- Step one's action ran (its side effect is at-least-once at boundaries);-      -- step two's never did.-      readIORef counter `shouldReturn` 1-      -- Step one's own append is the one the in-transaction check has to refuse:-      -- the marker landed *inside* that action, after the pre-action probe had-      -- already passed. Nothing more is journaled into a terminal workflow.-      Right recordedOne <- Store.runStoreIO storeHandle $ stepExists name wid 0 "one"-      recordedOne `shouldBe` False-      Right recordedTwo <- Store.runStoreIO storeHandle $ stepExists name wid 0 "two"-      recordedTwo `shouldBe` False-      Right recorded <--        Store.runStoreIO storeHandle $-          Store.readStreamForward (StreamName "wf:self-fail-sf-1") (StreamVersion 0) 10-      Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded))-      any (\case WorkflowFailed {} -> True; _ -> False) decoded `shouldBe` True-      any (\case StepRecorded "two" _ _ -> True; _ -> False) decoded `shouldBe` False--    it "declines an ordinary append into a cancelled workflow without erroring" $ \storeHandle -> do-      let name = WorkflowName "refuse-cancelled"-          wid = WorkflowId "rc-1"-      now <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCancelled now)-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry name wid (StepRecorded "late" (toJSON True) now)-      Right present <- Store.runStoreIO storeHandle $ stepExists name wid 0 "late"-      present `shouldBe` False--    -- A wake source settles its own durable row even when it cannot deliver:-    -- the promise is resolved, the journal entry is not written.-    it "completes an awakeable owned by a failed workflow but journals nothing" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "refuse-signal"-          wid = WorkflowId "rs-1"-      Right Suspended <--        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-      aid <- readRequiredAwakeableId aidRef-      failedAt <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry name wid (WorkflowFailed "ceiling reached" failedAt)-      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-      Right delivered <--        Store.runStoreIO storeHandle $-          stepExists name wid 0 (awakeableStepPrefix <> awakeableIdText aid)-      delivered `shouldBe` False--    -- The refusal reads the derived failure-marker index row, which-    -- resurrection deletes, so a revived workflow accepts deliveries again by-    -- construction (ADR 8: failure history is immutable, derived state is-    -- revivable).-    it "accepts a wake append again after the workflow is resurrected" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "revive-delivery"-          wid = WorkflowId "rd-1"-      Right Suspended <--        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)-      aid <- readRequiredAwakeableId aidRef-      failedAt <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry name wid (WorkflowFailed "ceiling reached" failedAt)-      Right Instance.WorkflowResurrected <--        Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid-      Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)-      signalled `shouldBe` True-      Right delivered <--        Store.runStoreIO storeHandle $-          stepExists name wid 0 (awakeableStepPrefix <> awakeableIdText aid)-      delivered `shouldBe` True-      Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef))-        `shouldReturn` Right (Completed "ok!")--    -- Defense in depth for the sleep fire: its instance-status guard cannot see-    -- a cancellation whose instance row was already collected, but the append-    -- transaction still refuses. The timer is marked fired regardless, so it is-    -- not requeued forever against a workflow that will never accept it.-    it "marks a sleep timer fired without delivering into a cancelled workflow" $ \storeHandle -> do-      counter <- newIORef (0 :: Int)-      let name = WorkflowName "refuse-sleep"-          wid = WorkflowId "rsl-1"-      Right Suspended <--        Store.runStoreIO storeHandle $-          runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 0)-      cancelledAt <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCancelled cancelledAt)-      -- Partial GC: the instance row is gone, so the fire action's terminal-      -- guard finds nothing and proceeds to the append.-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement ("rsl-1", "refuse-sleep") deleteWorkflowInstanceStmt-      claimTime <- getCurrentTime-      Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime-      Right fired <- Store.runStoreIO storeHandle $ workflowSleepFireAction claimed-      fired `shouldSatisfy` isJust-      Right delivered <- Store.runStoreIO storeHandle $ stepExists name wid 0 "sleep:wait"-      delivered `shouldBe` False--  describe "Keiro.Workflow.Awakeable" $ do-    -- Pure (no-DB) check of the frozen generation-0 compatibility derivation.-    it "reproduces a stable, label-sensitive generation-0 AwakeableId" $ do-      let aid1 = generation0AwakeableId (WorkflowName "w") (WorkflowId "1") "approval"-          aid2 = generation0AwakeableId (WorkflowName "w") (WorkflowId "1") "approval"-          aidOther = generation0AwakeableId (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 (generation0AwakeableId (WorkflowName "sch") (WorkflowId "1") "a")-            aidB = awakeableIdToUuid (generation0AwakeableId (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. The guarded-        -- UPDATE returns the owner coordinates so the caller can flip the-        -- owning instance row in the same transaction.-        Right cancelled <--          Store.runStoreIO storeHandle $-            Store.runTransaction $-              Awk.cancelAwakeableTx aidB-        cancelled `shouldBe` Just ("sch", "1")-        Right reCancelled <--          Store.runStoreIO storeHandle $-            Store.runTransaction $-              Awk.cancelAwakeableTx aidB-        reCancelled `shouldBe` Nothing-        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 = generation0AwakeableId 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 = generation0AwakeableId 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 "adopts a pre-UTF-8 generation-0 row for a non-ASCII label" $ \storeHandle -> do-        aidRef <- newIORef Nothing-        let name = WorkflowName "legacy-awake"-            wid = WorkflowId "la-1"-            legacy = AwakeableId (uuidLiteral "c4eb4dfa-4108-577d-8e92-84edb337a48b")-        preUtf8Generation0AwakeableId name wid "\x627F\x8A8D" `shouldBe` legacy-        Right () <--          Store.runStoreIO storeHandle $-            Store.runTransaction $-              Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid)-        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (unicodeApprovalFlowWithId aidRef)-        adopted <- readRequiredAwakeableId aidRef-        adopted `shouldBe` legacy-        Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text)-        completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (unicodeApprovalFlowWithId 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 awakeable registration" $ around (withFreshStore fixture) $ do-    it "registers the row before a journaled hand-off can expose the id" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "awakeable-signal-gap"-          wid = WorkflowId "asg-1"-      Right Suspended <--        Store.runStoreIO storeHandle $-          runWorkflow name wid (publishAwakeableBeforeAwait aidRef)-      aid <- readRequiredAwakeableId aidRef-      Right (Just pendingRow) <--        Store.runStoreIO storeHandle $-          Awk.lookupAwakeable (awakeableIdToUuid aid)-      pendingRow ^. #status `shouldBe` Awk.Pending--      Right signalled <--        Store.runStoreIO storeHandle $-          signalAwakeable aid ("ok" :: Text)-      signalled `shouldBe` True-      Right (Just completedRow) <--        Store.runStoreIO storeHandle $-          Awk.lookupAwakeable (awakeableIdToUuid aid)-      completedRow ^. #status `shouldBe` Awk.Completed--      let unknown =-            AwakeableId-              (uuidLiteral "00000000-0000-0000-0000-0000000002f2")-      Right unknownSignal <--        Store.runStoreIO storeHandle $-          signalAwakeable unknown ("forged" :: Text)-      unknownSignal `shouldBe` False--      completed <--        Store.runStoreIO storeHandle $-          runWorkflow name wid (awaitPublishedAwakeable aidRef)-      completed `shouldBe` Right (Completed "ok")--  describe "Keiro.Workflow awakeable signal race" $ around (withFreshStore fixture) $ do-    it "does not append a value when cancellation wins after the signal pre-read" $ \storeHandle -> do-      aidRef <- newIORef Nothing-      let name = WorkflowName "awakeable-cancel-race"-          wid = WorkflowId "acr-1"-      Right Suspended <--        Store.runStoreIO storeHandle $-          runWorkflow name wid (approvalFlowWithId aidRef)-      aid <- readRequiredAwakeableId aidRef-      Right (Just stalePendingRow) <--        Store.runStoreIO storeHandle $-          Awk.lookupAwakeable (awakeableIdToUuid aid)-      Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid-      cancelled `shouldBe` True-      Right signalled <--        Store.runStoreIO storeHandle $-          signalAwakeableFrom stalePendingRow ("late" :: Text)-      signalled `shouldBe` False-      Right recorded <--        Store.runStoreIO storeHandle $-          stepExists-            name-            wid-            0-            (awakeableStepPrefix <> awakeableIdText aid)-      recorded `shouldBe` False-      Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef))-        `shouldThrow` (== WorkflowAwakeableCancelled aid)--  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.Child durable failed delivery" $ around (withFreshStore fixture) $ do-    it "delivers a persisted child failure after the parent rotates past the failure journal" $ \storeHandle -> do-      let childWid = WorkflowId "failed-before-rotation"-          parentName = WorkflowName "parent-failure-rotation"-          parentId = WorkflowId "p-failure-rotation"-          registry =-            Map.fromList-              [ (parentName, WorkflowDef (\_ -> failedChildBeforeRotation childWid)),-                (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text)))-              ]-          opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1-      Right Suspended <--        Store.runStoreIO storeHandle $-          runWorkflow parentName parentId (failedChildBeforeRotation childWid)-      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-      failed summary `shouldBe` 1-      Right (Just childRow) <--        Store.runStoreIO storeHandle $-          Child.lookupChild "failed-before-rotation" "ship"-      childRow ^. #status `shouldBe` Child.ChildFailed-      childRow ^. #failureReason-        `shouldSatisfy` maybe False ("SimulatedCrash" `Text.isInfixOf`)-      Right failedOnGenerationZero <--        Store.runStoreIO storeHandle $-          stepExists-            parentName-            parentId-            0-            (childResultStepName childWid)-      failedOnGenerationZero `shouldBe` True--      Right ContinuedAsNew <--        Store.runStoreIO storeHandle $-          runWorkflow parentName parentId (rotatePastFailedChild childWid)-      Right generation <- Store.runStoreIO storeHandle $ currentGeneration parentName parentId-      generation `shouldBe` 1-      Right failedOnGenerationOne <--        Store.runStoreIO storeHandle $-          stepExists-            parentName-            parentId-            1-            (childResultStepName childWid)-      failedOnGenerationOne `shouldBe` False--      delivered <--        Store.runStoreIO storeHandle $-          runWorkflow parentName parentId (catchFailedChildAfterRotation childWid)-      delivered `shouldSatisfy` \case-        Right (Completed reason) -> "SimulatedCrash" `Text.isInfixOf` reason-        _ -> False--  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 "deletes scheduled sleep timers so a collected workflow cannot resurrect" $ \storeHandle -> do-      counter <- newIORef (0 :: Int)-      let name = WorkflowName "gc-scheduled-sleep"-          wid = WorkflowId "gss-1"-          journalStream = workflowGenerationStreamName name wid 0-          TimerId timerUuid = sleepTimerId name wid 0 "sleep:wait"-          body = do-            _ <- step (StepName "before-sleep") (liftIO (incrementAndRead counter))-            sleepNamed (StepName "wait") 3600-      Right Suspended <--        Store.runStoreIO storeHandle $-          runWorkflow name wid body-      Right timerBeforeGc <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement timerUuid sleepTimerStatusStmt-      fmap fst timerBeforeGc `shouldBe` Just "scheduled"--      cancelledAt <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          appendJournalEntry name wid (WorkflowCancelled cancelledAt)-      gcClock <- getCurrentTime-      Right collected <--        Store.runStoreIO storeHandle $-          WorkflowGc.gcWorkflowsOnce-            (addUTCTime 1 gcClock)-            WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10}-      collected `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1}--      Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream-      Right timerAfterGc <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement timerUuid sleepTimerStatusStmt-      timerAfterGc `shouldBe` Nothing--      Right noClaim <--        Store.runStoreIO storeHandle $-          runWorkflowTimerWorker Nothing (addUTCTime 7200 gcClock) (\_ -> pure Nothing)-      noClaim `shouldBe` Nothing-      Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid-      Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream-      readIORef counter >>= (`shouldBe` 1)--    it "cancels a sleep fire when a terminal instance survives partial GC" $ \storeHandle -> do-      let name = WorkflowName "gc-terminal-fire"-          wid = WorkflowId "gtf-1"-          full = "sleep:wait"-          timerId@(TimerId timerUuid) = sleepTimerId name wid 0 full-          journalStream = workflowGenerationStreamName name wid 0-      now <- getCurrentTime-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $ do-            Instance.upsertInstanceTx "gtf-1" "gc-terminal-fire" 0 Instance.WfCancelled Nothing-            void $-              scheduleTimerOnceTx-                TimerRequest-                  { timerId,-                    processManagerName = "gc-terminal-fire",-                    correlationId = "gtf-1",-                    fireAt = now,-                    payload = sleepTimerPayload 0 full-                  }-      Right (Just claimed) <--        Store.runStoreIO storeHandle $-          runWorkflowTimerWorker Nothing now (\_ -> pure Nothing)-      claimed ^. #timerId `shouldBe` timerId-      Right terminalTimer <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement timerUuid sleepTimerStatusStmt-      fmap fst terminalTimer `shouldBe` Just "cancelled"-      Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream-      Right resolved <--        Store.runStoreIO storeHandle $-          stepExists name wid 0 full-      resolved `shouldBe` False--    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--    -- One failing deletion used to take the whole batch with it, and the-    -- summary claimed everything eligible had been deleted regardless. The-    -- sabotage is a workflow id long enough that its derived journal stream-    -- name exceeds kiroku's 512-byte limit, so `hardDeleteStream` throws-    -- `StreamNameTooLong` every time — no timing, no concurrency.-    it "isolates a failing deletion, reports it honestly, and re-scans it" $ \storeHandle -> do-      counter <- newIORef (0 :: Int)-      let healthyName = WorkflowName "gc-isolated"-          healthyId = WorkflowId "gi-1"-          sabotagedId = Text.replicate 600 "x"-          policy = WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10}-      Right (Completed _) <--        Store.runStoreIO storeHandle $-          runWorkflow healthyName healthyId (demoWorkflow counter)-      -- Written directly: a workflow with this id could never journal anything,-      -- because the same limit rejects its appends. GC eligibility reads only-      -- the instance row, which is exactly the surface under test.-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement (sabotagedId, "gc-sabotaged") insertTerminalGcInstanceStmt-      now <- getCurrentTime-      Right summary <--        Store.runStoreIO storeHandle $-          WorkflowGc.gcWorkflowsOnce (addUTCTime 1 now) policy-      summary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 2, deleted = 1}-      -- The healthy workflow was collected despite the other one failing.-      Right healthyGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance healthyName healthyId-      healthyGone `shouldBe` Nothing-      -- The sabotaged one kept its instance row, so it stays eligible: a-      -- partially collected workflow converges instead of leaking.-      Right nextSummary <--        Store.runStoreIO storeHandle $-          WorkflowGc.gcWorkflowsOnce (addUTCTime 2 now) policy-      nextSummary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 0}--    it "keeps the gc loop alive across a pass it cannot finish" $ \storeHandle -> do-      logged <- newIORef ([] :: [Text])-      let sabotagedId = Text.replicate 600 "x"-          policy = WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10}-          -- A bare `forever` loop would report at most once and then die on the-          -- error; per-pass isolation keeps it reporting every tick.-          waitForTwoPasses = timeout 5_000_000 $ do-            let go = do-                  seen <- readIORef logged-                  if length seen >= 2-                    then pure ()-                    else threadDelay 20_000 >> go-            go-      Right () <--        Store.runStoreIO storeHandle $-          Store.runTransaction $-            Tx.statement (sabotagedId, "gc-loop-sabotaged") insertTerminalGcInstanceStmt-      worker <--        forkIO . void . Store.runStoreIO storeHandle $-          WorkflowGc.runWorkflowGcWorkerWith policy 20_000 (\msg -> modifyIORef' logged (msg :))-      reported <- waitForTwoPasses `finally` killThread worker-      reported `shouldBe` Just ()-      messages <- readIORef logged-      messages `shouldSatisfy` all ("stay eligible" `Text.isInfixOf`)---- | One resume pass over four candidates that exercise every outcome a pass--- can report: one that completes, one that suspends, one whose name is absent--- from the registry, and one that crashes into terminal failure at a ceiling of--- one attempt. Parameterised by @maxConcurrentAdvances@ so the sequential and--- concurrent runs are literally the same scenario.-runMixedResumePass :: Store.KirokuStore -> Int -> IO ResumeSummary-runMixedResumePass storeHandle concurrency = do-  healthyCounter <- newIORef (0 :: Int)-  let healthyName = WorkflowName "mixed-healthy"-      suspendedName = WorkflowName "mixed-suspended"-      poisonName = WorkflowName "mixed-poison"-      orphanName = WorkflowName "mixed-orphan"-      opts =-        defaultWorkflowResumeOptions-          & #maxAttempts-          .~ 1-          & #maxConcurrentAdvances-          .~ concurrency-          & #logEvent-          .~ const (pure ())-      registry =-        Map.fromList-          [ (healthyName, WorkflowDef (\_ -> threeStep healthyCounter)),-            (suspendedName, WorkflowDef (\_ -> neverArmingWorkflow)),-            (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))-          ]-  now <- getCurrentTime-  for_ [healthyName, suspendedName, poisonName, orphanName] $ \name ->-    Store.runStoreIO-      storeHandle-      (appendJournalEntry name (WorkflowId "mixed-1") (StepRecorded "seed" (toJSON True) now))-      `shouldReturn` Right ()-  Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry-  readIORef healthyCounter `shouldReturn` 3-  pure summary--expectedMixedResumeSummary :: ResumeSummary-expectedMixedResumeSummary =-  emptyResumeSummary-    { discovered = 4,-      advanced = 2,-      resumed = 3,-      completed = 1,-      stillSuspended = 1,-      unknownName = 1,-      failed = 1,-      unregisteredNames = Set.singleton "mixed-orphan"-    }---- | Do two recorded execution windows intersect? Used to tell a concurrent--- resume pass from a sequential one without measuring throughput.-windowsOverlap :: [(Text, UTCTime, UTCTime)] -> Bool-windowsOverlap = \case-  [(_, startA, endA), (_, startB, endB)] -> startA < endB && startB < endA-  _ -> False---- | 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))--forceWorkflowLeaseStmt :: Statement (Text, Text, Text, UTCTime) ()-forceWorkflowLeaseStmt =-  preparable-    """-    UPDATE keiro.keiro_workflows-    SET leased_by = $3,-        lease_expires_at = $4,-        updated_at = now()-    WHERE workflow_id = $1-      AND workflow_name = $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---- | 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)---- | A workflow with one durable side effect before a switchable failure and--- one durable side effect after it. Resurrection tests use the counter to prove--- the recorded prefix never executes again.-recoverableWorkflow ::-  (Workflow :> es, IOE :> es) =>-  IORef Bool ->-  IORef Int ->-  Eff es Int-recoverableWorkflow shouldCrash counter = do-  _ <- step (StepName "durable-prefix") (liftIO (incrementAndRead counter))-  crashing <- liftIO (readIORef shouldCrash)-  when crashing (liftIO (throwIO SimulatedCrash))-  step (StepName "durable-tail") (liftIO (incrementAndRead counter))---- | 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.--- | Two steps whose names collided under the codepoint-truncating id--- derivation: U+0101 and U+0001 both hashed as the single byte @0x01@, so the--- second step's journal append was rejected as a duplicate event id.-collidingStepWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int)-collidingStepWorkflow counter = do-  a <- step (StepName "\x0101") (liftIO (incrementAndRead counter))-  b <- step (StepName "\SOH") (liftIO (incrementAndRead counter))-  pure (a, b)--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 <> "!"))--unicodeApprovalFlowWithId :: (Workflow :> es, Store :> es, IOE :> es) => IORef (Maybe AwakeableId) -> Eff es Text-unicodeApprovalFlowWithId ref = do-  (aid, await) <- awakeableNamed (StepName "\x627F\x8A8D")-  liftIO (writeIORef ref (Just aid))-  v <- await-  step (StepName "use") (pure (v <> "!"))--publishAwakeableBeforeAwait ::-  forall es.-  (Workflow :> es, Store :> es, IOE :> es) =>-  IORef (Maybe AwakeableId) ->-  Eff es ()-publishAwakeableBeforeAwait ref = do-  (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate")-  _ <--    step (StepName "publish") $ do-      liftIO (writeIORef ref (Just aid))-  (_ :: ()) <- awaitStep (StepName "hold") (pure ())-  pure ()--awaitPublishedAwakeable ::-  (Workflow :> es, Store :> es, IOE :> es) =>-  IORef (Maybe AwakeableId) ->-  Eff es Text-awaitPublishedAwakeable ref = do-  (aid, await) <- awakeableNamed (StepName "gate")-  _ <--    step (StepName "publish") $ do-      liftIO (writeIORef ref (Just aid))-  await--snapshotUnsignalledAwakeable ::-  (Workflow :> es, Store :> es, IOE :> es) =>-  IORef (Maybe AwakeableId) ->-  Eff es Text-snapshotUnsignalledAwakeable ref = do-  (aid, await) <- awakeableNamed (StepName "gate")-  liftIO (writeIORef ref (Just aid))-  await--snapshotShadowedAwakeable :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text-snapshotShadowedAwakeable = do-  (aid, await) <- awakeableNamed (StepName "gate")-  _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text)))-  await--snapshotStaleAwakeablePhaseOne ::-  forall es.-  (Workflow :> es, Store :> es, IOE :> es) =>-  IORef (Maybe AwakeableId) ->-  Eff es ()-snapshotStaleAwakeablePhaseOne ref = do-  (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate")-  liftIO (writeIORef ref (Just aid))-  _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text)))-  (_ :: ()) <- awaitStep (StepName "hold") (pure ())-  pure ()--snapshotStaleAwakeablePhaseTwo :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text-snapshotStaleAwakeablePhaseTwo = do-  (_aid, await) <- awakeableNamed (StepName "gate")-  _ <- step (StepName "mid") (pure ())-  await--snapshotStaleChildPhaseOne ::-  (Workflow :> es, Store :> es, IOE :> es, Error Store.StoreError :> es) =>-  WorkflowId ->-  Eff es ()-snapshotStaleChildPhaseOne childWid = do-  _h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow-  _ <--    step (StepName "drive") $-      void (runChildWorkflow defaultWorkflowRunOptions (WorkflowName "snapshot-child") childWid shipWorkflow)-  (_ :: ()) <- awaitStep (StepName "hold") (pure ())-  pure ()--snapshotStaleChildPhaseTwo ::-  (Workflow :> es, Store :> es, IOE :> es) =>-  WorkflowId ->-  Eff es Text-snapshotStaleChildPhaseTwo childWid = do-  h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow-  _ <- step (StepName "drive") (pure ())-  awaitChild h--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)---- | Two sleeps on one generation with a step between them: the first is due--- immediately, the second far in the future. Firing the first and resuming--- moves the live wake hint onto the second sleep, which is the state a stale--- re-fire of the first timer must not disturb.-twoSleepWorkflow ::-  (Workflow :> es, Store :> es, IOE :> es) =>-  IORef Int -> Eff es Int-twoSleepWorkflow counter = do-  sleepNamed (StepName "first") 0-  n <- step (StepName "mid") (liftIO (incrementAndRead counter))-  sleepNamed (StepName "second") 3600-  pure n--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--failedChildBeforeRotation ::-  (Workflow :> es, Store :> es) =>-  WorkflowId ->-  Eff es Text-failedChildBeforeRotation childWid = do-  _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow-  awaitStep (StepName "rotation-gate") (pure ())--rotatePastFailedChild ::-  (Workflow :> es, Store :> es) =>-  WorkflowId ->-  Eff es Text-rotatePastFailedChild childWid = do-  _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow-  continueAsNew ()--catchFailedChildAfterRotation ::-  (Workflow :> es, Store :> es, IOE :> es) =>-  WorkflowId ->-  Eff es Text-catchFailedChildAfterRotation childWid = do-  child <- spawnChild (WorkflowName "ship") childWid shipWorkflow-  EffException.catch-    (awaitChild child)-    (\(WorkflowChildFailed _ _ reason) -> pure reason)---- | 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 ())---- | Two sequential gates. Journaling the first makes the workflow discoverable--- again; the resulting re-invocation replays past it and parks on the second,--- so the run is re-invoked and still suspends.-twoGateWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Int-twoGateWorkflow counter = do-  _ <- step (StepName "s1") (liftIO (incrementAndRead counter))-  (_ :: ()) <- awaitStep (StepName "awk:first") (pure ())-  awaitStep (StepName "awk:second") (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---- | The failure counterpart of 'selfCancellingWorkflow': step one's action--- writes this workflow's own terminal failure marker, standing in for the--- resume worker marking it failed while another runner is mid-run.-selfFailingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int-selfFailingWorkflow name wid counter = do-  _ <--    step (StepName "one") $ do-      now <- liftIO getCurrentTime-      appendJournalEntry name wid (WorkflowFailed "ceiling reached" now)-      liftIO (incrementAndRead counter)-  step (StepName "two") (liftIO (incrementAndRead counter))--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,-      rejectedAt = Nothing,-      rejection = 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)--instance CanonicalStateShape CounterState--data CounterStateV2-  = CountingV2-  | PausedV2-  deriving stock (Generic, Eq, Show, Enum, Bounded, Ord)-  deriving anyclass (FromJSON, ToJSON)--instance CanonicalStateShape CounterStateV2--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 CanonicalStateShape PartialSnapshotState--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--auditedCounterEventStream :: ValidatedCounterEventStream-auditedCounterEventStream =-  mkEventStreamOrThrow-    "counter-audited-only"-    (counterEventStreamDef & #transducer .~ auditedCounterTransducer)--auditedCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent-auditedCounterTransducer =-  SymTransducer-    { edgesOut = \case-        Counting ->-          [ Edge-              { guard = matchInCtor addCtor,-                update = UKeep,-                output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)],-                target = Counting,-                mode = Keiki.Live-              }-          ],-      initial = Counting,-      initialRegs = RNil,-      isFinal = \_ -> False-    }--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,-                mode = Keiki.Live-              }-          ],-      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,-                mode = Keiki.Live-              }-          ],-      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,-                mode = Keiki.Live-              }-          ],-      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,-                mode = Keiki.Live-              },-            Edge-              { guard = ambiguousGuard,-                update = UKeep,-                output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)],-                target = Counting,-                mode = Keiki.Live-              }-          ]-    }-  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,-                    mode = Keiki.Live-                  }-              ],-            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,-                mode = Keiki.Live-              }-          ],-      initial = Counting,-      initialRegs = RCons (Proxy @"lastAmount") 0 RNil,-      isFinal = \_ -> False-    }--foldV1SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream-foldV1SnapshotCounterEventStream =-  mkEventStreamOrThrow "snapshot-counter-fold-v1" foldV1SnapshotCounterEventStreamDef--foldV1SnapshotCounterEventStreamDef :: SnapshotCounterEventStream-foldV1SnapshotCounterEventStreamDef =-  snapshotCounterEventStreamDef-    { transducer = foldV1SnapshotCounterTransducer,-      stateCodec =-        Just-          ( defaultStateCodecWithFold-              @SnapshotCounterRegs-              @CounterState-              (FoldVersion "fold-v1")-              1-          )-    }--foldV2SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream-foldV2SnapshotCounterEventStream =-  mkEventStreamOrThrow "snapshot-counter-fold-v2" foldV2SnapshotCounterEventStreamDef--foldV2SnapshotCounterEventStreamDef :: SnapshotCounterEventStream-foldV2SnapshotCounterEventStreamDef =-  foldV1SnapshotCounterEventStreamDef-    { transducer = foldV2SnapshotCounterTransducer,-      snapshotPolicy = Every 1,-      stateCodec =-        Just-          ( defaultStateCodecWithFold-              @SnapshotCounterRegs-              @CounterState-              (FoldVersion "fold-v2")-              1-          )-    }--foldV2WithoutFingerprintBumpEventStream :: ValidatedSnapshotCounterEventStream-foldV2WithoutFingerprintBumpEventStream =-  mkEventStreamOrThrow-    "snapshot-counter-fold-v2-without-fingerprint-bump"-    foldV2WithoutFingerprintBumpEventStreamDef--foldV2WithoutFingerprintBumpEventStreamDef :: SnapshotCounterEventStream-foldV2WithoutFingerprintBumpEventStreamDef =-  foldV2SnapshotCounterEventStreamDef-    { stateCodec =-        Just-          ( defaultStateCodecWithFold-              @SnapshotCounterRegs-              @CounterState-              (FoldVersion "fold-v1")-              1-          )-    }--foldV1SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent-foldV1SnapshotCounterTransducer =-  foldSnapshotCounterTransducer-    (inpCtor addCtor #amount)--foldV2SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent-foldV2SnapshotCounterTransducer =-  foldSnapshotCounterTransducer-    (inpCtor addCtor #amount K..+ lit 1)--foldSnapshotCounterTransducer ::-  Keiki.Term SnapshotCounterRegs CounterCommand AddFields Int ->-  SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent-foldSnapshotCounterTransducer nextLastAmount =-  SymTransducer-    { edgesOut = \case-        Counting ->-          [ Edge-              { guard =-                  PAnd-                    (matchInCtor addCtor)-                    (inpCtor addCtor #amount K..< lit 100),-                update =-                  USet-                    (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int)-                    nextLastAmount,-                output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)],-                target = Counting,-                mode = Keiki.Live-              },-            Edge-              { guard =-                  PAnd-                    (matchInCtor addCtor)-                    ( PAnd-                        (inpCtor addCtor #amount K..>= lit 100)-                        ( inpCtor addCtor #amount-                            .== (proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int) K..+ lit 100)-                        )-                    ),-                update = UKeep,-                output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)],-                target = Counting,-                mode = Keiki.Live-              }-          ],-      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,-                mode = Keiki.Live-              }-          ],-      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,-                mode = Keiki.Live-              }-          ],-      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,-                mode = Keiki.Live-              }-          ],-      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,-                mode = Keiki.Live-              }-          ]-    }---- | 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,-          mode = Keiki.Live-        }---- | 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,-                mode = Keiki.Live-              }-          ]-    }---- | 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,-                mode = Keiki.Live-              }-          ]-    }--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,-                mode = Keiki.Live-              }-          ]-        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--data SilentChoiceCommand-  = RejectSilently-  | NoOpSilently-  | UnmatchedSilently-  deriving stock (Generic, Eq, Show)--data CoordinatorCommand-  = CoordinatorAccept !Int-  | CoordinatorReject !Text-  | CoordinatorNoOp !Text-  | CoordinatorUnmatched-  deriving stock (Generic, Eq, Show)--data DomainDispatchInput = DomainDispatchInput !Text ![CoordinatorCommand]-  deriving stock (Generic, Eq, Show)--type SilentChoiceEventStream = EventStream (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent--type ValidatedSilentChoiceEventStream = ValidatedEventStream (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent--type CoordinatorEventStream = EventStream (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent--type ValidatedCoordinatorEventStream = ValidatedEventStream (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent--type RetryDecisionEventStream = EventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent--type ValidatedRetryDecisionEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand 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-    }--silentChoiceEventStream :: ValidatedSilentChoiceEventStream-silentChoiceEventStream = mkEventStreamOrThrow "silent-choice-command" silentChoiceEventStreamDef--silentChoiceEventStreamDef :: SilentChoiceEventStream-silentChoiceEventStreamDef =-  EventStream-    { transducer = silentChoiceTransducer,-      initialState = Counting,-      initialRegisters = RNil,-      eventCodec = counterCodec,-      resolveStreamName = Stream.streamName,-      snapshotPolicy = Never,-      stateCodec = Nothing-    }--retryDecisionEventStream :: ValidatedRetryDecisionEventStream-retryDecisionEventStream = mkEventStreamOrThrow "retry-domain-decision" retryDecisionEventStreamDef--retryDecisionEventStreamDef :: RetryDecisionEventStream-retryDecisionEventStreamDef =-  EventStream-    { transducer =-        SymTransducer-          { edgesOut = \case-              Draining ->-                [ Edge-                    { guard = matchInCtor addCtor,-                      update = UKeep,-                      output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)],-                      target = Drained,-                      mode = Keiki.Live-                    }-                ]-              Drained ->-                [ Edge-                    { guard = matchInCtor addCtor,-                      update = UKeep,-                      output = [],-                      target = Drained,-                      mode = Keiki.Live-                    }-                ],-            initial = Draining,-            initialRegs = RNil,-            isFinal = const False-          },-      initialState = Draining,-      initialRegisters = RNil,-      eventCodec = counterCodec,-      resolveStreamName = Stream.streamName,-      snapshotPolicy = Never,-      stateCodec = Nothing-    }--coordinatorEventStream :: ValidatedCoordinatorEventStream-coordinatorEventStream = mkEventStreamOrThrow "coordinator-domain" coordinatorEventStreamDef--coordinatorEventStreamDef :: CoordinatorEventStream-coordinatorEventStreamDef =-  EventStream-    { transducer =-        SymTransducer-          { edgesOut = \case-              Counting ->-                [ Edge-                    { guard = matchInCtor coordinatorAcceptCtor,-                      update = UKeep,-                      output = [pack coordinatorAcceptCtor counterAddedCtor (inpCtor coordinatorAcceptCtor #amount *: oNil)],-                      target = Counting,-                      mode = Keiki.Live-                    },-                  Edge-                    { guard = matchInCtor coordinatorRejectCtor,-                      update = UKeep,-                      output = [],-                      target = Counting,-                      mode = Keiki.Live-                    },-                  Edge-                    { guard = matchInCtor coordinatorNoOpCtor,-                      update = UKeep,-                      output = [],-                      target = Counting,-                      mode = Keiki.Live-                    }-                ],-            initial = Counting,-            initialRegs = RNil,-            isFinal = const False-          },-      initialState = Counting,-      initialRegisters = RNil,-      eventCodec = counterCodec,-      resolveStreamName = Stream.streamName,-      snapshotPolicy = Never,-      stateCodec = Nothing-    }--type CoordinatorMessageFields = '[ '("message", Text)]--coordinatorAcceptCtor :: InCtor CoordinatorCommand AddFields-coordinatorAcceptCtor =-  Keiki.unavailableInCtor-    "CoordinatorAccept"-    (\case CoordinatorAccept amount -> Just (RCons Proxy amount RNil); _ -> Nothing)-    (\case RCons _ amount RNil -> CoordinatorAccept amount)--coordinatorRejectCtor :: InCtor CoordinatorCommand CoordinatorMessageFields-coordinatorRejectCtor =-  Keiki.unavailableInCtor-    "CoordinatorReject"-    (\case CoordinatorReject message -> Just (RCons Proxy message RNil); _ -> Nothing)-    (\case RCons _ message RNil -> CoordinatorReject message)--coordinatorNoOpCtor :: InCtor CoordinatorCommand CoordinatorMessageFields-coordinatorNoOpCtor =-  Keiki.unavailableInCtor-    "CoordinatorNoOp"-    (\case CoordinatorNoOp message -> Just (RCons Proxy message RNil); _ -> Nothing)-    (\case RCons _ message RNil -> CoordinatorNoOp message)--silentChoiceTransducer :: SymTransducer (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent-silentChoiceTransducer =-  SymTransducer-    { edgesOut = \case-        Counting ->-          [ Edge-              { guard = matchInCtor rejectSilentlyCtor,-                update = UKeep,-                output = [],-                target = Counting,-                mode = Keiki.Live-              },-            Edge-              { guard = matchInCtor noOpSilentlyCtor,-                update = UKeep,-                output = [],-                target = Counting,-                mode = Keiki.Live-              }-          ],-      initial = Counting,-      initialRegs = RNil,-      isFinal = \_ -> False-    }--rejectSilentlyCtor :: InCtor SilentChoiceCommand '[]-rejectSilentlyCtor =-  Keiki.unavailableInCtor-    "RejectSilently"-    (\case RejectSilently -> Just RNil; _ -> Nothing)-    (\RNil -> RejectSilently)--noOpSilentlyCtor :: InCtor SilentChoiceCommand '[]-noOpSilentlyCtor =-  Keiki.unavailableInCtor-    "NoOpSilently"-    (\case NoOpSilently -> Just RNil; _ -> Nothing)-    (\RNil -> NoOpSilently)--multiCounterDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent Text Text-multiCounterDomainHandler =-  DomainCommandHandler-    { eventStream = multiCounterEventStream,-      classifySilent = \_ -> error "multiCounterDomainHandler: eventful edge classified as silent"-    }--ambiguousCounterDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent Text Text-ambiguousCounterDomainHandler =-  DomainCommandHandler-    { eventStream = ambiguousCounterEventStream,-      classifySilent = \_ -> error "ambiguousCounterDomainHandler: no edge should be selected"-    }--silentChoiceDomainHandler :: DomainCommandHandler (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent Text Text-silentChoiceDomainHandler =-  DomainCommandHandler-    { eventStream = silentChoiceEventStream,-      classifySilent = \SilentCommandContext {command = selectedCommand, selectedEdge} ->-        case (selectedCommand, Keiki.edgeIndex selectedEdge) of-          (RejectSilently, 0) -> SilentRejected "edge-0: rejected"-          (NoOpSilently, 1) -> SilentNoOp "edge-1: already complete"-          other -> error ("silentChoiceDomainHandler: unexpected selected edge " <> show other)-    }--retryDecisionDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent Text Text-retryDecisionDomainHandler =-  DomainCommandHandler-    { eventStream = retryDecisionEventStream,-      classifySilent = \SilentCommandContext {state, selectedEdge} ->-        case (state, Keiki.edgeIndex selectedEdge) of-          (Drained, 0) -> SilentNoOp "already drained"-          other -> error ("retryDecisionDomainHandler: unexpected selected edge " <> show other)-    }--coordinatorDomainHandler :: DomainCommandHandler (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent Text Text-coordinatorDomainHandler =-  DomainCommandHandler-    { eventStream = coordinatorEventStream,-      classifySilent = \SilentCommandContext {command, selectedEdge} ->-        case (command, Keiki.edgeIndex selectedEdge) of-          (CoordinatorReject reason, 1) -> SilentRejected reason-          (CoordinatorNoOp explanation, 2) -> SilentNoOp explanation-          other -> error ("coordinatorDomainHandler: unexpected selected edge " <> show other)-    }--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,-                mode = Keiki.Live-              },-            Edge-              { guard = matchInCtor sSkipCtor,-                update = UKeep,-                output = [],-                target = Counting,-                mode = Keiki.Live-              }-          ],-      initial = Counting,-      initialRegs = RNil,-      isFinal = \_ -> False-    }--sAddCtor :: InCtor SkipCommand AddFields-sAddCtor =-  Keiki.unavailableInCtor-    "SAdd"-    ( \case-        SAdd amount -> Just (RCons Proxy amount RNil)-        SSkip -> Nothing-    )-    ( \case-        RCons _ amount RNil -> SAdd amount-    )--sSkipCtor :: InCtor SkipCommand '[]-sSkipCtor =-  Keiki.unavailableInCtor-    "SSkip"-    ( \case-        SAdd {} -> Nothing-        SSkip -> Just RNil-    )-    ( \case-        RNil -> SSkip-    )--addCtor :: InCtor CounterCommand AddFields-addCtor =-  Keiki.unavailableInCtor-    "Add"-    ( \case-        Add amount -> Just (RCons Proxy amount RNil)-    )-    ( \case-        RCons _ amount RNil -> Add amount-    )--counterAddedCtor :: WireCtor CounterEvent (Int, ())-counterAddedCtor =-  Keiki.unavailableWireCtor-    "CounterAdded"-    ( \case-        CounterAdded amount -> Just (amount, ())-        CounterAudited {} -> Nothing-    )-    ( \case-        (amount, ()) -> CounterAdded amount-    )--counterAuditedCtor :: WireCtor CounterEvent (Int, ())-counterAuditedCtor =-  Keiki.unavailableWireCtor-    "CounterAudited"-    ( \case-        CounterAudited amount -> Just (amount, ())-        CounterAdded {} -> Nothing-    )-    ( \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"---- * Divert fixture (plan 143: replay-only transitions / black-acuity) -------type DivertEventStream = EventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent--type ValidatedDivertEventStream = ValidatedEventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent--data DivertCommand-  = ConfirmDivert !Bool-  deriving stock (Generic, Eq, Show)--newtype DivertEvent-  = DivertConfirmed Bool-  deriving stock (Generic, Eq, Show)--data DivertState-  = DivertHeld-  deriving stock (Generic, Eq, Show, Enum, Bounded, Ord)--type DivertFields = '[ '("acuityBlack", Bool)]--confirmDivertCtor :: InCtor DivertCommand DivertFields-confirmDivertCtor =-  Keiki.unavailableInCtor-    "ConfirmDivert"-    ( \case-        ConfirmDivert acuityBlack -> Just (RCons Proxy acuityBlack RNil)-    )-    ( \case-        RCons _ acuityBlack RNil -> ConfirmDivert acuityBlack-    )--divertConfirmedCtor :: WireCtor DivertEvent (Bool, ())-divertConfirmedCtor =-  Keiki.unavailableWireCtor-    "DivertConfirmed"-    ( \case-        DivertConfirmed acuityBlack -> Just (acuityBlack, ())-    )-    ( \case-        (acuityBlack, ()) -> DivertConfirmed acuityBlack-    )--divertCodec :: Codec DivertEvent-divertCodec =-  Codec-    { eventTypes = EventType "DivertConfirmed" :| [],-      eventType = \_ -> EventType "DivertConfirmed",-      schemaVersion = 1,-      encode = \case-        DivertConfirmed acuityBlack -> object ["acuityBlack" Aeson..= acuityBlack],-      decode = parseDivertEvent,-      upcasters = []-    }--parseDivertEvent :: EventType -> Value -> Either Text DivertEvent-parseDivertEvent _ value =-  case parseEither parser value of-    Right event -> Right event-    Left message -> Left (fromStringLiteral message)-  where-    parser = withObject "DivertConfirmed" $ \objectValue ->-      DivertConfirmed <$> objectValue .: "acuityBlack"---- | The old rule: confirm any reservation.-divertOldGuard :: HsPred '[] DivertCommand-divertOldGuard = matchInCtor confirmDivertCtor---- | The tightened rule: confirm only non-black acuity.-divertNewGuard :: HsPred '[] DivertCommand-divertNewGuard =-  PAnd-    (matchInCtor confirmDivertCtor)-    (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit False)---- | The removed region, @old ∧ ¬new@: exactly black acuity.-divertRemovedRegionGuard :: HsPred '[] DivertCommand-divertRemovedRegionGuard =-  PAnd-    (matchInCtor confirmDivertCtor)-    (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit True)--divertConfirmEdge ::-  HsPred '[] DivertCommand ->-  Keiki.EdgeMode ->-  Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState-divertConfirmEdge edgeGuard edgeMode =-  Edge-    { guard = edgeGuard,-      update = UKeep,-      output = [pack confirmDivertCtor divertConfirmedCtor (inpCtor confirmDivertCtor #acuityBlack *: oNil)],-      target = DivertHeld,-      mode = edgeMode-    }--divertEventStreamDef ::-  [Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState] ->-  DivertEventStream-divertEventStreamDef heldEdges =-  EventStream-    { transducer =-        SymTransducer-          { edgesOut = \case-              DivertHeld -> heldEdges,-            initial = DivertHeld,-            initialRegs = RNil,-            isFinal = const False-          },-      initialState = DivertHeld,-      initialRegisters = RNil,-      eventCodec = divertCodec,-      resolveStreamName = Stream.streamName,-      snapshotPolicy = Never,-      stateCodec = Nothing-    }---- | Machine A: the original permissive rule.-permissiveDivertEventStream :: ValidatedDivertEventStream-permissiveDivertEventStream =-  mkEventStreamOrThrow-    "divert-permissive"-    (divertEventStreamDef [divertConfirmEdge divertOldGuard Keiki.Live])---- | Machine B without the twin: the tightened rule alone.-tightenedDivertEventStream :: ValidatedDivertEventStream-tightenedDivertEventStream =-  mkEventStreamOrThrow-    "divert-tightened"-    (divertEventStreamDef [divertConfirmEdge divertNewGuard Keiki.Live])---- | Machine B with the replay-only twin carrying the removed region:--- the tightened rule governs new traffic; black-acuity history keeps--- its inverting edge.-twinDivertEventStream :: ValidatedDivertEventStream-twinDivertEventStream =-  mkEventStreamOrThrow-    "divert-twin"-    ( divertEventStreamDef-        [ divertConfirmEdge divertNewGuard Keiki.Live,-          divertConfirmEdge divertRemovedRegionGuard Keiki.ReplayOnly-        ]-    )--domainProcessManager ::-  DomainProcessManager-    DomainDispatchInput-    (HsPred '[] CounterCommand)-    '[]-    CounterState-    CounterCommand-    CounterEvent-    (HsPred '[] CoordinatorCommand)-    '[]-    CounterState-    CoordinatorCommand-    CounterEvent-    Text-    Text-domainProcessManager =-  DomainProcessManager-    { name = "domain-pm",-      correlate = \(DomainDispatchInput correlationId _) -> correlationId,-      eventStream = counterEventStream,-      streamFor = \correlationId -> stream ("domain-pm:" <> correlationId),-      targetHandler = coordinatorDomainHandler,-      targetProjections = const [],-      handle = \(DomainDispatchInput correlationId targetCommands) ->-        ProcessManagerAction-          { command = Add 1,-            commands =-              Prelude.zipWith-                (\targetIndex targetCommand -> PMCommand {target = stream ("domain-pm-target:" <> correlationId <> ":" <> Text.pack (show targetIndex)), command = targetCommand})-                [0 :: Int ..]-                targetCommands,-            timers = []-          }-    }--domainRouter ::-  DomainRouter-    DomainDispatchInput-    (HsPred '[] CoordinatorCommand)-    '[]-    CounterState-    CoordinatorCommand-    CounterEvent-    Text-    Text-    es-domainRouter =-  DomainRouter-    { name = "domain-router",-      key = \(DomainDispatchInput correlationId _) -> correlationId,-      resolve = \(DomainDispatchInput correlationId targetCommands) ->-        pure-          ( Prelude.zipWith-              (\targetIndex targetCommand -> PMCommand {target = stream ("domain-router-target:" <> correlationId <> ":" <> Text.pack (show targetIndex)), command = targetCommand})-              [0 :: Int ..]-              targetCommands-          ),-      targetHandler = coordinatorDomainHandler,-      targetProjections = const []-    }--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 = []-            }-    }--unicodeCounterProcessManager ::-  ProcessManager-    CounterEvent-    (HsPred '[] CounterCommand)-    '[]-    CounterState-    CounterCommand-    CounterEvent-    (HsPred '[] CounterCommand)-    '[]-    CounterState-    CounterCommand-    CounterEvent-unicodeCounterProcessManager =-  counterProcessManager-    { name = "unicode-pm",-      correlate = const "\x4E2D\x6587-42",-      streamFor = const (stream "pm:counter-unicode"),-      handle = \case-        CounterAdded amount ->-          ProcessManagerAction-            { command = Add amount,-              commands = [PMCommand {target = stream "counter-target-unicode", command = Add amount}],-              timers = []-            }-        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)+import Control.Exception (AsyncException (..), ErrorCall, Exception, SomeException, displayException, evaluate, finally, throwIO, try)+import Control.Monad (forM, forM_)+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.ByteString qualified as ByteString+import Data.Char (isDigit)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int32)+import Data.List (isInfixOf)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map+import Data.Maybe (catMaybes)+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.Text.IO qualified as TextIO+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.UUID.V5 qualified as UUID.V5+import Data.Vector qualified as Vector+import Data.Version (showVersion)+import Data.Word (Word64)+import Effectful (Eff, IOE, runEff, (:>))+import Effectful.Error.Static (Error, throwError)+import Effectful.Exception qualified as EffException+import ExternalReadSpec qualified+import GHC.Conc (ThreadStatus (..), threadStatus)+import GroupRebuildSpec qualified+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,+    lit,+    matchInCtor,+    oNil,+    pack,+    proj,+    (*:),+    (.==),+  )+import Keiki.Core qualified as Keiki+import Keiki.Generics (emptyRegFile)+import Keiki.Operators qualified as K+import Keiki.Shape (CanonicalStateShape)+import Keiro+import Keiro qualified as KeiroRoot+import Keiro.Codec.Nominal+  ( NominalBinding (..),+    NominalFixture (..),+    NominalFixtureCases (..),+    nominalDomainRoundTrip,+    nominalRepresentationRoundTrip,+  )+import Keiro.Codec.Structural+  ( StructuralBinding (..),+    bindingDomainRoundTrip,+    bindingShapeRoundTrip,+    decodeViaBinding,+    encodeViaBinding,+  )+import Keiro.Connection (ensureProjectionSchema, qualifyTable, withProjectionSchema)+import Keiro.DeadLetter+  ( DispatchDeadLetter (..),+    DispatcherKind (..),+    listDispatchDeadLetters,+    recordDispatchDeadLetter,+  )+import Keiro.DeadLetter.Replay+  ( ReplayOutcome (..),+    ReplayResult (..),+    listSubscriptionDeadLetters,+    replaySubscriptionDeadLetters,+  )+import Keiro.DeterministicId (deterministicIdProbes, identitySeedBytes, legacySeedBytes)+import Keiro.EventStream (Terminality (..))+import Keiro.EventStream.Validate+  ( EventStreamWarning (..),+    ValidatedEventStream,+    mkEventStream,+    mkEventStreamOrThrow,+    mkEventStreamUnchecked,+    mkEventStreamWith,+    validateEventStream,+  )+import Keiro.Inbox+  ( DelegatedOutcome (..),+    InboxDedupePolicy (..),+    InboxError (..),+    InboxPersistence (..),+    InboxResult (..),+    InboxStatus (..),+    KafkaDeliveryRef (..),+    garbageCollectCompleted,+    listInbox,+    lookupInbox,+    markFailedTx,+    mkDelegatedRetryContext,+    runInboxDelegated,+    runInboxDelegatedBatch,+    runInboxDelegatedWithRetries,+    runInboxTransaction,+    runInboxTransactionBatch,+    runInboxTransactionWith,+    runInboxTransactionWithRetries,+    runInboxTransactionWithRetriesWith,+    sampleInboxBacklog,+  )+import Keiro.Inbox.Delegated+  ( DelegatedCommandError (..),+    delegatedCommand,+    delegatedEventId,+    delegatedFromPMCommand,+  )+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 (..),+    PublishRejectionError (..),+    claimOutboxBatch,+    defaultMaintenanceOptions,+    defaultPublishOptions,+    draftToEvent,+    enqueueIntegrationEventTx,+    freshIntegrationEvent,+    freshOutboxId,+    garbageCollectSent,+    lookupOutbox,+    markOutboxSent,+    mkIntegrationProducer,+    mkOutboxPublishOptions,+    mkPublishRejection,+    outboxMaintenancePass,+    publishClaimedOutbox,+    publishRejectionCode,+    publishRejectionDetail,+    sampleOutboxBacklog,+  )+import Keiro.Outbox qualified as ProducerOutbox+import Keiro.Outbox.Kafka qualified as OutboxKafka+import Keiro.Outbox.Schema (markOutboxFailedTx, markOutboxRejectedTx)+import Keiro.Prelude+import Keiro.ProcessManager+import Keiro.ProcessManager.Reaction qualified as Reaction+import Keiro.Projection+import Keiro.ReadModel+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Keiro.ReplayAudit qualified as ReplayAudit+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 (..),+    withFreshDatabase,+    withFreshResourceStore,+    withFreshResourceStorePrepared,+    withFreshResourceStoreWith,+    withFreshStore,+    withFreshStoreWith,+    withFreshStores2,+    withMigratedSuite,+  )+import Keiro.Timer+import Keiro.Timer qualified as Timer+import Keiro.Wake+  ( WakeReason (..),+    WakeSignal (..),+    neverWake,+    wakeSignalFromStore,+  )+import Keiro.Workflow+  ( LeaseHeartbeat (..),+    PatchId (..),+    StepName (..),+    Workflow,+    WorkflowError (..),+    WorkflowId (..),+    WorkflowIdentityError (..),+    WorkflowJournalEvent (StepRecorded, WorkflowCancelled, WorkflowCompleted, WorkflowContinuedAsNew, WorkflowFailed),+    WorkflowLeaseLost (..),+    WorkflowName (..),+    WorkflowOutcome (..),+    appendJournalEntry,+    appendJournalEntryReturningId,+    awaitStep,+    awakeableAllocStepPrefix,+    awakeableStepPrefix,+    cancelledStepName,+    completedStepName,+    continueAsNew,+    continueSeedStepName,+    continuedAsNewStepName,+    currentGeneration,+    defaultWorkflowRunOptions,+    deterministicJournalId,+    failedStepName,+    findUnfinishedWorkflowIds,+    loadStepIndex,+    mkWorkflowId,+    mkWorkflowName,+    patch,+    patchSetStepName,+    patchStepName,+    restoreSeed,+    runWorkflow,+    runWorkflowWith,+    step,+    stepExists,+    workflowGenerationStreamName,+    workflowJournalCodec,+  )+import Keiro.Workflow.Awakeable+  ( AwakeableId (..),+    WorkflowAwakeableCancelled (..),+    awakeableIdText,+    awakeableIdToUuid,+    awakeableNamed,+    cancelAwakeable,+    signalAwakeable,+    signalAwakeableFrom,+  )+import Keiro.Workflow.Awakeable.Compatibility+  ( generation0AwakeableId,+    preUtf8Generation0AwakeableId,+  )+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+  ( drainWorkflowSleepTimers,+    matchSleepTimerGeneration,+    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 Numeric.Natural (Natural)+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 Paths_keiro qualified as Package+import PreCanonicalRecoverySpec qualified+import PreimageSpec qualified+import ProjectionReplaySpec qualified+import ReactionExample qualified+import ReadModelSpec qualified+import Shibuya.Adapter (Adapter (..))+import Shibuya.Core.Ack (AckDecision (..), DeadLetterReason (..), HaltReason (..), RetryDelay (..), deadLetterCodeText, deadLetterReasonCode, deadLetterReasonDetail, renderDeadLetterReason)+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 VersionedRebuildSpec qualified+import VersionedTargetPostgresSpec qualified+import "hasql-transaction" Hasql.Transaction qualified as Tx++main :: IO ()+main = withMigratedSuite $ \fixture -> hspec $ do+  CatalogSpec.spec+  PreimageSpec.spec+  CatalogEvolutionSpec.spec fixture+  CatalogOperationsSpec.spec fixture+  GroupRebuildSpec.spec fixture+  ExternalReadSpec.spec fixture+  VersionedTargetPostgresSpec.spec fixture+  VersionedRebuildSpec.spec fixture+  PreCanonicalRecoverySpec.spec fixture+  ProjectionReplaySpec.spec fixture+  ReadModelSpec.spec++  describe "catalog-fenced inline projections" $ around (withFreshResourceStore fixture) $ do+    it "rolls back the event append and target write while its group rebuilds" $ \(_storeHandle, StoreRunner runStore) -> do+      validated <-+        case validateProjectionCatalog catalogInlineProjectionCatalog of+          Failure diagnostics ->+            expectationFailure ("catalog fixture failed validation: " <> show diagnostics)+              >> error "unreachable"+          Success value -> pure value+      Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql)+      Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated++      let targetStream = stream "counter-catalog-fence" :: Stream CounterEventStream+      first <-+        runStore $+          runCommandWithCatalogProjections+            defaultRunCommandOptions+            counterEventStream+            targetStream+            (Add 4)+            validated+            catalogInlineProjectionSet+      first `shouldSatisfy` \case+        Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1+        _ -> False+      Right 1 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)++      Right (Right _) <-+        runStore $+          Rebuild.beginGroupRebuild+            validated+            catalogInlineGroupId+            Rebuild.RebuildRequest+              { rebuildRunId = catalogInlineRunId,+                requestedBy = "keiro-test",+                requestReason = "inline fence proof",+                replayFrom = GlobalPosition 0+              }+      Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)++      second <-+        runStore $+          runCommandWithCatalogProjections+            defaultRunCommandOptions+            counterEventStream+            targetStream+            (Add 5)+            validated+            catalogInlineProjectionSet+      second+        `shouldBe` Right (Right (ProjectionCommandFenced catalogInlineGroupId catalogInlineRunId))+      Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)+      Right recorded <-+        runStore $+          Store.readStreamForward (StreamName "counter-catalog-fence") (StreamVersion 0) 10+      Vector.length recorded `shouldBe` 1++      let foreignSource = catalogIdentity mkSourceId "catalog-inline-foreign-source"+          foreignSet = catalogInlineProjectionSet & #projectionSource .~ foreignSource+          foreignStream = stream "counter-catalog-mismatch" :: Stream CounterEventStream+      mismatch <-+        runStore $+          runCommandWithCatalogProjections+            defaultRunCommandOptions+            counterEventStream+            foreignStream+            (Add 6)+            validated+            foreignSet+      mismatch `shouldBe` Right (Right (ProjectionCommandCatalogMismatch foreignSource))+      Right absent <-+        runStore $+          Store.readStreamForward (StreamName "counter-catalog-mismatch") (StreamVersion 0) 10+      Vector.null absent `shouldBe` True++    it "waits for an in-flight writer before preparing and clearing its group" $ \(_storeHandle, StoreRunner runStore) -> do+      validated <-+        case validateProjectionCatalog catalogInlineProjectionCatalog of+          Failure diagnostics ->+            expectationFailure ("catalog fixture failed validation: " <> show diagnostics)+              >> error "unreachable"+          Success value -> pure value+      Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql)+      Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated++      writerDone <- newEmptyMVar+      let targetStream = stream "counter-catalog-lock-order" :: Stream CounterEventStream+      _ <-+        forkIO $+          runStore+            ( runCommandWithCatalogProjections+                defaultRunCommandOptions+                counterEventStream+                targetStream+                (Add 9)+                validated+                catalogSlowInlineProjectionSet+            )+            >>= putMVar writerDone+      threadDelay 200_000+      startedAt <- getCurrentTime+      Right (Right _) <-+        runStore $+          Rebuild.beginGroupRebuild+            validated+            catalogInlineGroupId+            Rebuild.RebuildRequest+              { rebuildRunId = catalogInlineRunId,+                requestedBy = "keiro-test",+                requestReason = "in-flight inline lock proof",+                replayFrom = GlobalPosition 0+              }+      finishedAt <- getCurrentTime++      writer <- takeMVar writerDone+      writer `shouldSatisfy` \case+        Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1+        _ -> False+      diffUTCTime finishedAt startedAt `shouldSatisfy` (> 0.5)+      Right 0 <- runStore $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)+      pure ()++    it "dispatches inline writes through the persisted serving revision before appending" $ \(_storeHandle, StoreRunner runStore) -> do+      validated <- expectValidatedCatalog catalogInlineProjectionCatalog+      v1Only <- expectValidatedCatalog catalogInlineV1Catalog+      Right () <- runStore $ Store.runTransaction (Tx.sql catalogInlineFixtureSql)+      Right (Right _) <- runStore $ Rebuild.registerProjectionCatalog validated+      Right () <- runStore $ Store.runTransaction (Tx.sql seedCatalogInlineVersionedV1Sql)++      let targetStream = stream "counter-versioned-inline" :: Stream CounterEventStream+      first <-+        runStore $+          runCommandWithCatalogProjections+            defaultRunCommandOptions+            counterEventStream+            targetStream+            (Add 4)+            validated+            catalogInlineProjectionSet+      first `shouldSatisfy` \case+        Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1+        _ -> False+      Right [101] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt)++      Right () <- runStore $ Store.runTransaction (Tx.sql promoteCatalogInlineV2Sql)+      second <-+        runStore $+          runCommandWithCatalogProjections+            defaultRunCommandOptions+            counterEventStream+            targetStream+            (Add 5)+            validated+            catalogInlineProjectionSet+      second `shouldSatisfy` \case+        Right (Right (ProjectionCommandApplied result)) -> result ^. #eventsAppended == 1+        _ -> False+      Right [202] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt)++      missing <-+        runStore $+          runCommandWithCatalogProjections+            defaultRunCommandOptions+            counterEventStream+            targetStream+            (Add 6)+            v1Only+            catalogInlineProjectionSet+      missing+        `shouldBe` Right+          ( Right+              ( ProjectionCommandServingRevisionUnavailable+                  catalogInlineGroupId+                  catalogInlineRevisionV2Id+              )+          )+      Right recorded <-+        runStore $+          Store.readStreamForward (StreamName "counter-versioned-inline") (StreamVersion 0) 10+      Vector.length recorded `shouldBe` 2+      Right [202] <- runStore $ Store.runTransaction (Tx.statement () catalogInlineAmountsStmt)+      pure ()++  describe "Keiro" $ do+    it "exposes the package metadata version" $+      KeiroRoot.version `shouldBe` Text.pack (showVersion Package.version)++    it "keeps package metadata as the only version authority" $ do+      source <- TextIO.readFile "src/Keiro.hs"+      source `shouldSatisfy` Text.isInfixOf "showVersion Package.version"+      let isNumericVersionAssignment sourceLine =+            "version =" `Text.isInfixOf` sourceLine+              && Text.count "." sourceLine >= 3+              && Text.any isDigit sourceLine+      Text.lines source `shouldSatisfy` all (not . isNumericVersionAssignment)++  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.Codec.Structural" $ do+    let pairBinding :: StructuralBinding (Int, Bool) (Bool, Int)+        pairBinding =+          StructuralBinding+            { bindingToShape = \(amount, enabled) -> (enabled, amount),+              bindingFromShape = \(enabled, amount) -> (amount, enabled)+            }+        encodePairShape (enabled, amount) =+          object ["enabled" Aeson..= enabled, "amount" Aeson..= amount]+        decodePairShape value =+          case parseEither (withObject "PairShape" $ \objectValue -> (,) <$> objectValue .: "enabled" <*> objectValue .: "amount") value of+            Left err -> Left (Text.pack err)+            Right shape -> Right shape++    it "checks both total binding laws" $ do+      bindingDomainRoundTrip pairBinding (7, True) `shouldBe` True+      bindingShapeRoundTrip pairBinding (False, 9) `shouldBe` True++    it "delegates encoding to the generated shape codec" $+      encodeViaBinding pairBinding encodePairShape (7, True)+        `shouldBe` object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]++    it "propagates only shape decode failures before total construction" $ do+      let encoded = object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]+      decodeViaBinding pairBinding decodePairShape encoded `shouldBe` Right (9, False)+      decodeViaBinding pairBinding (const (Left "shape-error")) Aeson.Null+        `shouldBe` Left "shape-error"++  describe "Keiro.Codec.Nominal" $ do+    let swappedBinding :: NominalBinding (Int, Bool) (Bool, Int)+        swappedBinding =+          NominalBinding+            { nominalToRepresentation = \(amount, enabled) -> (enabled, amount),+              nominalFromRepresentation = \(enabled, amount) -> (amount, enabled)+            }+        fixtures =+          NominalFixtureCases+            ( NominalFixture "enabled" (object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]) (7, True)+                :| [NominalFixture "disabled" (object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]) (9, False)]+            )++    it "checks both total nominal binding laws" $ do+      nominalDomainRoundTrip swappedBinding (7, True) `shouldBe` True+      nominalRepresentationRoundTrip swappedBinding (False, 9) `shouldBe` True++    it "retains labelled expected-wire fixtures" $+      nominalFixtureCases fixtures+        `shouldBe` ( NominalFixture "enabled" (object ["enabled" Aeson..= True, "amount" Aeson..= (7 :: Int)]) (7, True)+                       :| [NominalFixture "disabled" (object ["enabled" Aeson..= False, "amount" Aeson..= (9 :: Int)]) (9, False)]+                   )++  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 duplicate upcaster sources at the stream boundary" $ do+      let duplicateCodec =+            counterCodec+              { schemaVersion = 3,+                upcasters = [(1, const Right), (1, const Right)]+              }+          duplicateStream = counterEventStreamDef {eventCodec = duplicateCodec}+      case mkEventStream "duplicate-codec" duplicateStream of+        Left warnings -> do+          map eswStreamLabel warnings `shouldSatisfy` all (== "duplicate-codec")+          map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "duplicate upcaster source version(s): 1")+        Right _ -> expectationFailure "expected mkEventStream to reject duplicate upcaster sources"++    it "rejects a missing upcaster rung at the stream boundary" $ do+      let incompleteCodec =+            counterCodec+              { schemaVersion = 3,+                upcasters = [(2, const Right)]+              }+          incompleteStream = counterEventStreamDef {eventCodec = incompleteCodec}+      case mkEventStream "incomplete-codec" incompleteStream of+        Left warnings -> do+          map eswStreamLabel warnings `shouldSatisfy` all (== "incomplete-codec")+          map eswReason warnings `shouldSatisfy` any (Text.isInfixOf "missing upcaster source version(s): 1")+        Right _ -> expectationFailure "expected mkEventStream to reject an incomplete upcaster chain"++    it "includes the stream label when throwing for an invalid codec" $ do+      let incompleteCodec =+            counterCodec+              { schemaVersion = 3,+                upcasters = [(2, const Right)]+              }+          incompleteStream = counterEventStreamDef {eventCodec = incompleteCodec}+      result <- try @ErrorCall (evaluate (mkEventStreamOrThrow "throwing-incomplete-codec" incompleteStream))+      case result of+        Left err -> do+          displayException err `shouldSatisfy` isInfixOf "throwing-incomplete-codec"+          displayException err `shouldSatisfy` isInfixOf "missing upcaster source version(s): 1"+        Right _ -> expectationFailure "expected mkEventStreamOrThrow to reject an incomplete upcaster chain"++    it "keeps invalid codecs available through the unchecked escape hatch" $ do+      let duplicateCodec =+            counterCodec+              { schemaVersion = 3,+                upcasters = [(1, const Right), (1, const Right)]+              }+          incompleteCodec =+            counterCodec+              { schemaVersion = 3,+                upcasters = [(2, const Right)]+              }+      _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef {eventCodec = duplicateCodec})+      _ <- evaluate (mkEventStreamUnchecked counterEventStreamDef {eventCodec = incompleteCodec})+      pure ()++    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-" <> showVersion Package.version,+            "test/ReplaySafetyTypeProbe.hs"+          ]+          ""+      exitCode `shouldSatisfy` (/= ExitSuccess)+      stderr `shouldSatisfy` ("ValidatedEventStream" `isInfixOf`)++  describe "Keiro.Command" $ around (withFreshStore fixture) $ do+    describe "typed domain command outcomes" $ do+      it "returns the exact ordered accepted batch and compatibility result" $ \storeHandle -> do+        let target = stream "domain-command-accepted" :: Stream CounterEventStream+        commandResult <-+          Store.runStoreIO storeHandle $+            runDomainCommand defaultRunCommandOptions multiCounterDomainHandler target (Add 4)+        case commandResult of+          Right (Right outcome@DomainCommandOutcome {decision = DomainAccepted events, result}) -> do+            events `shouldBe` (CounterAdded 4 :| [CounterAudited 4])+            result ^. #streamVersion `shouldBe` StreamVersion 2+            result ^. #eventsAppended `shouldBe` 2+            forgetDomainDecision outcome `shouldBe` result+          other -> expectationFailure ("expected typed accepted command, got " <> show other)+        Right recorded <-+          Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "domain-command-accepted") (StreamVersion 0) 10+        traverse (decodeRecorded counterCodec) (Vector.toList recorded)+          `shouldBe` Right [CounterAdded 4, CounterAudited 4]++      it "attributes sibling silent edges and returns typed rejection and no-op" $ \storeHandle -> do+        let rejectionTarget = stream "domain-command-rejected" :: Stream SilentChoiceEventStream+            noOpTarget = stream "domain-command-no-op" :: Stream SilentChoiceEventStream+        rejectionResult <-+          Store.runStoreIO storeHandle $+            runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler rejectionTarget RejectSilently+        case rejectionResult of+          Right (Right outcome@DomainCommandOutcome {decision = DomainRejected reason, result}) -> do+            reason `shouldBe` "edge-0: rejected"+            result ^. #eventsAppended `shouldBe` 0+            result ^. #streamVersion `shouldBe` StreamVersion 0+            result ^. #globalPosition `shouldBe` Nothing+            forgetDomainDecision outcome `shouldBe` result+          other -> expectationFailure ("expected typed domain rejection, got " <> show other)+        noOpResult <-+          Store.runStoreIO storeHandle $+            runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler noOpTarget NoOpSilently+        case noOpResult of+          Right (Right outcome@DomainCommandOutcome {decision = DomainNoOp explanation, result}) -> do+            explanation `shouldBe` "edge-1: already complete"+            result ^. #eventsAppended `shouldBe` 0+            result ^. #streamVersion `shouldBe` StreamVersion 0+            result ^. #globalPosition `shouldBe` Nothing+            forgetDomainDecision outcome `shouldBe` result+          other -> expectationFailure ("expected typed domain no-op, got " <> show other)+        Right rejectedEvents <-+          Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "domain-command-rejected") (StreamVersion 0) 10+        Right noOpEvents <-+          Store.runStoreIO storeHandle $+            Store.readStreamForward (StreamName "domain-command-no-op") (StreamVersion 0) 10+        rejectedEvents `shouldBe` Vector.empty+        noOpEvents `shouldBe` Vector.empty++      it "keeps unmatched and ambiguous selection failures as CommandError" $ \storeHandle -> do+        let unmatchedTarget = stream "domain-command-unmatched" :: Stream SilentChoiceEventStream+            ambiguousTarget = stream "domain-command-ambiguous" :: Stream CounterEventStream+        unmatched <-+          Store.runStoreIO storeHandle $+            runDomainCommand defaultRunCommandOptions silentChoiceDomainHandler unmatchedTarget UnmatchedSilently+        ambiguous <-+          Store.runStoreIO storeHandle $+            runDomainCommand defaultRunCommandOptions ambiguousCounterDomainHandler ambiguousTarget (Add 1)+        unmatched `shouldBe` Right (Left CommandRejected)+        ambiguous `shouldBe` Right (Left (CommandAmbiguous [0, 1]))++      it "retains validated rejection of state-changing silent edges" $ \_ -> do+        case mkEventStream "domain-state-changing-epsilon" stateChangingEpsilonEventStreamDef of+          Left warnings ->+            map eswReason warnings+              `shouldSatisfy` any (Text.isInfixOf "state-changing-epsilon")+          Right _ -> expectationFailure "expected validation to reject a state-changing silent edge"++      it "runs SQL once with the exact accepted event pairs" $ \_ ->+        withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+          let target = stream "domain-command-sql-accepted" :: Stream CounterEventStream+          outcome <-+            runner $+              runDomainCommandWithSqlEvents+                defaultRunCommandOptions+                multiCounterDomainHandler+                target+                (Add 6)+                (\pairs _appendResult -> pure (Prelude.fst <$> pairs))+          case outcome of+            Right+              ( Right+                  ( DomainCommandOutcome {decision = DomainAccepted events, result},+                    Just callbackEvents+                    )+                ) -> do+                events `shouldBe` (CounterAdded 6 :| [CounterAudited 6])+                callbackEvents `shouldBe` NonEmpty.toList events+                result ^. #eventsAppended `shouldBe` 2+            other -> expectationFailure ("expected accepted SQL domain command, got " <> show other)++      it "skips SQL callbacks and inline projections for rejection and no-op" $ \_ ->+        withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+          let rejectionTarget = stream "domain-command-sql-rejected" :: Stream SilentChoiceEventStream+              noOpTarget = stream "domain-command-projection-no-op" :: Stream SilentChoiceEventStream+              callback _ _ = error "silent domain decision invoked SQL callback" :: Tx.Transaction Text+              projection =+                InlineProjection+                  { name = "silent-domain-bomb",+                    apply = \_ _ -> error "silent domain decision invoked projection"+                  }+          rejected <-+            runner $+              runDomainCommandWithSqlEvents+                defaultRunCommandOptions+                silentChoiceDomainHandler+                rejectionTarget+                RejectSilently+                callback+          case rejected of+            Right (Right (DomainCommandOutcome {decision = DomainRejected reason}, Nothing)) ->+              reason `shouldBe` "edge-0: rejected"+            other -> expectationFailure ("expected silent SQL rejection, got " <> show other)+          noOp <-+            runner $+              runDomainCommandWithProjections+                defaultRunCommandOptions+                silentChoiceDomainHandler+                noOpTarget+                NoOpSilently+                [projection]+          case noOp of+            Right (Right DomainCommandOutcome {decision = DomainNoOp explanation, result}) -> do+              explanation `shouldBe` "edge-1: already complete"+              result ^. #eventsAppended `shouldBe` 0+            other -> expectationFailure ("expected silent projection no-op, got " <> show other)++      it "applies inline projections atomically for accepted domain events" $ \_ ->+        withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+          Right () <-+            Store.runStoreIO storeHandle $+              initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+          let target = stream "domain-command-projection-accepted" :: Stream CounterEventStream+          outcome <-+            runner $+              runDomainCommandWithProjections+                defaultRunCommandOptions+                multiCounterDomainHandler+                target+                (Add 7)+                [counterInlineProjection]+          case outcome of+            Right (Right DomainCommandOutcome {decision = DomainAccepted events}) ->+              events `shouldBe` (CounterAdded 7 :| [CounterAudited 7])+            other -> expectationFailure ("expected accepted projected domain command, got " <> show other)+          projected <-+            Store.runStoreIO storeHandle $+              runQuery Nothing counterReadModel "inline"+          projected `shouldBe` Right (Right 7)++      it "preserves catalog outcomes while skipping catalog SQL for silent decisions" $ \_ ->+        withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+          validated <-+            case validateProjectionCatalog catalogInlineProjectionCatalog of+              Failure diagnostics ->+                expectationFailure ("catalog fixture failed validation: " <> show diagnostics)+                  >> error "unreachable"+              Success value -> pure value+          Right () <- runner $ Store.runTransaction (Tx.sql catalogInlineFixtureSql)+          Right (Right _) <- runner $ Rebuild.registerProjectionCatalog validated+          let target = stream "domain-command-catalog-rejected" :: Stream SilentChoiceEventStream+          outcome <-+            runner $+              runDomainCommandWithCatalogProjections+                defaultRunCommandOptions+                silentChoiceDomainHandler+                target+                RejectSilently+                validated+                catalogInlineProjectionSet+          case outcome of+            Right (Right (DomainProjectionCommandApplied DomainCommandOutcome {decision = DomainRejected reason})) ->+              reason `shouldBe` "edge-0: rejected"+            other -> expectationFailure ("expected applied silent catalog decision, got " <> show other)+          Right 0 <- runner $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)+          let acceptedTarget = stream "domain-command-catalog-accepted" :: Stream CounterEventStream+          accepted <-+            runner $+              runDomainCommandWithCatalogProjections+                defaultRunCommandOptions+                multiCounterDomainHandler+                acceptedTarget+                (Add 5)+                validated+                catalogInlineProjectionSet+          case accepted of+            Right (Right (DomainProjectionCommandApplied DomainCommandOutcome {decision = DomainAccepted events})) ->+              events `shouldBe` (CounterAdded 5 :| [CounterAudited 5])+            other -> expectationFailure ("expected applied accepted catalog decision, got " <> show other)+          Right 2 <- runner $ Store.runTransaction (Tx.statement () catalogInlineCountStmt)+          Right (Right _) <-+            runner $+              Rebuild.beginGroupRebuild+                validated+                catalogInlineGroupId+                Rebuild.RebuildRequest+                  { rebuildRunId = catalogInlineRunId,+                    requestedBy = "keiro-test",+                    requestReason = "typed domain catalog fence proof",+                    replayFrom = GlobalPosition 0+                  }+          let fencedTarget = stream "domain-command-catalog-fenced" :: Stream CounterEventStream+          fenced <-+            runner $+              runDomainCommandWithCatalogProjections+                defaultRunCommandOptions+                multiCounterDomainHandler+                fencedTarget+                (Add 8)+                validated+                catalogInlineProjectionSet+          fenced+            `shouldBe` Right (Right (DomainProjectionCommandFenced catalogInlineGroupId catalogInlineRunId))+          Right recorded <-+            runner $+              Store.readStreamForward (StreamName "domain-command-catalog-fenced") (StreamVersion 0) 10+          recorded `shouldBe` Vector.empty+          pure ()++      it "discards an accepted conflict attempt and returns the rehydrated silent decision" $ \_ ->+        withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+          conflictInserted <- newIORef False+          let target = stream "domain-command-conflict-final-no-op" :: Stream RetryDecisionEventStream+              targetStreamName = StreamName "domain-command-conflict-final-no-op"+              insertConflict = do+                shouldInsert <- atomicModifyIORef' conflictInserted $ \inserted -> (True, not inserted)+                when shouldInsert $ do+                  encoded <- shouldBeRight (encodeForAppend counterCodec (CounterAdded 9))+                  appended <-+                    Store.runStoreIO storeHandle $+                      Store.appendToStream targetStreamName NoStream [encoded]+                  case appended of+                    Right _ -> pure ()+                    Left err -> expectationFailure ("failed to inject domain conflict: " <> show err)+              options =+                defaultRunCommandOptions+                  & #beforeAppend+                  .~ insertConflict+                  & #retryBackoffMicros+                  .~ 0+              callback _ _ = error "stale accepted decision invoked SQL callback" :: Tx.Transaction Text+          outcome <-+            runner $+              runDomainCommandWithSqlEvents+                options+                retryDecisionDomainHandler+                target+                (Add 1)+                callback+          case outcome of+            Right (Right (DomainCommandOutcome {decision = DomainNoOp explanation, result}, Nothing)) -> do+              explanation `shouldBe` "already drained"+              result ^. #streamVersion `shouldBe` StreamVersion 1+              result ^. #eventsAppended `shouldBe` 0+            other -> expectationFailure ("expected rehydrated no-op decision, got " <> show other)+          readIORef conflictInserted `shouldReturn` True+          Right recorded <-+            Store.runStoreIO storeHandle $+              Store.readStreamForward targetStreamName (StreamVersion 0) 10+          traverse (decodeRecorded counterCodec) (Vector.toList recorded)+            `shouldBe` Right [CounterAdded 9]++      it "records only bounded decision classes on successful spans and metrics" $ \storeHandle -> do+        (processor, spansRef) <- inMemoryListExporter+        tracerProvider <- createTracerProvider [processor] emptyTracerProviderOptions+        (metricExporter, metricsRef) <- inMemoryMetricExporter+        (meterProvider, _env) <-+          createMeterProvider+            emptyMaterializedResources+            defaultSdkMeterProviderOptions {metricExporter = Just metricExporter}+        meter <- getMeter meterProvider Telemetry.keiroInstrumentationLibrary+        keiroMetrics <- Telemetry.newKeiroMetrics meter+        let tracer = makeTracer tracerProvider "keiro-test" tracerOptions+            options =+              defaultRunCommandOptions+                & #tracer+                ?~ tracer+                & #metrics+                ?~ keiroMetrics+        Right (Right _) <-+          Store.runStoreIO storeHandle $+            runDomainCommand options multiCounterDomainHandler (stream "domain-telemetry-accepted") (Add 1)+        Right (Right _) <-+          Store.runStoreIO storeHandle $+            runDomainCommand options silentChoiceDomainHandler (stream "domain-telemetry-rejected") RejectSilently+        Right (Right _) <-+          Store.runStoreIO storeHandle $+            runDomainCommand options silentChoiceDomainHandler (stream "domain-telemetry-no-op") NoOpSilently+        _ <- shutdownTracerProvider tracerProvider Nothing+        _ <- forceFlushMeterProvider meterProvider Nothing+        spans <- traverse captureSpan =<< readIORef spansRef+        fmap (\sp -> textAttr (csAttributes sp) "keiro.command.decision") spans+          `shouldMatchList` [Just "accepted", Just "rejected", Just "no_op"]+        fmap csStatus spans `shouldSatisfy` all (== Unset)+        fmap (\sp -> textAttr (csAttributes sp) "error.type") spans+          `shouldSatisfy` all (== Nothing)+        exported <- readIORef metricsRef+        let decisionPoints =+              [ (textAttr attrs "keiro.command.decision", value)+              | (name, value, attrs) <- flattenScalarPointsWithAttributes exported,+                name == "keiro.command.decisions"+              ]+        decisionPoints+          `shouldMatchList` [ (Just "accepted", IntNumber 1),+                              (Just "rejected", IntNumber 1),+                              (Just "no_op", IntNumber 1)+                            ]++      it "keeps all five process-manager target outcomes distinguishable" $ \_ ->+        withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+          let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+              input =+                DomainDispatchInput+                  "five-outcomes"+                  [ CoordinatorAccept 3,+                    CoordinatorReject "private rejection",+                    CoordinatorNoOp "private no-op",+                    CoordinatorUnmatched+                  ]+          first <-+            runner $+              runDomainProcessManagerOnce+                defaultRunCommandOptions+                domainProcessManager+                sourceEvent+                input+          case first of+            Right (Right result) -> do+              result ^. #managerResult `shouldSatisfy` \case+                PMStateAppended {} -> True+                _ -> False+              case result ^. #commandResults of+                [ DomainPMCommandHandled DomainCommandOutcome {decision = DomainAccepted events},+                  DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected reason},+                  DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp explanation},+                  DomainPMCommandFailed _ CommandRejected+                  ] -> do+                    events `shouldBe` (CounterAdded 3 :| [])+                    reason `shouldBe` "private rejection"+                    explanation `shouldBe` "private no-op"+                other -> expectationFailure ("expected four fresh domain PM outcomes, got " <> show other)+            other -> expectationFailure ("expected domain process-manager success, got " <> show other)+          second <-+            runner $+              runDomainProcessManagerOnce+                defaultRunCommandOptions+                domainProcessManager+                sourceEvent+                input+          case second of+            Right (Right result) -> do+              result ^. #managerResult `shouldSatisfy` \case+                PMStateDuplicate {} -> True+                _ -> False+              result ^. #commandResults `shouldSatisfy` \case+                [ DomainPMCommandDuplicate {},+                  DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected "private rejection"},+                  DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp "private no-op"},+                  DomainPMCommandFailed _ CommandRejected+                  ] -> True+                _ -> False+            other -> expectationFailure ("expected domain process-manager redelivery, got " <> show other)++      it "keeps all five router target outcomes distinguishable" $ \_ ->+        withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+          let sourceEvent = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)+              input =+                DomainDispatchInput+                  "five-outcomes"+                  [ CoordinatorAccept 4,+                    CoordinatorReject "router rejection",+                    CoordinatorNoOp "router no-op",+                    CoordinatorUnmatched+                  ]+          Right (DomainRouterResult first) <-+            runner $+              runDomainRouterOnce+                defaultRunCommandOptions+                domainRouter+                sourceEvent+                input+          case first of+            [ DomainPMCommandHandled DomainCommandOutcome {decision = DomainAccepted events},+              DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected reason},+              DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp explanation},+              DomainPMCommandFailed _ CommandRejected+              ] -> do+                events `shouldBe` (CounterAdded 4 :| [])+                reason `shouldBe` "router rejection"+                explanation `shouldBe` "router no-op"+            other -> expectationFailure ("expected four fresh domain router outcomes, got " <> show other)+          Right (DomainRouterResult second) <-+            runner $+              runDomainRouterOnce+                defaultRunCommandOptions+                domainRouter+                sourceEvent+                input+          second `shouldSatisfy` \case+            [ DomainPMCommandDuplicate {},+              DomainPMCommandHandled DomainCommandOutcome {decision = DomainRejected "router rejection"},+              DomainPMCommandHandled DomainCommandOutcome {decision = DomainNoOp "router no-op"},+              DomainPMCommandFailed _ CommandRejected+              ] -> True+            _ -> False++      it "acks domain rejection and no-op in coordinator workers without leaking payloads" $ \_ ->+        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+          processManagerDecisions <- newIORef []+          routerDecisions <- newIORef []+          let rejectionPayload = "pm-private-rejection-payload"+              noOpPayload = "router-private-no-op-payload"+              processManagerSource = recordedFromEventId (EventId sampleUuid3) (CounterAdded 1)+              routerSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 1)+              processManagerInput = DomainDispatchInput "worker-pm" [CoordinatorReject rejectionPayload, CoordinatorNoOp "pm no-op"]+              routerInput = DomainDispatchInput "worker-router" [CoordinatorReject "router rejection", CoordinatorNoOp noOpPayload]+              processManagerAdapter = inMemoryAdapter processManagerDecisions [(processManagerSource, processManagerInput)]+              routerAdapter = inMemoryAdapter routerDecisions [(routerSource, routerInput)]+              workerOptions = defaultWorkerOptions & #metrics ?~ keiroMetrics+              commandOptions = defaultRunCommandOptions & #metrics ?~ keiroMetrics+          Right () <-+            runner $+              runDomainProcessManagerWorkerWith+                workerOptions+                commandOptions+                domainProcessManager+                processManagerAdapter+                Just+          Right () <-+            runner $+              runDomainRouterWorkerWith+                workerOptions+                commandOptions+                domainRouter+                routerAdapter+                Just+          readIORef processManagerDecisions `shouldReturn` [AckOk]+          readIORef routerDecisions `shouldReturn` [AckOk]+          Right processManagerDeadLetters <- runner (listDispatchDeadLetters "domain-pm")+          Right routerDeadLetters <- runner (listDispatchDeadLetters "domain-router")+          processManagerDeadLetters `shouldBe` []+          routerDeadLetters `shouldBe` []+          _ <- forceFlushMeterProvider provider Nothing+          exported <- readIORef metricsRef+          lookup "keiro.dispatch.failed" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 0)+          let rendered = Text.pack (show exported)+          Text.isInfixOf rejectionPayload rendered `shouldBe` False+          Text.isInfixOf noOpPayload rendered `shouldBe` False++    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 "fails hydration after guard tightening without a replay-only twin (plan 143 reproduction)" $ \storeHandle -> do+      let target = stream "divert-black-acuity-bad" :: Stream DivertEventStream+      Right (Right appended) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True)+      appended ^. #streamVersion `shouldBe` StreamVersion 1+      result <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions tightenedDivertEventStream target (ConfirmDivert False)+      result+        `shouldBe` Right+          (Left (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge))++    it "replays black-acuity history through the replay-only twin and keeps serving the live rule" $ \storeHandle -> do+      let target = stream "divert-black-acuity-good" :: Stream DivertEventStream+      Right (Right appended) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True)+      appended ^. #streamVersion `shouldBe` StreamVersion 1+      result <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert False)+      case result of+        Right (Right commandResult) -> do+          commandResult ^. #streamVersion `shouldBe` StreamVersion 2+          commandResult ^. #eventsAppended `shouldBe` 1+        other ->+          expectationFailure ("expected hydration through the twin to succeed, got " <> show other)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "divert-black-acuity-good") (StreamVersion 0) 10+      traverse (decodeRecorded divertCodec) (Vector.toList recorded)+        `shouldBe` Right [DivertConfirmed True, DivertConfirmed False]++    it "rejects a new command in the removed region under the twin-bearing machine" $ \storeHandle -> do+      let target = stream "divert-black-acuity-removed" :: Stream DivertEventStream+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True)+      result <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions twinDivertEventStream target (ConfirmDivert True)+      result `shouldBe` Right (Left CommandRejected)+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "divert-black-acuity-removed") (StreamVersion 0) 10+      Vector.length recorded `shouldBe` 1++    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 "invalidates a snapshot when the control-state shape changes" $ \storeHandle -> do+      let targetStreamName = StreamName "snapshot-state-shape-change"+          target = stream "snapshot-state-shape-change" :: Stream SnapshotCounterEventStream+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 2)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add 3)+      lookupResult <-+        Store.runStoreIO storeHandle $+          lookupSnapshotSeed+            targetStreamName+            (defaultStateCodec @SnapshotCounterRegs @CounterStateV2 1)+      case lookupResult of+        Right (SnapshotUnavailable SnapshotNotFound) -> pure ()+        _ -> expectationFailure "expected the changed control-state shape to miss the stored snapshot"++    it "uses the fold fingerprint as a snapshot discriminator" $ \storeHandle -> do+      let targetStreamName = StreamName "snapshot-fold-fingerprint-lookup"+          target = stream "snapshot-fold-fingerprint-lookup" :: Stream SnapshotCounterEventStream+          foldV1Codec =+            defaultStateCodecWithFold+              @SnapshotCounterRegs+              @CounterState+              (FoldVersion "fold-v1")+              1+          foldV2Codec =+            defaultStateCodecWithFold+              @SnapshotCounterRegs+              @CounterState+              (FoldVersion "fold-v2")+              1+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3)+      sameFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV1Codec+      case sameFingerprint of+        Right (SnapshotHit seed) -> seed ^. #streamVersion `shouldBe` StreamVersion 2+        _ -> expectationFailure "expected an equal fold fingerprint to reuse the snapshot"+      changedFingerprint <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName foldV2Codec+      case changedFingerprint of+        Right (SnapshotUnavailable SnapshotNotFound) -> pure ()+        _ -> expectationFailure "expected a changed fold fingerprint to miss the snapshot"++    it "composes the hand-owned fold version into the state discriminator" $ \_storeHandle -> do+      let plain = defaultStateCodec @SnapshotCounterRegs @CounterState 1+          withFold =+            defaultStateCodecWithFold+              @SnapshotCounterRegs+              @CounterState+              (FoldVersion "fold-v1")+              1+      withFold ^. #stateShapeHash `shouldBe` (plain ^. #stateShapeHash <> ";fold=fold-v1")+      withFold ^. #stateCodecVersion `shouldBe` plain ^. #stateCodecVersion+      withFold ^. #shapeHash `shouldBe` plain ^. #shapeHash++    it "full-replays under a changed fold and persists the new discriminator" $ \storeHandle -> do+      let targetStreamName = "snapshot-fold-fingerprint-e2e"+          target = stream targetStreamName :: Stream SnapshotCounterEventStream+          candidateCodec =+            defaultStateCodecWithFold+              @SnapshotCounterRegs+              @CounterState+              (FoldVersion "fold-v2")+              1+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3)+      case Keiki.applyEventsEither+        foldV2SnapshotCounterTransducer+        (Counting, RCons (Proxy @"lastAmount") 0 RNil)+        [CounterAdded 2, CounterAdded 3] of+        Right (_, RCons _ fullReplayLastAmount RNil) ->+          fullReplayLastAmount `shouldBe` 4+        Left failure ->+          expectationFailure ("expected full replay under fold v2, got " <> show failure)+      candidateResult <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV2SnapshotCounterEventStream target (Add 104)+      case candidateResult of+        Right (Right result) -> do+          result ^. #streamVersion `shouldBe` StreamVersion 3+          result ^. #eventsAppended `shouldBe` 1+        other -> expectationFailure ("expected changed-fold full replay to accept probe command, got " <> show other)+      Right storedStateShape <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement targetStreamName snapshotStateShapeForStreamStmt+      storedStateShape `shouldBe` Just (candidateCodec ^. #stateShapeHash)++    it "pins the manual-contract hazard when fold logic changes without a discriminator bump" $ \storeHandle -> do+      let targetStreamName = StreamName "snapshot-fold-manual-contract"+          target = stream "snapshot-fold-manual-contract" :: Stream SnapshotCounterEventStream+          unchangedCodec =+            defaultStateCodecWithFold+              @SnapshotCounterRegs+              @CounterState+              (FoldVersion "fold-v1")+              1+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3)+      staleSeed <- Store.runStoreIO storeHandle $ lookupSnapshotSeed targetStreamName unchangedCodec+      case staleSeed of+        Right (SnapshotHit seed) ->+          case seed ^. #registers of+            RCons _ staleLastAmount RNil -> staleLastAmount `shouldBe` 3+        _ -> expectationFailure "expected the unchanged discriminator to serve the stale seed"+      residualResult <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV2WithoutFingerprintBumpEventStream target (Add 104)+      residualResult `shouldBe` Right (Left CommandRejected)++    it "samples a stale accepted seed without failing the command or writing a snapshot" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      let targetName = "snapshot-seed-sampled-divergence"+          target = stream targetName :: Stream SnapshotCounterEventStream+          candidateStream :: ValidatedSnapshotCounterEventStream+          candidateStream =+            mkEventStreamOrThrow+              "snapshot-counter-fold-v2-sampled"+              (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never)+          options =+            defaultRunCommandOptions+              & #metrics+              ?~ keiroMetrics+              & #seedVerifySampleRate+              .~ 1+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3)+      result <-+        Store.runStoreIO storeHandle $+          runCommand options candidateStream target (Add 4)+      case result of+        Right (Right commandResult) -> do+          commandResult ^. #streamVersion `shouldBe` StreamVersion 3+          commandResult ^. #eventsAppended `shouldBe` 1+        other -> expectationFailure ("expected sampled verification to stay advisory, got " <> show other)+      observed <-+        timeout 5_000_000 $+          let awaitDivergence = do+                _ <- forceFlushMeterProvider provider Nothing+                exported <- readIORef metricsRef+                case lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) of+                  Just (IntNumber 1) -> pure ()+                  _ -> threadDelay 10_000 >> awaitDivergence+           in awaitDivergence+      observed `shouldBe` Just ()+      Right snapshotVersion <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement targetName snapshotVersionForStreamStmt+      snapshotVersion `shouldBe` Just (StreamVersion 2)++    it "disables sampled seed verification at rate zero" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      let targetName = "snapshot-seed-sampling-disabled"+          target = stream targetName :: Stream SnapshotCounterEventStream+          candidateStream :: ValidatedSnapshotCounterEventStream+          candidateStream =+            mkEventStreamOrThrow+              "snapshot-counter-fold-v2-sampling-disabled"+              (foldV2WithoutFingerprintBumpEventStreamDef & #snapshotPolicy .~ Never)+          options =+            defaultRunCommandOptions+              & #metrics+              ?~ keiroMetrics+              & #seedVerifySampleRate+              .~ 0+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 2)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 3)+      Right (Right commandResult) <-+        Store.runStoreIO storeHandle $+          runCommand options candidateStream target (Add 4)+      commandResult ^. #streamVersion `shouldBe` StreamVersion 3+      threadDelay 100_000+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      lookup "keiro.snapshot.seed.divergence" (flattenScalarPoints exported) `shouldBe` Nothing+      Right snapshotVersion <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement targetName snapshotVersionForStreamStmt+      snapshotVersion `shouldBe` Just (StreamVersion 2)++    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,+                stateShapeHash = rollbackCodec ^. #stateShapeHash+              }+      Right snapshotVersionAfter <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement "snapshot-codec-rollback-overwrite" snapshotVersionForStreamStmt+      snapshotVersionAfter `shouldBe` Just (StreamVersion 2)++  describe "Keiro.ReplayAudit" $ around (withFreshStore fixture) $ do+    it "accepts only stream names in the configured category" $ \_ -> do+      ReplayAudit.streamInCategory "counter" (StreamName "counter-one")+        `shouldBe` (Just (Stream.Stream (StreamName "counter-one")) :: Maybe (Stream ()))+      ReplayAudit.streamInCategory "counter" (StreamName "other-one")+        `shouldBe` (Nothing :: Maybe (Stream ()))++    it "catches a removed inverting edge while skipping unaffected streams" $ \storeHandle -> do+      let affectedTarget =+            stream "auditremove-affected" :: Stream CounterEventStream+          unaffectedTarget =+            stream "auditremove-unaffected" :: Stream CounterEventStream+          affected =+            ReplayAudit.AffectedSet+              { affectedEventTypes = Set.singleton (EventType "CounterAdded"),+                includeSnapshotStreams = False+              }+          budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 2+          candidateTarget =+            ReplayAudit.AuditTarget+              { eventStream = auditedCounterEventStream,+                category = "auditremove",+                mkStream = Just . Stream.Stream+              }+          deployedTarget =+            ReplayAudit.AuditTarget+              { eventStream = counterEventStream,+                category = "auditremove",+                mkStream = Just . Stream.Stream+              }+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream affectedTarget (Add 7)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions auditedCounterEventStream unaffectedTarget (Add 9)++      Right candidateReport <-+        Store.runStoreIO storeHandle $+          ReplayAudit.auditStreams+            (ReplayAudit.AuditTargeted affected)+            budget+            candidateTarget+      candidateReport ^. #streamsSelected `shouldBe` 1+      candidateReport ^. #streamsSkipped `shouldBe` 1+      candidateReport ^. #failures `shouldBe` 1+      candidateReport ^. #divergences `shouldBe` 0+      candidateReport ^. #rejectedStreams `shouldBe` []+      case candidateReport ^. #results of+        [ ReplayAudit.StreamAuditResult+            _+            ( ReplayAudit.ReplayFailed+                (HydrationReplayFailed _ HydrationNoInvertingEdge)+              )+          ] -> pure ()+        other ->+          expectationFailure+            ("expected a no-inverting-edge audit failure, got " <> show other)++      Right deployedReport <-+        Store.runStoreIO storeHandle $+          ReplayAudit.auditStreams+            (ReplayAudit.AuditTargeted affected)+            budget+            deployedTarget+      ReplayAudit.auditExitCode [deployedReport] `shouldBe` 0++      Right eventsAfterAudit <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward+            (StreamName "auditremove-affected")+            (StreamVersion 0)+            10+      Vector.length eventsAfterAudit `shouldBe` 1++    it "proves a replay-only twin preserves the stored guard-tightening history" $ \storeHandle -> do+      let target = stream "divert-audit-replay-only" :: Stream DivertEventStream+          affected =+            ReplayAudit.AffectedSet+              { affectedEventTypes = Set.singleton (EventType "DivertConfirmed"),+                includeSnapshotStreams = False+              }+          budget = ReplayAudit.defaultAuditBudget & #parallelism .~ 1+          auditWith candidate =+            ReplayAudit.auditStreams+              (ReplayAudit.AuditTargeted affected)+              budget+              ReplayAudit.AuditTarget+                { eventStream = candidate,+                  category = "divert",+                  mkStream = Just . Stream.Stream+                }+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions permissiveDivertEventStream target (ConfirmDivert True)++      Right withoutTwin <-+        Store.runStoreIO storeHandle $+          auditWith tightenedDivertEventStream+      withoutTwin ^. #results+        `shouldBe` [ ReplayAudit.StreamAuditResult+                       (StreamName "divert-audit-replay-only")+                       ( ReplayAudit.ReplayFailed+                           (HydrationReplayFailed (StreamVersion 1) HydrationNoInvertingEdge)+                       )+                   ]+      ReplayAudit.auditExitCode [withoutTwin] `shouldBe` 1++      Right withTwin <-+        Store.runStoreIO storeHandle $+          auditWith twinDivertEventStream+      withTwin ^. #results+        `shouldBe` [ ReplayAudit.StreamAuditResult+                       (StreamName "divert-audit-replay-only")+                       ReplayAudit.ReplayOk+                         { ReplayAudit.streamVersion = StreamVersion 1,+                           ReplayAudit.digest = Nothing+                         }+                   ]+      ReplayAudit.auditExitCode [withTwin] `shouldBe` 0++    it "reports a stale accepted snapshot seed as a divergence" $ \storeHandle -> do+      let target =+            stream "auditfold-stale" :: Stream SnapshotCounterEventStream+          auditTarget =+            ReplayAudit.AuditTarget+              { eventStream = foldV2WithoutFingerprintBumpEventStream,+                category = "auditfold",+                mkStream = Just . Stream.Stream+              }+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 7)+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions foldV1SnapshotCounterEventStream target (Add 8)++      Right outcome <-+        Store.runStoreIO storeHandle $+          ReplayAudit.auditStream auditTarget target+      case outcome of+        ReplayAudit.SeedDivergence+          { seedVersion = StreamVersion 2,+            seededDigest,+            fullDigest+          } ->+            seededDigest `shouldNotBe` fullDigest+        other ->+          expectationFailure+            ("expected a stale-seed divergence, got " <> show other)++    it "keeps clean digests stable and resumes without re-auditing" $ \storeHandle -> do+      let targets =+            [ stream "auditclean-one" :: Stream SnapshotCounterEventStream,+              stream "auditclean-two" :: Stream SnapshotCounterEventStream+            ]+          affected =+            ReplayAudit.AffectedSet+              { affectedEventTypes = Set.singleton (EventType "CounterAdded"),+                includeSnapshotStreams = False+              }+          auditTarget =+            ReplayAudit.AuditTarget+              { eventStream = snapshotCounterEventStream,+                category = "auditclean",+                mkStream = Just . Stream.Stream+              }+          unbounded = ReplayAudit.defaultAuditBudget & #parallelism .~ 2+      for_ (zip targets [10, 20]) $ \(target, amount) -> do+        Right (Right _) <-+          Store.runStoreIO storeHandle $+            runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add amount)+        Right (Right _) <-+          Store.runStoreIO storeHandle $+            runCommand defaultRunCommandOptions snapshotCounterEventStream target (Add (amount + 1))+        pure ()++      Right firstFull <-+        Store.runStoreIO storeHandle $+          ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget+      Right secondFull <-+        Store.runStoreIO storeHandle $+          ReplayAudit.auditStreams ReplayAudit.AuditFull unbounded auditTarget+      firstFull ^. #streamsSelected `shouldBe` 2+      firstFull ^. #streamsSkipped `shouldBe` 0+      firstFull ^. #results `shouldBe` secondFull ^. #results++      Right firstPage <-+        Store.runStoreIO storeHandle $+          ReplayAudit.auditStreams+            (ReplayAudit.AuditTargeted affected)+            (unbounded & #maxStreams ?~ 1)+            auditTarget+      firstPage ^. #streamsSelected `shouldBe` 1+      firstPage ^. #checkpoint `shouldSatisfy` isJust+      Right secondPage <-+        Store.runStoreIO storeHandle $+          ReplayAudit.auditStreams+            (ReplayAudit.AuditTargeted affected)+            ( unbounded+                & #maxStreams+                ?~ 1+                & #resumeFrom+                .~ (firstPage ^. #checkpoint)+            )+            auditTarget+      secondPage ^. #streamsSelected `shouldBe` 1+      let firstNames = Set.fromList ((^. #streamName) <$> firstPage ^. #results)+          secondNames = Set.fromList ((^. #streamName) <$> secondPage ^. #results)+      Set.disjoint firstNames secondNames `shouldBe` True+      firstNames <> secondNames+        `shouldBe` Set.fromList (Stream.streamName <$> targets)++      Right targeted <-+        Store.runStoreIO storeHandle $+          ReplayAudit.auditStreams+            (ReplayAudit.AuditTargeted affected)+            unbounded+            auditTarget+      targeted ^. #results `shouldBe` firstFull ^. #results++  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)+        truthfulResult <-+          Store.runStoreIO storeHandle $+            runQueryWithFreshness Nothing Immediate counterImmediateReadModel "inline"+        truthfulResult `shouldBe` queryResult++    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 "returns no subscription position for an empty durable inventory" $ \_ -> do+      let inventory =+            KirokuSub.SubscriptionCheckpointInventory+              (GlobalPosition 17)+              Vector.empty+      subscriptionPositionFromInventory (SubscriptionName "missing") inventory+        `shouldBe` Nothing++    it "returns the newest visible position after a stream is hard deleted" $ \storeHandle -> do+      let target = stream "read-model-captured-head" :: Stream CounterEventStream+      Right (Right commandResult) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 1)+      capturedPosition <- case commandResult ^. #globalPosition of+        Just position -> pure position+        Nothing -> expectationFailure "expected command global position" *> error "unreachable"+      Right (Just _) <-+        Store.runStoreIO storeHandle $+          Store.hardDeleteStream (StreamName "read-model-captured-head")+      observedHead <- Store.runStoreIO storeHandle storeHeadPosition+      observedHead `shouldBe` Right (GlobalPosition 0)+      Right (KirokuSub.SubscriptionCheckpointInventory authoritativePosition _) <-+        Store.runStoreIO storeHandle Store.subscriptionCheckpointInventory+      authoritativePosition `shouldBe` capturedPosition++    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)+      truthfulResult <-+        Store.runStoreIO storeHandle $+          runQueryWithFreshness+            Nothing+            (WaitForHead EntireVisibleLog)+            counterCursorReadModel+            "empty"+      truthfulResult `shouldBe` queryResult++    it "rejects truthful waits when an immediate inline model has no cursor" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterImmediateReadModel initializeCounterReadModelTable+      queryResult <-+        Store.runStoreIO storeHandle $+          runQueryWithFreshness+            Nothing+            (WaitForHead EntireVisibleLog)+            counterImmediateReadModel+            "inline"+      queryResult+        `shouldBe` Right+          ( Left+              ( ReadModelMissingCursor+                  "counter-read-model"+                  (WaitForHead EntireVisibleLog)+              )+          )++    it "waitFor fails fast on a cursorless model instead of burning the timeout" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      startedAt <- getCurrentTime+      waitResult <-+        Store.runStoreIO storeHandle $+          waitFor (Just keiroMetrics) defaultHeadWaitOptions counterImmediateReadModel (GlobalPosition 5)+      finishedAt <- getCurrentTime+      waitResult+        `shouldBe` Right+          ( Left+              ( ReadModelMissingCursor+                  "counter-read-model"+                  (WaitForPosition (defaultHeadWaitOptions & #target ?~ GlobalPosition 5))+              )+          )+      diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2)+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      lookup "keiro.projection.wait.timeouts" (flattenScalarPoints exported) `shouldBe` Nothing++    it "deprecated Strong and PositionWait overrides fail fast on a cursorless model" $ \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 counterImmediateReadModel initializeCounterReadModelTable+      let target = stream "read-model-cursorless-strong" :: Stream CounterEventStream+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand defaultRunCommandOptions counterEventStream target (Add 5)+      startedAt <- getCurrentTime+      strongResult <-+        Store.runStoreIO storeHandle $+          runQueryWith (Just keiroMetrics) Strong counterImmediateReadModel "inline"+      finishedAt <- getCurrentTime+      strongResult+        `shouldBe` Right+          (Left (ReadModelMissingCursor "counter-read-model" (WaitForHead EntireVisibleLog)))+      diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2)+      truthfulResult <-+        Store.runStoreIO storeHandle $+          runQueryWithFreshness Nothing (WaitForHead EntireVisibleLog) counterImmediateReadModel "inline"+      truthfulResult `shouldBe` strongResult+      positionResult <-+        Store.runStoreIO storeHandle $+          runQueryWith+            (Just keiroMetrics)+            (PositionWait (fastWaitOptions & #target .~ Just (GlobalPosition 5)))+            counterImmediateReadModel+            "inline"+      positionResult+        `shouldBe` Right+          ( Left+              ( ReadModelMissingCursor+                  "counter-read-model"+                  (WaitForPosition (fastWaitOptions & #target .~ Just (GlobalPosition 5)))+              )+          )+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      lookup "keiro.projection.wait.timeouts" (flattenScalarPoints exported) `shouldBe` Nothing++    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 and WaitForHead return promptly after workflow GC hard-deletes the newest events" $ \_ ->+      withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+        Right () <-+          Store.runStoreIO storeHandle $+            initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+        Right (Right commandResult) <-+          runner $+            runCommandWithProjections+              defaultRunCommandOptions+              counterEventStream+              (stream "read-model-gc-strong" :: Stream CounterEventStream)+              (Add 5)+              [counterInlineProjection]+        visiblePosition <- 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 visiblePosition)+                upsertSubscriptionCursorStmt++        counter <- newIORef (0 :: Int)+        Right (Completed _) <-+          Store.runStoreIO storeHandle $+            runWorkflowWith+              (defaultWorkflowRunOptions & #snapshotPolicy .~ OnTerminal)+              (WorkflowName "gc-strong-wf")+              (WorkflowId "gsw-1")+              (demoWorkflow counter)+        now <- getCurrentTime+        Right summary <-+          Store.runStoreIO storeHandle $+            WorkflowGc.gcWorkflowsOnce+              (addUTCTime 1 now)+              WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10}+        summary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1}++        observedHead <- Store.runStoreIO storeHandle storeHeadPosition+        observedHead `shouldBe` Right visiblePosition+        Right (KirokuSub.SubscriptionCheckpointInventory authoritativePosition _) <-+          Store.runStoreIO storeHandle Store.subscriptionCheckpointInventory+        authoritativePosition `shouldSatisfy` (> visiblePosition)++        startedAt <- getCurrentTime+        queryResult <-+          Store.runStoreIO storeHandle $+            runQueryWith Nothing Strong counterReadModel "inline"+        finishedAt <- getCurrentTime+        queryResult `shouldBe` Right (Right 5)+        diffUTCTime finishedAt startedAt `shouldSatisfy` (< 2)++        truthfulStartedAt <- getCurrentTime+        truthfulResult <-+          Store.runStoreIO storeHandle $+            runQueryWithFreshness+              Nothing+              (WaitForHead EntireVisibleLog)+              counterCursorReadModel+              "inline"+        truthfulFinishedAt <- getCurrentTime+        truthfulResult `shouldBe` queryResult+        diffUTCTime truthfulFinishedAt truthfulStartedAt `shouldSatisfy` (< 2)++    it "Strong and WaitForHead still time out when visible events outrun the subscription" $ \_ ->+      withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+        Right () <-+          Store.runStoreIO storeHandle $+            initializeRegisteredReadModel counterReadModel initializeCounterReadModelTable+        Right (Right commandResult) <-+          runner $+            runCommandWithProjections+              defaultRunCommandOptions+              counterEventStream+              (stream "read-model-strong-visible-behind" :: Stream CounterEventStream)+              (Add 5)+              [counterInlineProjection]+        visiblePosition <- case commandResult ^. #globalPosition of+          Just position -> pure position+          Nothing -> expectationFailure "expected command global position" *> error "unreachable"+        queryResult <-+          Store.runStoreIO storeHandle $+            runQueryWith Nothing Strong counterReadModel "inline"+        queryResult+          `shouldBe` Right+            ( Left+                ( ReadModelWaitTimeout+                    "counter-read-model"+                    visiblePosition+                    (GlobalPosition 0)+                )+            )+        truthfulResult <-+          Store.runStoreIO storeHandle $+            runQueryWithFreshness+              Nothing+              (WaitForHead EntireVisibleLog)+              counterCursorReadModel+              "inline"+        truthfulResult `shouldBe` queryResult++    it "Strong and WaitForHead return when their 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)+        truthfulResult <-+          Store.runStoreIO storeHandle $+            runQueryWithFreshness+              Nothing+              (WaitForHead (CategoryVisibleHead "counter"))+              counterCursorReadModel+              "inline"+        truthfulResult `shouldBe` queryResult++    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)+        truthfulResult <-+          Store.runStoreIO storeHandle $+            runQueryWithFreshness+              Nothing+              (WaitForPosition (fastWaitOptions & #target .~ Just globalPosition))+              counterCursorReadModel+              "inline"+        truthfulResult `shouldBe` queryResult++    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)))+      truthfulResult <-+        Store.runStoreIO storeHandle $+          runQueryWithFreshness+            Nothing+            (WaitForPosition (fastWaitOptions & #target .~ Just (GlobalPosition 5)))+            counterCursorReadModel+            "timeout"+      truthfulResult `shouldBe` queryResult++    it "rejects a truthful position wait without a target" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel counterCursorReadModel initializeCounterReadModelTable+      queryResult <-+        Store.runStoreIO storeHandle $+          runQueryWithFreshness+            Nothing+            (WaitForPosition fastWaitOptions)+            counterCursorReadModel+            "missing-target"+      queryResult+        `shouldBe` Right (Left (ReadModelMissingPosition "counter-read-model"))++    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 "startRebuild on a cursorless model skips the checkpoint reset and completes" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          initializeRegisteredReadModel+            counterCursorlessRebuildReadModel+            initializeCounterReadModelTable+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $ do+            Tx.sql "INSERT INTO counter_read_model (model_id, amount, last_seen) VALUES ('inline', 9, 1)"+            Tx.statement ("counter-read-model-sub", 7) upsertSubscriptionCursorStmt+      rebuildingResult <-+        Store.runStoreIO storeHandle $+          Rebuild.startRebuild counterCursorlessRebuildReadModel [] (GlobalPosition 0)+      rebuilding <- case rebuildingResult of+        Right metadata -> pure metadata+        Left err -> expectationFailure ("cursorless startRebuild failed: " <> show err) *> error "unreachable"+      rebuilding ^. #status `shouldBe` Rebuilding+      untouched <-+        Store.runStoreIO storeHandle $+          readSubscriptionPosition "counter-read-model-sub"+      untouched `shouldBe` Right (Just (GlobalPosition 7))+      Right (Right live) <-+        Store.runStoreIO storeHandle $+          Rebuild.finishRebuild counterCursorlessRebuildReadModel [] (GlobalPosition 0)+      live ^. #status `shouldBe` Live+      afterRebuild <-+        Store.runStoreIO storeHandle $+          runQuery Nothing counterCursorlessRebuildReadModel "inline"+      afterRebuild `shouldBe` Right (Right 0)++    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 matching global position distance and projection lag gauges" $ \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 both the preferred and+      -- compatibility gauges record the same non-negative position distance.+      Right () <-+        Store.runStoreIO storeHandle $+          recordProjectionGlobalPositionDistance (Just keiroMetrics) counterAsyncProjection+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      let scalars = flattenScalarPoints exported+          preferred = lookup "keiro.projection.global_position_distance" scalars+          compatibility = lookup "keiro.projection.lag" scalars+      preferred `shouldBe` compatibility+      case preferred of+        Just (IntNumber n) -> n `shouldSatisfy` (>= 1)+        other -> expectationFailure ("expected an integer global position distance, got " <> show other)++    it "reports zero global position distance after the newest events are hard deleted" $ \storeHandle -> do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      keiroMetrics <- Telemetry.newKeiroMetrics meter+      Right (Right survivorResult) <-+        Store.runStoreIO storeHandle $+          runCommand+            defaultRunCommandOptions+            counterEventStream+            (stream "gauge-gc-survivor" :: Stream CounterEventStream)+            (Add 1)+      survivorPosition <- case survivorResult ^. #globalPosition of+        Just position -> pure position+        Nothing -> expectationFailure "expected survivor global position" *> error "unreachable"+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement+              ("counter-read-model-sub", globalPositionToInt survivorPosition)+              upsertSubscriptionCursorStmt+      Right (Right _) <-+        Store.runStoreIO storeHandle $+          runCommand+            defaultRunCommandOptions+            counterEventStream+            (stream "gauge-gc-victim" :: Stream CounterEventStream)+            (Add 1)+      Right (Just _) <-+        Store.runStoreIO storeHandle $+          Store.hardDeleteStream (StreamName "gauge-gc-victim")+      Right () <-+        Store.runStoreIO storeHandle $+          recordProjectionGlobalPositionDistance (Just keiroMetrics) counterAsyncProjection+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      let scalars = flattenScalarPoints exported+      lookup "keiro.projection.global_position_distance" scalars+        `shouldBe` Just (IntNumber 0)+      lookup "keiro.projection.lag" scalars+        `shouldBe` Just (IntNumber 0)++    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 "process reaction API feasibility" $ do+    it "keeps the supplied witness on the first event of an accepted multi-event batch" $ \_ ->+      withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+        let target = stream "reaction-feasibility-multi" :: Stream CounterEventStream+            targetName = StreamName "reaction-feasibility-multi"+            witnessId = EventId sampleUuid+            options = defaultRunCommandOptions & #eventIds .~ [witnessId]+        outcome <-+          runner $+            runDomainCommandWithSqlEvents+              options+              multiCounterDomainHandler+              target+              (Add 7)+              (\pairs _ -> pure (Prelude.snd <$> pairs))+        case outcome of+          Right (Right (DomainCommandOutcome {decision = DomainAccepted events}, Just persisted)) -> do+            events `shouldBe` (CounterAdded 7 :| [CounterAudited 7])+            fmap (^. #eventId) persisted `shouldSatisfy` \case+              firstId : secondId : [] -> firstId == witnessId && secondId /= witnessId+              _ -> False+          other -> expectationFailure ("expected accepted feasibility batch, got " <> show other)+        Right firstPage <- runner $ Store.readStreamForward targetName (StreamVersion 0) 1+        case Vector.toList firstPage of+          [witness] -> do+            witness ^. #eventId `shouldBe` witnessId+            decodeRecorded counterCodec witness `shouldBe` Right (CounterAdded 7)+          other -> expectationFailure ("expected one witness event, got " <> show other)++    it "runs no accepted callback from an optimistic attempt discarded by rehydration" $ \_ ->+      withFreshResourceStore fixture $ \(storeHandle, StoreRunner runner) -> do+        conflictInserted <- newIORef False+        let target = stream "reaction-feasibility-conflict" :: Stream RetryDecisionEventStream+            targetName = StreamName "reaction-feasibility-conflict"+            insertConflict = do+              shouldInsert <- atomicModifyIORef' conflictInserted $ \inserted -> (True, Prelude.not inserted)+              when shouldInsert $ appendCounterEventWithId storeHandle targetName (EventId sampleUuid2) (CounterAdded 9)+            options =+              defaultRunCommandOptions+                & #eventIds+                .~ [EventId sampleUuid]+                & #beforeAppend+                .~ insertConflict+                & #retryBackoffMicros+                .~ 0+            callback _ _ = error "discarded feasibility attempt ran its callback" :: Tx.Transaction ()+        outcome <- runner $ runDomainCommandWithSqlEvents options retryDecisionDomainHandler target (Add 1) callback+        case outcome of+          Right (Right (DomainCommandOutcome {decision = DomainNoOp explanation, result}, Nothing)) -> do+            explanation `shouldBe` "already drained"+            result ^. #streamVersion `shouldBe` StreamVersion 1+          other -> expectationFailure ("expected rehydrated silent feasibility decision, got " <> show other)++    it "exposes one accepted and one rehydrated-silent result when the same source races" $ \_ ->+      withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+        arrivals <- newMVar (0 :: Int)+        release <- newEmptyMVar+        firstResult <- newEmptyMVar+        secondResult <- newEmptyMVar+        let target = stream "reaction-feasibility-same-source" :: Stream RetryDecisionEventStream+            witnessId = EventId sampleUuid+            awaitPeer = do+              arrived <- modifyMVar arrivals $ \count ->+                let next = count + 1+                 in pure (next, next)+              when (arrived == 2) (putMVar release ())+              readMVar release+            options =+              defaultRunCommandOptions+                & #eventIds+                .~ [witnessId]+                & #beforeAppend+                .~ awaitPeer+                & #retryBackoffMicros+                .~ 0+            runOne destination =+              runner+                ( runDomainCommandWithSqlEvents+                    options+                    retryDecisionDomainHandler+                    target+                    (Add 3)+                    (\_ _ -> pure ())+                )+                >>= putMVar destination+        _ <- forkIO (runOne firstResult)+        _ <- forkIO (runOne secondResult)+        outcomes <- traverse takeMVar [firstResult, secondResult]+        let accepted =+              Prelude.length+                [ ()+                | Right (Right (DomainCommandOutcome {decision = DomainAccepted {}}, Just ())) <- outcomes+                ]+            silent =+              Prelude.length+                [ ()+                | Right (Right (DomainCommandOutcome {decision = DomainNoOp "already drained"}, Nothing)) <- outcomes+                ]+        (accepted, silent) `shouldBe` (1, 1)++    it "allows a receipt-free silent delivery to accept after unrelated saga progress" $ \_ ->+      withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+        let target = stream "reaction-feasibility-silent-redelivery" :: Stream FeasibilityGateEventStream+            witnessId = EventId sampleUuid+            sourceOptions = defaultRunCommandOptions & #eventIds .~ [witnessId]+        first <- runner $ runDomainCommand sourceOptions feasibilityGateDomainHandler target (TryAccept 5)+        case first of+          Right (Right DomainCommandOutcome {decision = DomainNoOp "gate closed", result}) ->+            result ^. #eventsAppended `shouldBe` 0+          other -> expectationFailure ("expected initial silent feasibility decision, got " <> show other)+        Right (Right DomainCommandOutcome {decision = DomainAccepted (GateOpened :| [])}) <-+          runner $ runDomainCommand defaultRunCommandOptions feasibilityGateDomainHandler target OpenGate+        redelivery <- runner $ runDomainCommand sourceOptions feasibilityGateDomainHandler target (TryAccept 5)+        case redelivery of+          Right (Right DomainCommandOutcome {decision = DomainAccepted (GateAccepted 5 :| [])}) -> pure ()+          other -> expectationFailure ("expected accepted silent redelivery, got " <> show other)++    it "shows that a negative silent probe cannot fence a later unconditional timer transaction" $ \_ ->+      withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+        probeReady <- newEmptyMVar+        releaseTimer <- newEmptyMVar+        silentResult <- newEmptyMVar+        let target = stream "reaction-feasibility-silent-timer-race" :: Stream FeasibilityGateEventStream+            targetName = StreamName "reaction-feasibility-silent-timer-race"+            witnessId = EventId sampleUuid+            sourceOptions = defaultRunCommandOptions & #eventIds .~ [witnessId]+            request =+              counterTimerRequest+                & #timerId+                .~ TimerId sampleUuid2+                & #processManagerName+                .~ "reaction-feasibility"+            runSilentBranch = do+              silent <- runner $ runDomainCommand sourceOptions feasibilityGateDomainHandler target (TryAccept 9)+              probe <- runner $ firstExistingEventId sourceOptions targetName (witnessId :| [])+              putMVar probeReady (silent, probe)+              takeMVar releaseTimer+              scheduled <- runner $ Store.runTransaction (scheduleTimerOnceTx request)+              putMVar silentResult scheduled+        _ <- forkIO runSilentBranch+        (initial, negativeProbe) <- takeMVar probeReady+        case initial of+          Right (Right DomainCommandOutcome {decision = DomainNoOp "gate closed"}) -> pure ()+          other -> expectationFailure ("expected silent branch before probe, got " <> show other)+        negativeProbe `shouldBe` Right Nothing+        Right (Right _) <- runner $ runDomainCommand defaultRunCommandOptions feasibilityGateDomainHandler target OpenGate+        Right (Right DomainCommandOutcome {decision = DomainAccepted (GateAccepted 9 :| [])}) <-+          runner $ runDomainCommand sourceOptions feasibilityGateDomainHandler target (TryAccept 9)+        putMVar releaseTimer ()+        takeMVar silentResult `shouldReturn` Right True+        timer <- runner $ lookupTimer (request ^. #timerId)+        timer `shouldSatisfy` \case+          Right (Just row) -> row ^. #status == Scheduled+          _ -> False++    it "cancels a timer in the same transaction as an accepted saga append" $ \_ ->+      withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+        let target = stream "reaction-feasibility-cancel-accepted" :: Stream CounterEventStream+            request = counterTimerRequest & #timerId .~ TimerId sampleUuid2+        Right () <- runner $ Store.runTransaction (scheduleTimerTx request)+        outcome <-+          runner $+            runDomainCommandWithSqlEvents+              defaultRunCommandOptions+              multiCounterDomainHandler+              target+              (Add 2)+              (\_ _ -> cancelTimerTx (request ^. #timerId))+        case outcome of+          Right (Right (DomainCommandOutcome {decision = DomainAccepted {}}, Just True)) -> pure ()+          other -> expectationFailure ("expected accepted append and timer cancellation, got " <> show other)+        runner (claimDueTimer dueTimerTime) `shouldReturn` Right Nothing+        timer <- runner $ lookupTimer (request ^. #timerId)+        timer `shouldSatisfy` \case+          Right (Just row) -> row ^. #status == Timer.Cancelled+          _ -> False++    it "rolls back both an accepted saga append and transactional cancellation when condemned" $ \_ ->+      withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+        let target = stream "reaction-feasibility-cancel-rollback" :: Stream CounterEventStream+            targetName = StreamName "reaction-feasibility-cancel-rollback"+            request = counterTimerRequest & #timerId .~ TimerId sampleUuid2+        Right () <- runner $ Store.runTransaction (scheduleTimerTx request)+        outcome <-+          runner $+            runDomainCommandWithSqlEventsControlled+              defaultRunCommandOptions+              multiCounterDomainHandler+              target+              (Add 4)+              ( \_ _ -> do+                  cancelled <- cancelTimerTx (request ^. #timerId)+                  pure (RollbackSqlTransaction cancelled)+              )+        outcome `shouldBe` Right (Right (DomainSqlCommandRolledBack True))+        Right recorded <- runner $ Store.readStreamForward targetName (StreamVersion 0) 10+        recorded `shouldBe` Vector.empty+        timer <- runner $ lookupTimer (request ^. #timerId)+        timer `shouldSatisfy` \case+          Right (Just row) -> row ^. #status == Scheduled+          _ -> False++    it "keeps transactional cancellation idempotent and protects terminal and foreground-owned rows" $ \_ ->+      withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runner) -> do+        let request n = counterTimerRequest & #timerId .~ TimerId (UUID.fromWords 0 0 0 n)+            cancelledRequest = request 101+            firedRequest = request 102+            liveClaimRequest = request 103+            expiredClaimRequest = request 104+            absentRequest = request 105+            claimRequest timerRequest leaseSeconds =+              DeadTimerClaimRequest+                (timerRequest ^. #timerId)+                (timerRequest ^. #processManagerName)+                "reaction-feasibility"+                3+                leaseSeconds+            setupForeground timerRequest leaseSeconds = do+              Right () <- runner $ Store.runTransaction (scheduleTimerTx timerRequest)+              Right True <- runner $ deadLetterTimer (timerRequest ^. #timerId) "reaction-feasibility"+              Right (Right _) <- runner $ claimDeadTimer (claimRequest timerRequest leaseSeconds)+              pure ()+        Right () <- runner $ Store.runTransaction $ do+          scheduleTimerTx cancelledRequest+          scheduleTimerTx firedRequest+        runner (cancelTimer (cancelledRequest ^. #timerId)) `shouldReturn` Right True+        runner (Store.runTransaction (cancelTimerTx (cancelledRequest ^. #timerId))) `shouldReturn` Right False+        Right (Just _) <- runner $ claimDueTimer dueTimerTime+        runner (markTimerFired (firedRequest ^. #timerId) (EventId sampleUuid3)) `shouldReturn` Right True+        runner (Store.runTransaction (cancelTimerTx (firedRequest ^. #timerId))) `shouldReturn` Right False+        setupForeground liveClaimRequest 60+        runner (Store.runTransaction (cancelTimerTx (liveClaimRequest ^. #timerId))) `shouldReturn` Right False+        setupForeground expiredClaimRequest 1+        threadDelay 1_100_000+        runner (Store.runTransaction (cancelTimerTx (expiredClaimRequest ^. #timerId))) `shouldReturn` Right False+        runner (Store.runTransaction (cancelTimerTx (absentRequest ^. #timerId))) `shouldReturn` Right False+        runner (Store.runTransaction (scheduleTimerOnceTx absentRequest)) `shouldReturn` Right True+        timer <- runner $ lookupTimer (absentRequest ^. #timerId)+        timer `shouldSatisfy` \case+          Right (Just row) -> row ^. #status == Scheduled+          _ -> False++  describe "Keiro.ProcessManager.Reaction" $ around (withFreshResourceStore fixture) $ do+    it "commits accepted saga timers before ordered target fan-out and recovers duplicates" $ \(_storeHandle, StoreRunner runner) -> do+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 5)+          target = stream "reaction-target:accepted" :: Stream CounterCommand+          rearmRequest = counterTimerRequest & #timerId .~ TimerId sampleUuid2 & #payload .~ object ["mode" Aeson..= ("rearm" :: Text)]+          onceRequest = counterTimerRequest & #timerId .~ TimerId sampleUuid3 & #payload .~ object ["mode" Aeson..= ("once" :: Text)]+          plan =+            Reaction.AdvanceReaction+              (Add 5)+              [ Reaction.FollowSchedule Reaction.Rearm rearmRequest,+                Reaction.FollowDispatch (PMCommand target (Add 5))+              ]+              [ Reaction.FollowSchedule Reaction.Once onceRequest,+                Reaction.FollowDispatch (PMCommand target (Add 6))+              ]+          input = ("accepted", plan)+      first <- runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager sourceEvent input+      case first of+        Right (Right result) -> do+          result ^. #managerResult `shouldSatisfy` \case+            Reaction.ReactionEvaluated DomainCommandOutcome {decision = DomainAccepted (CounterAdded 5 :| [CounterAudited 5])} -> True+            _ -> False+          result ^. #commandResults `shouldSatisfy` \case+            [PMCommandAppended a, PMCommandAppended b] -> a ^. #eventsAppended == 1 && b ^. #eventsAppended == 1+            _ -> False+          result ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 2 1 0+        other -> expectationFailure ("expected accepted reaction, got " <> show other)+      beforeRearm <- runner $ lookupTimer (rearmRequest ^. #timerId)+      beforeOnce <- runner $ lookupTimer (onceRequest ^. #timerId)+      duplicate <- runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager sourceEvent input+      case duplicate of+        Right (Right result) -> do+          result ^. #managerResult `shouldSatisfy` \case+            Reaction.ReactionDuplicate {} -> True+            _ -> False+          result ^. #commandResults `shouldSatisfy` \case+            [PMCommandDuplicate {}, PMCommandDuplicate {}] -> True+            _ -> False+          result ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 0 0 0+        other -> expectationFailure ("expected duplicate reaction recovery, got " <> show other)+      runner (lookupTimer (rearmRequest ^. #timerId)) `shouldReturn` beforeRearm+      runner (lookupTimer (onceRequest ^. #timerId)) `shouldReturn` beforeOnce+      Right sagaEvents <- runner $ Store.readStreamForward (StreamName "reaction-saga:accepted") (StreamVersion 0) 10+      Right targetEvents <- runner $ Store.readStreamForward (StreamName "reaction-target:accepted") (StreamVersion 0) 10+      Vector.length sagaEvents `shouldBe` 2+      Vector.length targetEvents `shouldBe` 2++    it "runs no-advance and silent unconditional effects without accepted-only effects" $ \(_storeHandle, StoreRunner runner) -> do+      let noAdvanceSource = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          silentSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 2)+          noAdvanceTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid+          silentTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid2+          acceptedOnlyTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid3+          noAdvancePlan =+            Reaction.NoAdvance+              [ Reaction.FollowSchedule Reaction.Once noAdvanceTimer,+                Reaction.FollowDispatch (PMCommand (stream "reaction-target:no-advance") (Add 1))+              ]+          silentPlan =+            Reaction.AdvanceReaction+              NoOpSilently+              [ Reaction.FollowSchedule Reaction.Once silentTimer,+                Reaction.FollowDispatch (PMCommand (stream "reaction-target:silent") (Add 2))+              ]+              [ Reaction.FollowSchedule Reaction.Once acceptedOnlyTimer,+                Reaction.FollowDispatch (PMCommand (stream "reaction-target:accepted-only") (Add 3))+              ]+      Right (Right noAdvance) <-+        runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager noAdvanceSource ("no-advance", noAdvancePlan)+      noAdvance ^. #managerResult `shouldBe` Reaction.ReactionNotAdvanced+      noAdvance ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 1 1 0+      Right noSaga <- runner $ Store.getStream (StreamName "reaction-saga:no-advance")+      noSaga `shouldBe` Nothing+      Right (Right silent) <-+        runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions silentReactionManager silentSource ("silent", silentPlan)+      silent ^. #managerResult `shouldSatisfy` \case+        Reaction.ReactionEvaluated DomainCommandOutcome {decision = DomainNoOp "edge-1: already complete"} -> True+        _ -> False+      silent ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 1 1 0+      runner (lookupTimer (acceptedOnlyTimer ^. #timerId)) `shouldReturn` Right Nothing+      Right acceptedOnlyEvents <- runner $ Store.readStreamForward (StreamName "reaction-target:accepted-only") (StreamVersion 0) 10+      acceptedOnlyEvents `shouldBe` Vector.empty++    it "retries missing same-target dispatches after a later command commits" $ \(_storeHandle, StoreRunner runner) -> do+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          target = stream "reaction-strict-target:order" :: Stream FeasibilityGateCommand+          committedTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid2+          plan =+            Reaction.AdvanceReaction+              (Add 1)+              [ Reaction.FollowSchedule Reaction.Once committedTimer,+                Reaction.FollowDispatch (PMCommand target (TryAccept 7)),+                Reaction.FollowDispatch (PMCommand target OpenGate)+              ]+              []+          input = ("partial", plan)+      Right (Right first) <-+        runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions strictTargetReactionManager sourceEvent input+      first ^. #commandResults `shouldSatisfy` \case+        [PMCommandFailed _ CommandRejected, PMCommandAppended {}] -> True+        _ -> False+      first ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 1 1 0+      timerAfterTargetFailure <- runner (lookupTimer (committedTimer ^. #timerId))+      timerAfterTargetFailure `shouldSatisfy` \case+        Right (Just row) -> row ^. #status == Scheduled+        _ -> False+      Right (Right replayed) <-+        runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions strictTargetReactionManager sourceEvent input+      replayed ^. #commandResults `shouldSatisfy` \case+        [PMCommandAppended {}, PMCommandDuplicate {}] -> True+        _ -> False+      replayed ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 0 0 0+      Right events <- runner $ Store.readStreamForward (StreamName "reaction-strict-target:order") (StreamVersion 0) 10+      traverse (decodeRecorded feasibilityGateCodec) (Vector.toList events)+        `shouldBe` Right [GateOpened, GateAccepted 7]++    it "reconciles a concurrent target loser that rehydrates to a silent result" $ \(_storeHandle, StoreRunner runner) -> do+      arrivals <- newMVar (0 :: Int)+      release <- newEmptyMVar+      firstResult <- newEmptyMVar+      secondResult <- newEmptyMVar+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 3)+          target = stream "reaction-race-target" :: Stream CounterCommand+          plan = Reaction.NoAdvance [Reaction.FollowDispatch (PMCommand target (Add 3))]+          input = ("race", plan)+          awaitPeer = do+            arrived <- modifyMVar arrivals $ \count ->+              let next = count + 1+               in pure (next, next)+            when (arrived == 2) (putMVar release ())+            readMVar release+          options = defaultRunCommandOptions & #beforeAppend .~ awaitPeer & #retryBackoffMicros .~ 0+          runOne destination =+            runner (Reaction.runReactiveProcessManagerOnce options retryTargetReactionManager sourceEvent input)+              >>= putMVar destination+      _ <- forkIO (runOne firstResult)+      _ <- forkIO (runOne secondResult)+      outcomes <- traverse takeMVar [firstResult, secondResult]+      let successful = [result | Right (Right result) <- outcomes]+          results = [commandResults | Reaction.ReactiveProcessManagerResult {commandResults} <- successful]+      Prelude.length results `shouldBe` 2+      map (^. #timerEffects) successful `shouldBe` Prelude.replicate 2 (Reaction.ReactionTimerEffects 0 0 0)+      results `shouldSatisfy` \observed ->+        Prelude.length [() | [PMCommandAppended {}] <- observed] == 1+          && Prelude.length [() | [PMCommandDuplicate {}] <- observed] == 1++    it "preserves timer statement order, Once payloads, and later-source Rearm updates" $ \(_storeHandle, StoreRunner runner) -> do+      let sourceA = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          sourceB = recordedFromEventId (EventId sampleUuid2) (CounterAdded 2)+          orderedId = TimerId sampleUuid+          onceId = TimerId sampleUuid2+          rearmId = TimerId sampleUuid3+          reverseOrderId = TimerId (UUID.fromWords 0 0 0 104)+          original id = counterTimerRequest & #timerId .~ id & #fireAt .~ dueTimerTime & #payload .~ object ["version" Aeson..= (1 :: Int)]+          changed id = original id & #fireAt .~ addUTCTime 60 dueTimerTime & #payload .~ object ["version" Aeson..= (2 :: Int)]+          runPlan source correlation followUps =+            runner $+              Reaction.runReactiveProcessManagerOnce+                defaultRunCommandOptions+                counterReactionManager+                source+                (correlation, Reaction.NoAdvance followUps)+      Right () <- runner $ Store.runTransaction (scheduleTimerTx (original orderedId))+      Right (Right ordered) <-+        runPlan+          sourceA+          "ordered"+          [Reaction.FollowSchedule Reaction.Rearm (changed orderedId), Reaction.FollowCancel orderedId]+      ordered ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 2 0 1+      orderedTimer <- runner (lookupTimer orderedId)+      orderedTimer `shouldSatisfy` \case+        Right (Just row) -> row ^. #status == Timer.Cancelled+        _ -> False+      Right () <- runner $ Store.runTransaction (scheduleTimerTx (original reverseOrderId))+      Right (Right reverseOrdered) <-+        runPlan+          sourceA+          "reverse-ordered"+          [Reaction.FollowCancel reverseOrderId, Reaction.FollowSchedule Reaction.Rearm (changed reverseOrderId)]+      reverseOrdered ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 2 0 1+      reverseTimer <- runner (lookupTimer reverseOrderId)+      reverseTimer `shouldSatisfy` \case+        Right (Just row) -> row ^. #status == Timer.Cancelled && row ^. #payload == object ["version" Aeson..= (1 :: Int)]+        _ -> False+      Right (Right _) <- runPlan sourceA "once-a" [Reaction.FollowSchedule Reaction.Once (original onceId)]+      Right (Right _) <- runPlan sourceB "once-b" [Reaction.FollowSchedule Reaction.Once (changed onceId)]+      onceTimer <- runner (lookupTimer onceId)+      onceTimer `shouldSatisfy` \case+        Right (Just row) -> row ^. #fireAt == dueTimerTime && row ^. #payload == object ["version" Aeson..= (1 :: Int)]+        _ -> False+      Right (Right _) <- runPlan sourceA "rearm-a" [Reaction.FollowSchedule Reaction.Rearm (original rearmId)]+      Right (Right _) <- runPlan sourceB "rearm-b" [Reaction.FollowSchedule Reaction.Rearm (changed rearmId)]+      rearmedTimer <- runner (lookupTimer rearmId)+      rearmedTimer `shouldSatisfy` \case+        Right (Just row) -> row ^. #fireAt == addUTCTime 60 dueTimerTime && row ^. #payload == object ["version" Aeson..= (2 :: Int)]+        _ -> False++    it "rolls back saga and earlier timer writes when later timer SQL fails" $ \(_storeHandle, StoreRunner runner) -> do+      Right () <- runner $ Store.runTransaction (Tx.sql reactionTimerFailureTriggerSql)+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 4)+          firstTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid2 & #processManagerName .~ "reaction-ok"+          failingTimer = counterTimerRequest & #timerId .~ TimerId sampleUuid3 & #processManagerName .~ "reaction-fail"+          plan =+            Reaction.AdvanceReaction+              (Add 4)+              [ Reaction.FollowSchedule Reaction.Rearm firstTimer,+                Reaction.FollowSchedule Reaction.Rearm failingTimer+              ]+              []+      outcome <-+        runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager sourceEvent ("timer-failure", plan)+      outcome `shouldSatisfy` \case+        Right (Left (Reaction.ReactionCommandFailed (StoreFailed _))) -> True+        _ -> False+      Right sagaEvents <- runner $ Store.readStreamForward (StreamName "reaction-saga:timer-failure") (StreamVersion 0) 10+      sagaEvents `shouldBe` Vector.empty+      runner (lookupTimer (firstTimer ^. #timerId)) `shouldReturn` Right Nothing+      runner (lookupTimer (failingTimer ^. #timerId)) `shouldReturn` Right Nothing++    it "rejects undecodable, foreign-stream, and wrong-target identity collisions" $ \(storeHandle, StoreRunner runner) -> do+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          correlationId = "collision"+          managerId = deterministicCommandId "counter-reaction" correlationId (sourceEvent ^. #eventId) (-1)+          sagaName = StreamName "reaction-saga:collision"+          simplePlan = Reaction.AdvanceReaction (Add 1) [] []+      foreignEvent <- shouldBeRight (encodeForAppend feasibilityGateCodec GateOpened)+      Right _ <- runner $ Store.appendToStream sagaName NoStream [foreignEvent & #eventId ?~ managerId]+      undecodable <- runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager sourceEvent (correlationId, simplePlan)+      undecodable `shouldBe` Right (Left (Reaction.ReactionWitnessUndecodable sagaName managerId))++      let otherSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 2)+          otherCorrelation = "wrong-stream"+          wrongManagerId = deterministicCommandId "counter-reaction" otherCorrelation (otherSource ^. #eventId) (-1)+      appendCounterEventWithId storeHandle (StreamName "other-saga") wrongManagerId (CounterAdded 2)+      wrongStream <- runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager otherSource (otherCorrelation, simplePlan)+      wrongStream `shouldSatisfy` \case+        Right (Left (Reaction.ReactionCommandFailed (StoreFailed _))) -> True+        _ -> False++      let targetSource = recordedFromEventId (EventId sampleUuid3) (CounterAdded 3)+          targetName = StreamName "reaction-target:collision"+          targetId = Reaction.deterministicReactionCommandId "counter-reaction" "target-collision" (targetSource ^. #eventId) targetName 0+          targetPlan = Reaction.NoAdvance [Reaction.FollowDispatch (PMCommand (stream "reaction-target:collision") (Add 3))]+      appendCounterEventWithId storeHandle (StreamName "other-target") targetId (CounterAdded 3)+      Right (Right targetCollision) <-+        runner $ Reaction.runReactiveProcessManagerOnce defaultRunCommandOptions counterReactionManager targetSource ("target-collision", targetPlan)+      targetCollision ^. #commandResults `shouldSatisfy` \case+        [PMCommandFailed observed (StoreFailed _)] -> observed == targetName+        _ -> False++    it "pages accepted witnesses at 256, 1024, and 4096 event history depths" $ \(_storeHandle, StoreRunner runner) ->+      forM_ [256, 1024, 4096] $ \depth -> do+        let sourceId = EventId (UUID.fromWords 0 0 279 (fromIntegral depth))+            sourceEvent = recordedFromEventId sourceId (CounterAdded depth)+            correlationId = "paged-witness-" <> Text.pack (show depth)+            sagaName = StreamName ("reaction-saga:" <> correlationId)+            managerId = deterministicCommandId "counter-reaction" correlationId sourceId (-1)+        encoded <- traverse (shouldBeRight . encodeForAppend counterCodec . CounterAdded) [1 .. depth]+        let withIds =+              Prelude.zipWith+                (\eventIndex event -> if eventIndex == depth - 1 then event & #eventId ?~ managerId else event)+                [0 ..]+                encoded+        Right _ <- runner $ Store.appendToStream sagaName NoStream withIds+        recovered <-+          runner $+            Reaction.runReactiveProcessManagerOnce+              defaultRunCommandOptions+              counterReactionManager+              sourceEvent+              (correlationId, Reaction.AdvanceReaction (Add 1) [] [])+        recovered `shouldSatisfy` \case+          Right (Right result) -> case result ^. #managerResult of+            Reaction.ReactionDuplicate duplicateId -> duplicateId == managerId+            _ -> False+          _ -> False++    it "runs the public-only handwritten reported and acknowledged example" $ \(_storeHandle, StoreRunner runner) -> do+      let manager = ReactionExample.exampleReactionManager dueTimerTime+          reportedSource = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          acknowledgedSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 2)+          correlationId = "incident-279"+      Right (Right reported) <-+        runner $+          Reaction.runReactiveProcessManagerOnce+            defaultRunCommandOptions+            manager+            reportedSource+            (ReactionExample.IncidentReported correlationId ReactionExample.Urgent)+      reported ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 2 2 0+      reported ^. #commandResults `shouldSatisfy` \case+        [PMCommandAppended result] -> result ^. #eventsAppended == 1+        _ -> False+      reminder <- runner (lookupTimer ReactionExample.exampleReminderTimerId)+      escalation <- runner (lookupTimer ReactionExample.exampleEscalationTimerId)+      reminder `shouldSatisfy` \case+        Right (Just row) -> row ^. #fireAt == addUTCTime 300 dueTimerTime+        _ -> False+      escalation `shouldSatisfy` \case+        Right (Just row) -> row ^. #fireAt == addUTCTime 900 dueTimerTime+        _ -> False+      Right (Right routine) <-+        runner $+          Reaction.runReactiveProcessManagerOnce+            defaultRunCommandOptions+            manager+            acknowledgedSource+            (ReactionExample.IncidentReported "routine-279" ReactionExample.Routine)+      routine ^. #managerResult `shouldBe` Reaction.ReactionNotAdvanced+      routine ^. #commandResults `shouldBe` []+      Right routineSaga <- runner $ Store.getStream (StreamName "incident-reaction-saga:routine-279")+      routineSaga `shouldBe` Nothing+      let target = stream ("incident-reaction-target:" <> correlationId)+      Right (Just firedReminder) <-+        runner $+          runTimerWorker Nothing (addUTCTime 300 dueTimerTime) $ \_ -> do+            late <-+              runCommand+                defaultRunCommandOptions+                ReactionExample.exampleTargetEventStream+                target+                ReactionExample.ApplyLateTimeout+            pure $ case late of+              Right result | result ^. #eventsAppended == 0 -> Just (EventId sampleUuid3)+              _ -> Nothing+      firedReminder ^. #timerId `shouldBe` ReactionExample.exampleReminderTimerId+      Right (Right acknowledged) <-+        runner $+          Reaction.runReactiveProcessManagerOnce+            defaultRunCommandOptions+            manager+            acknowledgedSource+            (ReactionExample.IncidentAcknowledged correlationId)+      acknowledged ^. #timerEffects `shouldBe` Reaction.ReactionTimerEffects 2 0 1+      runner (runTimerWorker Nothing (addUTCTime 300 dueTimerTime) (\_ -> error "fired reminder redelivered"))+        `shouldReturn` Right Nothing++    it "worker finalizes each success and duplicate exactly once" $ \(_storeHandle, StoreRunner runner) -> do+      decisions <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 2)+          target = stream "reaction-worker-target:ok" :: Stream CounterCommand+          plan = Reaction.AdvanceReaction (Add 2) [] [Reaction.FollowDispatch (PMCommand target (Add 2))]+          message = (sourceEvent, ("worker-ok", plan))+      Right () <-+        runner $+          Reaction.runReactiveProcessManagerWorker+            defaultRunCommandOptions+            counterReactionManager+            (inMemoryAdapter decisions [message, message])+            Just+      readIORef decisions `shouldReturn` [AckOk, AckOk]+      Right targetEvents <- runner $ Store.readStreamForward (StreamName "reaction-worker-target:ok") (StreamVersion 0) 10+      Vector.length targetEvents `shouldBe` 1++    it "worker applies target rejection policy with the overall dispatch index" $ \(_storeHandle, StoreRunner runner) -> do+      decisions <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          target = stream "reaction-worker-strict:rejected" :: Stream FeasibilityGateCommand+          plan = Reaction.AdvanceReaction (Add 1) [] [Reaction.FollowDispatch (PMCommand target (TryAccept 7))]+          message = (sourceEvent, ("worker-rejected", plan))+          workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter+      Right () <-+        runner $+          Reaction.runReactiveProcessManagerWorkerWith+            workerOptions+            defaultRunCommandOptions+            strictTargetReactionManager+            (inMemoryAdapter decisions [message])+            Just+      readIORef decisions `shouldReturn` [AckOk]+      Right deadLetters <- runner (listDispatchDeadLetters "strict-target-reaction")+      deadLetters `shouldSatisfy` \case+        [row] -> row ^. #emitIndex == 0 && row ^. #targetStreamName == StreamName "reaction-worker-strict:rejected"+        _ -> False++    it "worker handles typed silence as a successful delivery" $ \(_storeHandle, StoreRunner runner) -> do+      silentDecisions <- newIORef []+      let silentSource = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          silentPlan = Reaction.AdvanceReaction NoOpSilently [] []+      Right () <-+        runner $+          Reaction.runReactiveProcessManagerWorker+            defaultRunCommandOptions+            silentReactionManager+            (inMemoryAdapter silentDecisions [(silentSource, ("worker-silent", silentPlan))])+            Just+      readIORef silentDecisions `shouldReturn` [AckOk]++    it "worker records manager failures at index minus one" $ \(_storeHandle, StoreRunner runner) -> do+      managerFailureDecisions <- newIORef []+      let failedSource = recordedFromEventId (EventId sampleUuid2) (CounterAdded 2)+          failedPlan = Reaction.AdvanceReaction (Add 2) [] []+          rejectingHandler =+            DomainCommandHandler+              { eventStream = rejectingEventStream,+                classifySilent = \_ -> error "rejecting reaction handler selected a silent edge"+              }+          rejectingManager =+            Reaction.ReactiveProcessManager+              "counter-reaction"+              Prelude.fst+              rejectingHandler+              (\correlationId -> stream ("reaction-saga:" <> correlationId))+              counterEventStream+              (const [])+              Prelude.snd+          workerOptions = defaultWorkerOptions & #rejectedCommandPolicy .~ RejectedDeadLetter+      Right () <-+        runner $+          Reaction.runReactiveProcessManagerWorkerWith+            workerOptions+            defaultRunCommandOptions+            rejectingManager+            (inMemoryAdapter managerFailureDecisions [(failedSource, ("worker-manager-failure", failedPlan))])+            Just+      readIORef managerFailureDecisions `shouldReturn` [AckOk]+      Right deadLetters <- runner (listDispatchDeadLetters "counter-reaction")+      deadLetters `shouldSatisfy` \case+        [row] -> row ^. #emitIndex == (-1) && row ^. #targetStreamName == StreamName "reaction-saga:worker-manager-failure"+        _ -> False++    it "worker uses bounded witness reasons and poison callbacks" $ \(_storeHandle, StoreRunner runner) -> do+      witnessDecisions <- newIORef []+      poisonDecisions <- newIORef []+      poisoned <- newIORef []+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          correlationId = "worker-witness"+          managerId = deterministicCommandId "counter-reaction" correlationId (sourceEvent ^. #eventId) (-1)+          plan = Reaction.AdvanceReaction (Add 1) [] []+      foreignEvent <- shouldBeRight (encodeForAppend feasibilityGateCodec GateOpened)+      Right _ <- runner $ Store.appendToStream (StreamName "reaction-saga:worker-witness") NoStream [foreignEvent & #eventId ?~ managerId]+      Right () <-+        runner $+          Reaction.runReactiveProcessManagerWorker+            defaultRunCommandOptions+            counterReactionManager+            (inMemoryAdapter witnessDecisions [(sourceEvent, (correlationId, plan))])+            Just+      readIORef witnessDecisions+        `shouldReturn` [AckHalt (HaltFatal "process-reaction-witness-undecodable")]+      let poisonOptions =+            defaultWorkerOptions+              & #poisonPolicy+              .~ PoisonDeadLetter (\env -> liftIO (modifyIORef' poisoned (<> [env ^. #payload])))+      Right () <-+        runner $+          Reaction.runReactiveProcessManagerWorkerWith+            poisonOptions+            defaultRunCommandOptions+            counterReactionManager+            (inMemoryAdapter poisonDecisions ["not-a-reaction" :: Text])+            (const Nothing)+      readIORef poisonDecisions+        `shouldReturn` [AckDeadLetter (InvalidPayload "process-reaction-worker-decode-failed")]+      readIORef poisoned `shouldReturn` ["not-a-reaction"]++    it "worker lets asynchronous cancellation escape without acknowledging" $ \(_storeHandle, StoreRunner runner) -> do+      decisions <- newIORef []+      let workerOptions =+            defaultWorkerOptions+              & #poisonPolicy+              .~ PoisonSkip (\_ -> liftIO (throwIO ThreadKilled))+      cancelled <-+        try @AsyncException $+          runner $+            Reaction.runReactiveProcessManagerWorkerWith+              workerOptions+              defaultRunCommandOptions+              counterReactionManager+              (inMemoryAdapter decisions ["cancel" :: Text])+              (const Nothing)+      cancelled `shouldBe` Left ThreadKilled+      readIORef decisions `shouldReturn` []++    it "scales worker fan-out across 8, 32, and 128 same and distinct targets" $ \(_storeHandle, StoreRunner runner) ->+      forM_ [8, 32, 128] $ \fanOut ->+        forM_ [("same", True), ("distinct", False)] $ \(flavor, sameTarget) -> do+          decisions <- newIORef []+          let sourceId =+                EventId+                  ( UUID.fromWords+                      0+                      0+                      (if sameTarget then 279 else 280)+                      (fromIntegral fanOut)+                  )+              sourceEvent = recordedFromEventId sourceId (CounterAdded fanOut)+              correlationId = "fanout-" <> flavor <> "-" <> Text.pack (show fanOut)+              targetName targetIndex =+                if sameTarget+                  then "reaction-fanout:" <> flavor <> ":" <> Text.pack (show fanOut)+                  else "reaction-fanout:" <> flavor <> ":" <> Text.pack (show fanOut) <> ":" <> Text.pack (show targetIndex)+              commands =+                [ Reaction.FollowDispatch (PMCommand (stream (targetName targetIndex)) (Add targetIndex))+                | targetIndex <- [1 .. fanOut]+                ]+              plan = Reaction.AdvanceReaction (Add fanOut) [] commands+              message = (sourceEvent, (correlationId, plan))+          Right () <-+            runner $+              Reaction.runReactiveProcessManagerWorker+                defaultRunCommandOptions+                counterReactionManager+                (inMemoryAdapter decisions [message])+                Just+          readIORef decisions `shouldReturn` [AckOk]+          Right sagaEvents <-+            runner $+              Store.readStreamForward+                (StreamName ("reaction-saga:" <> correlationId))+                (StreamVersion 0)+                10+          Vector.length sagaEvents `shouldBe` 2+          persistedCounts <-+            if sameTarget+              then do+                Right events <- runner $ Store.readStreamForward (StreamName (targetName 1)) (StreamVersion 0) (fromIntegral fanOut + 1)+                pure [Vector.length events]+              else forM [1 .. fanOut] $ \targetIndex -> do+                Right events <- runner $ Store.readStreamForward (StreamName (targetName targetIndex)) (StreamVersion 0) 2+                pure (Vector.length events)+          Prelude.sum persistedCounts `shouldBe` fanOut++  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 "bridges a pre-UTF-8 process-manager state and command redelivery" $ \(storeHandle, StoreRunner _runner) -> do+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          correlationId = "\x4E2D\x6587-42"+          managerStreamName = StreamName "pm:counter-unicode"+          targetStreamName = StreamName "counter-target-unicode"+          legacyManagerId = legacyDeterministicCommandId "unicode-pm" correlationId (sourceEvent ^. #eventId) (-1)+          legacyCommandId = legacyDeterministicCommandId "unicode-pm" correlationId (sourceEvent ^. #eventId) 0+      appendCounterEventWithId storeHandle managerStreamName legacyManagerId (CounterAdded 9)+      appendCounterEventWithId storeHandle targetStreamName legacyCommandId (CounterAdded 9)+      Right (Right pmResult) <-+        _runner $+          runProcessManagerOnce defaultRunCommandOptions unicodeCounterProcessManager sourceEvent (CounterAdded 9)+      Right managerEvents <- _runner $ Store.readStreamForward managerStreamName (StreamVersion 0) 10+      Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10+      ( pmResult ^. #managerResult,+        pmResult ^. #commandResults,+        Vector.length managerEvents,+        Vector.length targetEvents+        )+        `shouldBe` ( PMStateDuplicate legacyManagerId,+                     [PMCommandDuplicate legacyCommandId],+                     1,+                     1+                   )++    it "bridges a pre-UTF-8 domain process-manager state and command redelivery" $ \(storeHandle, StoreRunner _runner) -> do+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          correlationId = "\x4E2D\x6587-9"+          managerStreamName = StreamName ("domain-pm:" <> correlationId)+          targetStreamName = StreamName ("domain-pm-target:" <> correlationId <> ":0")+          legacyManagerId = legacyDeterministicCommandId "domain-pm" correlationId (sourceEvent ^. #eventId) (-1)+          legacyCommandId = legacyDeterministicCommandId "domain-pm" correlationId (sourceEvent ^. #eventId) 0+          input = DomainDispatchInput correlationId [CoordinatorAccept 9]+      appendCounterEventWithId storeHandle managerStreamName legacyManagerId (CounterAdded 1)+      appendCounterEventWithId storeHandle targetStreamName legacyCommandId (CounterAdded 9)+      Right (Right pmResult) <-+        _runner $+          runDomainProcessManagerOnce defaultRunCommandOptions domainProcessManager sourceEvent input+      Right managerEvents <- _runner $ Store.readStreamForward managerStreamName (StreamVersion 0) 10+      Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10+      ( pmResult ^. #managerResult,+        pmResult ^. #commandResults,+        Vector.length managerEvents,+        Vector.length targetEvents+        )+        `shouldBe` ( PMStateDuplicate legacyManagerId,+                     [DomainPMCommandDuplicate legacyCommandId],+                     1,+                     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)+      -- kiroku-store 0.8.0.0 types class-40 rollbacks separately from+      -- UnexpectedServerError. The transaction rolled back completely and+      -- nothing was committed, so the source event retries rather than halting+      -- the subscription; every other server code still halts.+      ackForCommandError+        (RetryDelay 5)+        (StoreFailed (Store.TransientTransactionFailure "40001" "could not serialize access"))+        `shouldBe` AckRetry (RetryDelay 5)+      ackForCommandError+        (RetryDelay 5)+        (StoreFailed (Store.TransientTransactionFailure "40P01" "deadlock detected"))+        `shouldBe` AckRetry (RetryDelay 5)+      ackForCommandError (RetryDelay 5) (StoreFailed (Store.UnexpectedServerError "XX000" "boom"))+        `shouldSatisfy` \case+          AckHalt (HaltFatal _) -> True+          _ -> False+      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 "RouterSelection validates positive runtime invariants" $ \(_storeHandle, StoreRunner _runner) -> do+      mkRecipientLimit 0 `shouldSatisfy` \case Left _ -> True; Right _ -> False+      mkSelectionVersion 0 `shouldSatisfy` \case Left _ -> True; Right _ -> False+      limit <- shouldBeRight (mkRecipientLimit 2)+      selectionVersion <- shouldBeRight (mkSelectionVersion 3)+      recipientLimitValue limit `shouldBe` 2+      selectionVersionValue selectionVersion `shouldBe` 3++    it "RouterSelection sorts, deduplicates, caps, and rejects conflicts before dispatch" $ \(_storeHandle, StoreRunner _runner) -> do+      limit <- shouldBeRight (mkRecipientLimit 2)+      one <- shouldBeRight (mkRecipientLimit 1)+      let targetA = PMCommand {target = stream "selection-a", command = Add 1}+          targetB = PMCommand {target = stream "selection-b", command = Add 1}+          targetBConflict = PMCommand {target = stream "selection-b", command = Add 2}+      normalizeRecipients limit [targetB, targetA, targetB]+        `shouldBe` Right [targetA, targetB]+      normalizeRecipients limit [targetB, targetBConflict, targetA]+        `shouldBe` Left (SelectionConflictingCommands (StreamName "selection-b"))+      normalizeRecipients one [targetB, targetA, targetB]+        `shouldBe` Left (SelectionRecipientOverflow one 2)+      normalizeRecipients limit [targetB, targetA]+        `shouldBe` Right [targetA, targetB]++    it "RouterSelection exposes stable public dead-letter code, detail, and rendering" $ \(_storeHandle, StoreRunner _runner) -> do+      contract <- testSelectionContract EmptyDeadLetter FailureDeadLetter 4+      recipientLimit <- shouldBeRight (mkRecipientLimit 4)+      let failures =+            [ (SelectionQueryFailed "secret backend detail", "keiro.router.selection.query_failed"),+              (SelectionEvaluationFailed "secret payload", "keiro.router.selection.evaluation_failed"),+              (SelectionConflictingCommands (StreamName "hospital-1"), "keiro.router.selection.target_conflict"),+              (SelectionRecipientOverflow recipientLimit 5, "keiro.router.selection.recipient_overflow")+            ]+          assertReason expectedCode reason = do+            deadLetterCodeText (deadLetterReasonCode reason) `shouldBe` expectedCode+            deadLetterReasonDetail reason `shouldSatisfy` maybe False (not . Text.null)+            renderDeadLetterReason reason `shouldSatisfy` Text.isPrefixOf (expectedCode <> ": ")+      assertReason "keiro.router.selection.empty" (emptySelectionDeadLetterReason contract)+      for_ failures $ \(failure, expectedCode) -> do+        let reason = selectionFailureDeadLetterReason contract failure+        assertReason expectedCode reason+        renderDeadLetterReason reason `shouldNotSatisfy` Text.isInfixOf "secret"++    it "RouterSelection performs no target callback on conflict or overflow and dispatches exactly at the cap" $ \(_storeHandle, StoreRunner _runner) -> do+      twoRecipientContract <- testSelectionContract EmptyAck FailureRetry 2+      oneRecipientContract <- testSelectionContract EmptyAck FailureRetry 1+      callbacks <- newIORef (0 :: Int)+      let options = defaultRunCommandOptions & #beforeAppend .~ modifyIORef' callbacks (+ 1)+          sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          targetA = PMCommand {target = stream "bounded-a", command = Add 1}+          targetB = PMCommand {target = stream "bounded-b", command = Add 1}+          targetBConflict = PMCommand {target = stream "bounded-b", command = Add 2}+      Right conflict <-+        _runner $+          runDeclarativeRouterOnce+            options+            (selectionRouter twoRecipientContract (pure (Right [targetB, targetBConflict, targetA])))+            sourceEvent+            (RouteGroup "g1")+      conflict `shouldBe` DeclarativeSelectionFailed (SelectionConflictingCommands (StreamName "bounded-b"))+      readIORef callbacks `shouldReturn` 0+      Right overflow <-+        _runner $+          runDeclarativeRouterOnce+            options+            (selectionRouter oneRecipientContract (pure (Right [targetB, targetA, targetB])))+            sourceEvent+            (RouteGroup "g1")+      overflow `shouldBe` DeclarativeSelectionFailed (SelectionRecipientOverflow (oneRecipientContract ^. #limit) 2)+      readIORef callbacks `shouldReturn` 0+      Right atCap <-+        _runner $+          runDeclarativeRouterOnce+            options+            (selectionRouter twoRecipientContract (pure (Right [targetB, targetA, targetB])))+            sourceEvent+            (RouteGroup "g1")+      atCap `shouldSatisfy` \case+        DeclarativeSelectionDispatched (RouterResult results) -> length results == 2 && all isAppended results+        _ -> False+      readIORef callbacks `shouldReturn` 2++    it "RouterSelection retains successful targets after a later target dispatch fails" $ \(_storeHandle, StoreRunner _runner) -> do+      contract <- testSelectionContract EmptyAck FailureRetry 2+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          router =+            selectionRouter contract (pure (Right [PMCommand {target = stream "partial-a", command = Add 1}, PMCommand {target = stream "partial-b", command = Add 9}]))+              & #targetEventStream+              .~ rejectNineEventStream+      Right result <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1"))+      result `shouldSatisfy` \case+        DeclarativeSelectionDispatched (RouterResult [first, second]) -> isAppended first && isFailed second+        _ -> False+      Right partialA <- _runner (Store.readStreamForward (StreamName "partial-a") (StreamVersion 0) 10)+      Right partialB <- _runner (Store.readStreamForward (StreamName "partial-b") (StreamVersion 0) 10)+      Vector.length partialA `shouldBe` 1+      Vector.length partialB `shouldBe` 0++    it "RouterSelection preserves target-keyed stable union across result drift" $ \(_storeHandle, StoreRunner _runner) -> do+      contract <- testSelectionContract EmptyAck FailureRetry 2+      attempts <- newIORef (0 :: Int)+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          selectAttempt _ = do+            attempt <- liftIO (atomicModifyIORef' attempts (\value -> (value + 1, value)))+            pure $ Right $ case attempt of+              0 -> commandsFor ["union-b", "union-a"]+              _ -> commandsFor ["union-c", "union-a"]+          commandsFor targetNames = [PMCommand {target = stream targetName, command = Add 1} | targetName <- targetNames]+          router = (selectionRouter contract (pure (Right []))) {select = selectAttempt}+      Right first <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1"))+      Right second <- _runner (runDeclarativeRouterOnce defaultRunCommandOptions router sourceEvent (RouteGroup "g1"))+      first `shouldSatisfy` \case+        DeclarativeSelectionDispatched (RouterResult results) -> all isAppended results+        _ -> False+      second `shouldSatisfy` \case+        DeclarativeSelectionDispatched (RouterResult [unionA, unionC]) -> isDuplicate unionA && isAppended unionC+        _ -> False+      for_ ["union-a", "union-b", "union-c"] $ \targetName -> do+        Right events <- _runner (Store.readStreamForward (StreamName targetName) (StreamVersion 0) 10)+        Vector.length events `shouldBe` 1++    it "RouterSelection worker lowers the complete empty and failure policy matrices" $ \(_storeHandle, StoreRunner _runner) -> do+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          message = (sourceEvent, RouteGroup "g1")+          runCase emptySelectionPolicy failureSelectionPolicy selected = do+            contract <- testSelectionContract emptySelectionPolicy failureSelectionPolicy 2+            decisions <- newIORef []+            Right () <-+              _runner $+                runDeclarativeRouterWorker+                  defaultRunCommandOptions+                  (selectionRouter contract (pure selected))+                  (inMemoryAdapter decisions [message])+                  Just+            readIORef decisions+      runCase EmptyAck FailureRetry (Right []) `shouldReturn` [AckOk]+      runCase EmptyRetry FailureRetry (Right []) `shouldReturn` [AckRetry (RetryDelay 5)]+      emptyDeadLetter <- runCase EmptyDeadLetter FailureRetry (Right [])+      emptyDeadLetter `shouldSatisfy` \case+        [AckDeadLetter reason] -> deadLetterCodeText (deadLetterReasonCode reason) == "keiro.router.selection.empty"+        _ -> False+      emptyHalt <- runCase EmptyHalt FailureRetry (Right [])+      emptyHalt `shouldSatisfy` \case [AckHalt {}] -> True; _ -> False+      runCase EmptyAck FailureRetry (Left (SelectionQueryFailed "private")) `shouldReturn` [AckRetry (RetryDelay 5)]+      failureDeadLetter <- runCase EmptyAck FailureDeadLetter (Left (SelectionEvaluationFailed "private"))+      failureDeadLetter `shouldSatisfy` \case+        [AckDeadLetter reason] -> deadLetterCodeText (deadLetterReasonCode reason) == "keiro.router.selection.evaluation_failed"+        _ -> False+      failureHalt <- runCase EmptyAck FailureHalt (Left (SelectionQueryFailed "private"))+      failureHalt `shouldSatisfy` \case [AckHalt {}] -> True; _ -> False++    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++    it "bridges a pre-UTF-8 positional router redelivery with a non-ASCII key" $ \(storeHandle, StoreRunner _runner) -> do+      Right () <-+        _runner $+          initializeRegisteredReadModel routerTargetsReadModel initializeRouterTargetsTable+      let correlationId = "g-\x4E2D\x6587"+          targetStreamName = StreamName "transition-unicode-target"+          sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 1)+          legacyId = legacyDeterministicCommandId "demo-router" correlationId (sourceEvent ^. #eventId) 0+      Right () <-+        _runner $+          Store.runTransaction (Tx.statement (correlationId, "transition-unicode-target") insertRouterTargetStmt)+      appendCounterEventWithId storeHandle targetStreamName legacyId (CounterAdded 1)+      Right (RouterResult results) <-+        _runner $+          runRouterOnce defaultRunCommandOptions demoRouter sourceEvent (RouteGroup correlationId)+      Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10+      (results, Vector.length targetEvents)+        `shouldBe` ([PMCommandDuplicate legacyId], 1)++    it "bridges a pre-UTF-8 domain router redelivery with a non-ASCII key" $ \(storeHandle, StoreRunner _runner) -> do+      let sourceEvent = recordedFromEventId (EventId sampleUuid) (CounterAdded 9)+          correlationId = "\x4E2D\x6587-9"+          targetStreamName = StreamName ("domain-router-target:" <> correlationId <> ":0")+          legacyId = legacyDeterministicCommandId "domain-router" correlationId (sourceEvent ^. #eventId) 0+          input = DomainDispatchInput correlationId [CoordinatorAccept 9]+      appendCounterEventWithId storeHandle targetStreamName legacyId (CounterAdded 9)+      Right (DomainRouterResult results) <-+        _runner $+          runDomainRouterOnce defaultRunCommandOptions domainRouter sourceEvent input+      Right targetEvents <- _runner $ Store.readStreamForward targetStreamName (StreamVersion 0) 10+      (results, Vector.length targetEvents)+        `shouldBe` ([DomainPMCommandDuplicate legacyId], 1)++  describe "Keiro.Timer foreground consumer"+    $ around+      ( \action ->+          withFreshDatabase fixture $ \connection ->+            Store.withStore (Store.defaultConnectionSettings connection) $ \firstStore ->+              Store.withStore (Store.defaultConnectionSettings connection) $ \secondStore ->+                action (firstStore, secondStore)+      )+    $ do+      it "preflights original work and invokes one callback for competing authorized resumes" $ \(firstStore, secondStore) -> do+        let original = counterTimerRequest & #payload .~ object ["memorySpace" Aeson..= ("space-a" :: Text)]+            tid = original ^. #timerId+            owner = original ^. #processManagerName+            reason = "deferred: interactive session required"+        callbacks <- newIORef (0 :: Int)+        let foreground store allowed available = do+              Right _ <- Store.runStoreIO store recoverExpiredTimerResumes+              Right inspected <- Store.runStoreIO store $ lookupTimerInspection tid+              case inspected of+                Just inspection+                  | inspection ^. #lastError == Just reason,+                    inspection ^. #timer . #payload == object ["memorySpace" Aeson..= ("space-a" :: Text)],+                    allowed,+                    available -> do+                      Right (Right claimed) <- Store.runStoreIO store $ claimDeadTimer (DeadTimerClaimRequest tid owner reason 3 60)+                      forM_ claimed $ \_ -> atomicModifyIORef' callbacks (\n -> (n + 1, ()))+                      pure claimed+                _ -> pure Nothing+        Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ scheduleTimerTx original+        Right True <- Store.runStoreIO firstStore $ deadLetterTimer tid reason+        Right before <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt+        -- Revocation after listing and repeated unavailable-session preflights.+        Right (Right _) <- Store.runStoreIO firstStore $ findDeadTimers (DeadTimerFilter (Just owner) (ReasonExact reason)) (DeadTimerPageRequest 10 Nothing)+        denied <- foreground firstStore False True+        isNothing denied `shouldBe` True+        forM_ [1 .. 3 :: Int] $ \_ -> do+          unavailable <- foreground firstStore True False+          isNothing unavailable `shouldBe` True+        Store.runStoreIO firstStore (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before+        (a, b) <- timerRaceIO (foreground firstStore True True) (foreground secondStore True True)+        length (catMaybes [a, b]) `shouldBe` 1+        readIORef callbacks `shouldReturn` 1+        -- Crash, deterministic expiry, and recovery keep interactive work parked.+        Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx+        Store.runStoreIO secondStore recoverExpiredTimerResumes `shouldReturn` Right 1+        Store.runStoreIO firstStore (runTimerWorker Nothing dueTimerTime (\_ -> error "interactive work dispatched in background")) `shouldReturn` Right Nothing+        unavailable <- foreground firstStore True False+        isNothing unavailable `shouldBe` True+        Just next <- foreground secondStore True True+        resumeClaimTimer next ^. #timerId `shouldBe` tid+        resumeClaimTimer next ^. #attempts `shouldBe` 2+        -- A transient post-claim failure consumes the attempt and retains reason.+        Store.runStoreIO secondStore (parkTimerResume next) `shouldReturn` Right True+        Right (Just parked) <- Store.runStoreIO firstStore $ lookupTimerInspection tid+        parked ^. #lastError `shouldBe` Just reason+        parked ^. #timer . #attempts `shouldBe` 2+        -- Malformed work and ordinary dead letters are application refusals.+        Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.sql "UPDATE keiro.keiro_timers SET payload = '{}'::jsonb"+        malformed <- foreground firstStore True True+        isNothing malformed `shouldBe` True+        Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.sql "UPDATE keiro.keiro_timers SET last_error = 'ordinary dead letter'"+        ordinary <- foreground firstStore True True+        isNothing ordinary `shouldBe` True+        readIORef callbacks `shouldReturn` 2++      it "orders renewal and completion against recovery on independent stores" $ \(firstStore, secondStore) -> do+        let tid = counterTimerRequest ^. #timerId+            request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 3 60+        Right () <- Store.runStoreIO firstStore $ Store.runTransaction $ scheduleTimerTx counterTimerRequest+        Right True <- Store.runStoreIO firstStore $ deadLetterTimer tid "deferred"+        Right (Right (Just claim)) <- Store.runStoreIO firstStore $ claimDeadTimer request+        (renewed, recovered) <-+          timerRaceIO+            (Store.runStoreIO firstStore $ renewTimerResume claim 60)+            (Store.runStoreIO secondStore recoverExpiredTimerResumes)+        renewed `shouldBe` Right (Right True)+        recovered `shouldBe` Right 0+        Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx+        (expiredRenewal, expiredRecovery) <-+          timerRaceIO+            (Store.runStoreIO firstStore $ renewTimerResume claim 60)+            (Store.runStoreIO secondStore recoverExpiredTimerResumes)+        expiredRenewal `shouldBe` Right (Right False)+        expiredRecovery `shouldBe` Right 1+        Right (Right (Just replacement)) <- Store.runStoreIO firstStore $ claimDeadTimer request+        Right before <- Store.runStoreIO firstStore $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt+        forM_ [parkTimerResume claim, cancelTimerResume claim, completeTimerResume claim (EventId sampleUuid2)] $ \operation ->+          Store.runStoreIO firstStore operation `shouldReturn` Right False+        Store.runStoreIO firstStore (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before+        Right () <- Store.runStoreIO firstStore $ Store.runTransaction expireTimerResumesTx+        (expiredCompletion, completionRecovery) <-+          timerRaceIO+            (Store.runStoreIO firstStore $ completeTimerResume replacement (EventId sampleUuid2))+            (Store.runStoreIO secondStore recoverExpiredTimerResumes)+        expiredCompletion `shouldBe` Right False+        completionRecovery `shouldBe` Right 1+        Right (Right (Just finalClaim)) <- Store.runStoreIO firstStore $ claimDeadTimer request+        (completed, noRecovery) <-+          timerRaceIO+            (Store.runStoreIO firstStore $ completeTimerResume finalClaim (EventId sampleUuid2))+            (Store.runStoreIO secondStore recoverExpiredTimerResumes)+        completed `shouldBe` Right True+        noRecovery `shouldBe` Right 0++  describe "Keiro.Timer" $ around (withFreshStore fixture) $ do+    it "guards dead resume ownership and retains attempts when parked" $ \storeHandle -> do+      let tid = counterTimerRequest ^. #timerId+          request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 2 60+      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest+      Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred"+      Right (Right (Just claim)) <- Store.runStoreIO storeHandle $ claimDeadTimer request+      resumeClaimTimer claim ^. #attempts `shouldBe` 1+      Store.runStoreIO storeHandle (claimDueTimer dueTimerTime) `shouldReturn` Right Nothing+      Store.runStoreIO storeHandle (markTimerFired tid (EventId sampleUuid2)) `shouldReturn` Right False+      Store.runStoreIO storeHandle (cancelTimer tid) `shouldReturn` Right False+      Store.runStoreIO storeHandle (deadLetterTimer tid "wrong") `shouldReturn` Right False+      Store.runStoreIO storeHandle (requeueStuckTimer tid) `shouldReturn` Right False+      Store.runStoreIO storeHandle (requeueStuckTimers 0 (resumeClaimLeaseUntil claim)) `shouldReturn` Right 0+      Store.runStoreIO storeHandle (renewTimerResume claim 60) `shouldReturn` Right (Right True)+      Store.runStoreIO storeHandle (parkTimerResume claim) `shouldReturn` Right True+      Right (Right (Just replacement)) <- Store.runStoreIO storeHandle $ claimDeadTimer request+      resumeClaimTimer replacement ^. #attempts `shouldBe` 2+      Store.runStoreIO storeHandle (completeTimerResume claim (EventId sampleUuid2)) `shouldReturn` Right False+      Store.runStoreIO storeHandle (parkTimerResume claim) `shouldReturn` Right False+      Store.runStoreIO storeHandle (cancelTimerResume claim) `shouldReturn` Right False+      Store.runStoreIO storeHandle (renewTimerResume claim 60) `shouldReturn` Right (Right False)+      Store.runStoreIO storeHandle (parkTimerResume replacement) `shouldReturn` Right True+      Right (Right refused) <- Store.runStoreIO storeHandle $ claimDeadTimer request+      isNothing refused `shouldBe` True+      Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid+      observed ^. #lastError `shouldBe` Just "deferred"+      observed ^. #timer . #attempts `shouldBe` 2++    it "refuses every ineligible claim without changing any persisted column" $ \storeHandle -> do+      let tid = counterTimerRequest ^. #timerId+          request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 1 60+          snapshot = Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt+          refused req = do+            before <- snapshot+            Right (Right result) <- Store.runStoreIO storeHandle $ claimDeadTimer req+            isNothing result `shouldBe` True+            snapshot `shouldReturn` before+      refused request+      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest+      refused request+      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+      refused request+      Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred"+      refused (request & #processManagerName .~ "COUNTER")+      refused (request & #expectedReason .~ "Deferred")+      refused (request & #maxAttempts .~ 0)+      refused request -- ordinary claim already consumed the ceiling+      before <- snapshot+      Right (Left badMax) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #maxAttempts .~ (-1))+      badMax `shouldBe` InvalidTimerResumeMaxAttempts (-1)+      forM_ [0, -1, maxBound] $ \seconds -> do+        Right (Left badLease) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #leaseSeconds .~ seconds)+        badLease `shouldBe` InvalidTimerResumeLeaseSeconds seconds+      snapshot `shouldReturn` before+      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement (case tid of TimerId uuid -> uuid) legacyDeadTimerReasonStmt+      refused (request & #maxAttempts .~ 2)++    it "claims literal empty and Unicode reasons and preserves original work" $ \storeHandle -> do+      forM_ (zip [1 ..] ["", "延期: café 日本語 🌱", "a%_\\'雪"]) $ \(n, reason) -> do+        let original = counterTimerRequest & #timerId .~ TimerId (UUID.fromWords 0 0 0 n)+            tid = original ^. #timerId+            request = DeadTimerClaimRequest tid (original ^. #processManagerName) reason 1 60+        Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx original+        Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid reason+        Right (Just before) <- Store.runStoreIO storeHandle $ lookupTimer tid+        Right (Right (Just claim)) <- Store.runStoreIO storeHandle $ claimDeadTimer request+        resumeClaimTimer claim `shouldBe` (before & #status .~ Firing & #attempts .~ 1)+        Right (Right repeated) <- Store.runStoreIO storeHandle $ claimDeadTimer request+        isNothing repeated `shouldBe` True+        Store.runStoreIO storeHandle (completeTimerResume claim (EventId sampleUuid2)) `shouldReturn` Right True+        Right (Just inspection) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid+        inspection ^. #lastError `shouldBe` Just reason+        inspection ^. #timer . #firedEventId `shouldBe` Just (EventId sampleUuid2)+        Right (Right terminal) <- Store.runStoreIO storeHandle $ claimDeadTimer (request & #maxAttempts .~ 2)+        isNothing terminal `shouldBe` True++    it "expires without revival and re-parks independently of ordinary recovery" $ \storeHandle -> do+      let tid = counterTimerRequest ^. #timerId+          request = DeadTimerClaimRequest tid (counterTimerRequest ^. #processManagerName) "deferred" 3 60+      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest+      Right True <- Store.runStoreIO storeHandle $ deadLetterTimer tid "deferred"+      Right (Right (Just old)) <- Store.runStoreIO storeHandle $ claimDeadTimer request+      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction expireTimerResumesTx+      Right before <- Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt+      Store.runStoreIO storeHandle (renewTimerResume old 60) `shouldReturn` Right (Right False)+      Store.runStoreIO storeHandle (completeTimerResume old (EventId sampleUuid2)) `shouldReturn` Right False+      Store.runStoreIO storeHandle (parkTimerResume old) `shouldReturn` Right False+      Store.runStoreIO storeHandle (cancelTimerResume old) `shouldReturn` Right False+      Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () timerReadSnapshotStmt)) `shouldReturn` Right before+      let options = defaultTimerWorkerOptions & #requeueStuckAfter .~ Nothing+      Store.runStoreIO storeHandle (runTimerWorkerWith Nothing options dueTimerTime (\_ -> error "foreground work reached background")) `shouldReturn` Right Nothing+      Store.runStoreIO storeHandle recoverExpiredTimerResumes `shouldReturn` Right 0+      Right (Just parked) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid+      parked ^. #timer . #status `shouldBe` Dead+      parked ^. #timer . #attempts `shouldBe` 1+      parked ^. #lastError `shouldBe` Just "deferred"+      Right (Right (Just replacement)) <- Store.runStoreIO storeHandle $ claimDeadTimer request+      Store.runStoreIO storeHandle (completeTimerResume old (EventId sampleUuid2)) `shouldReturn` Right False+      Store.runStoreIO storeHandle (renewTimerResume old 60) `shouldReturn` Right (Right False)+      Store.runStoreIO storeHandle (cancelTimerResume replacement) `shouldReturn` Right True+      Right (Right cancelled) <- Store.runStoreIO storeHandle $ claimDeadTimer request+      isNothing cancelled `shouldBe` True++    it "inspects absent timers and preserves legacy metadata through every lifecycle" $ \storeHandle -> do+      let tid = counterTimerRequest ^. #timerId+          inspect reason = do+            Right old <- Store.runStoreIO storeHandle $ lookupTimer tid+            Right observed <- Store.runStoreIO storeHandle $ lookupTimerInspection tid+            fmap (^. #timer) observed `shouldBe` old+            fmap (^. #lastError) observed `shouldBe` Just reason+      Store.runStoreIO storeHandle (lookupTimerInspection tid) `shouldReturn` Right Nothing+      Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx counterTimerRequest+      inspect Nothing+      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+      inspect Nothing+      Right True <- Store.runStoreIO storeHandle $ markTimerFired tid (EventId sampleUuid2)+      inspect Nothing+      Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection tid+      observed ^. #timer . #firedEventId `shouldBe` Just (EventId sampleUuid2)+      observed ^. #timer . #attempts `shouldBe` 1++    it "preserves empty, populated, and Unicode dead reasons verbatim" $ \storeHandle -> do+      forM_ (zip [1 ..] ["", " retry exhausted ", "延期: café 日本語 🌱"]) $ \(n, reason) -> do+        let request = counterTimerRequest & #timerId .~ TimerId (UUID.fromWords 0 0 0 n)+        Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request+        Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (request ^. #timerId) reason+        Right old <- Store.runStoreIO storeHandle $ lookupTimer (request ^. #timerId)+        Right (Just observed) <- Store.runStoreIO storeHandle $ lookupTimerInspection (request ^. #timerId)+        Just (observed ^. #timer) `shouldBe` old+        observed ^. #lastError `shouldBe` Just reason++    it "filters dead timers by exact owner and literal reason, preserving NULL" $ \storeHandle -> do+      let fixtures =+            [ (1, "A", Just "deferred: one"),+              (2, "A", Just "deferred: 二"),+              (3, "B", Just "deferred: three"),+              (4, "A", Just "ordinary"),+              (5, "A", Nothing),+              (6, "A", Just ""),+              (7, "A", Just "a%_\\'雪 tail"),+              (8, "A", Just "aXX雪 tail"),+              (9, "a", Just "Deferred: one")+            ]+          tid n = TimerId (UUID.fromWords 0 0 0 n)+          check owner reason expected = do+            Right (Right page) <-+              Store.runStoreIO storeHandle $+                findDeadTimers (DeadTimerFilter owner reason) (DeadTimerPageRequest 100 Nothing)+            fmap (^. #timer . #timerId) (page ^. #timers) `shouldBe` fmap tid expected+            page ^. #nextAfterTimerId `shouldBe` Nothing+      forM_ fixtures $ \(n, owner, reason) -> do+        let request = counterTimerRequest & #timerId .~ tid n & #processManagerName .~ owner+        Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request+        Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (tid n) (fromMaybe "legacy" reason)+        when (isNothing reason) $ do+          Right () <-+            Store.runStoreIO storeHandle $+              Store.runTransaction $+                Tx.statement (UUID.fromWords 0 0 0 n) legacyDeadTimerReasonStmt+          Right (Just inspection) <- Store.runStoreIO storeHandle $ lookupTimerInspection (tid n)+          inspection ^. #lastError `shouldBe` Nothing+      -- Include every non-dead lifecycle in the same manager/reason search space.+      forM_ [10 .. 13] $ \n -> do+        Right () <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              scheduleTimerTx (counterTimerRequest & #timerId .~ tid n & #processManagerName .~ "A")+        pure ()+      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+      Right True <- Store.runStoreIO storeHandle $ markTimerFired (tid 10) (EventId sampleUuid2)+      Right (Just _) <- Store.runStoreIO storeHandle $ claimDueTimer dueTimerTime+      Right True <- Store.runStoreIO storeHandle $ cancelTimer (tid 12)+      Right (Just cancelled) <- Store.runStoreIO storeHandle $ lookupTimerInspection (tid 12)+      cancelled ^. #timer . #status `shouldBe` Timer.Cancelled+      check Nothing AnyTimerReason [1 .. 9]+      check (Just "A") (ReasonPrefix "deferred:") [1, 2]+      check Nothing (ReasonPrefix "deferred:") [1, 2, 3]+      check (Just "a") AnyTimerReason [9]+      check Nothing ReasonAbsent [5]+      check Nothing (ReasonExact "") [6]+      check Nothing (ReasonPrefix "") [1, 2, 3, 4, 6, 7, 8, 9]+      check Nothing (ReasonExact "deferred: 二") [2]+      check Nothing (ReasonPrefix "a%_\\'雪") [7]+      check Nothing (ReasonExact "a%_\\'雪 tail") [7]+      check Nothing (ReasonExact "DEFERRED: one") []+      check (Just "A' OR TRUE --") AnyTimerReason []++    it "bounds pages, traverses UUID order, and leaves every stored column unchanged" $ \storeHandle -> do+      forM_ [1 .. 101] $ \n -> do+        let request = plainTimerRequest n+        Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx request+        Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (request ^. #timerId) "deferred"+        pure ()+      let snapshot = Store.runStoreIO storeHandle $ Store.runTransaction $ Tx.statement () timerReadSnapshotStmt+          readPage size cursor = Store.runStoreIO storeHandle $ findDeadTimers anyDeadTimer (DeadTimerPageRequest size cursor)+      storedBefore <- snapshot+      forM_ [-1, 0, 101, maxBound] $ \size ->+        readPage size Nothing `shouldReturn` Right (Left (InvalidDeadTimerPageSize size))+      Right (Right first) <- readPage 100 Nothing+      length (first ^. #timers) `shouldBe` 100+      first ^. #nextAfterTimerId `shouldBe` Just (plainTimerRequest 100 ^. #timerId)+      readPage 100 Nothing `shouldReturn` Right (Right first)+      Right (Right finalPage) <- readPage 100 (first ^. #nextAfterTimerId)+      fmap (^. #timer . #timerId) (finalPage ^. #timers) `shouldBe` [plainTimerRequest 101 ^. #timerId]+      finalPage ^. #nextAfterTimerId `shouldBe` Nothing+      readPage 1 (Just (plainTimerRequest 101 ^. #timerId)) `shouldReturn` Right (Right (DeadTimerPage [] Nothing))+      let walk cursor = do+            Right (Right page) <- readPage 1 cursor+            let ids = fmap (^. #timer . #timerId) (page ^. #timers)+            case page ^. #nextAfterTimerId of+              Nothing -> pure ids+              next -> (ids <>) <$> walk next+      walk Nothing `shouldReturn` fmap ((^. #timerId) . plainTimerRequest) [1 .. 101]+      Right (Just _) <- Store.runStoreIO storeHandle $ lookupTimerInspection (plainTimerRequest 1 ^. #timerId)+      snapshot `shouldReturn` storedBefore+      Store.runStoreIO storeHandle (runTimerWorker Nothing dueTimerTime (\_ -> pure (Just (EventId sampleUuid2))))+        `shouldReturn` Right Nothing+      snapshot `shouldReturn` storedBefore++    it "continues after a deleted cursor and observes new eligibility only above it" $ \storeHandle -> do+      let add n = do+            Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx (plainTimerRequest n)+            Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (plainTimerRequest n ^. #timerId) "deferred"+            pure ()+          readPage cursor = Store.runStoreIO storeHandle $ findDeadTimers anyDeadTimer (DeadTimerPageRequest 1 cursor)+      mapM_ add [20, 40, 60]+      Right (Right first) <- readPage Nothing+      first ^. #nextAfterTimerId `shouldBe` Just (plainTimerRequest 20 ^. #timerId)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.sql+              "DELETE FROM keiro.keiro_timers WHERE correlation_id = 'drain-20'; UPDATE keiro.keiro_timers SET status = 'cancelled' WHERE correlation_id = 'drain-40'"+      mapM_ add [10, 30]+      Right (Right second) <- readPage (first ^. #nextAfterTimerId)+      fmap (^. #timer . #timerId) (second ^. #timers) `shouldBe` [plainTimerRequest 30 ^. #timerId]+      Right (Right third) <- readPage (second ^. #nextAfterTimerId)+      fmap (^. #timer . #timerId) (third ^. #timers) `shouldBe` [plainTimerRequest 60 ^. #timerId]+      third ^. #nextAfterTimerId `shouldBe` Nothing++    it "renders authorized original work beyond empty pages and rechecks revoked permissions" $ \storeHandle -> do+      let reason = "kioku:deferred:interactive-unavailable feature=summary details=保持"+          deadFilter = DeadTimerFilter (Just "drain-pm") (ReasonPrefix "kioku:deferred:interactive-unavailable feature=")+          entries =+            [ (1, object ["space" Aeson..= ("hidden" :: Text), "work" Aeson..= ("secret" :: Text)]),+              (2, object ["invalid" Aeson..= ("never render" :: Text)]),+              (3, object ["space" Aeson..= ("allowed" :: Text), "work" Aeson..= ("original work" :: Text)]),+              (4, object ["space" Aeson..= ("allowed" :: Text), "work" Aeson..= ("revoked work" :: Text)])+            ]+      forM_ entries $ \(n, payload) -> do+        Right () <- Store.runStoreIO storeHandle $ Store.runTransaction $ scheduleTimerTx (plainTimerRequest n & #payload .~ payload)+        Right True <- Store.runStoreIO storeHandle $ deadLetterTimer (plainTimerRequest n ^. #timerId) reason+        pure ()+      permissions <- newIORef (Set.singleton ("allowed" :: Text))+      let renderPage cursor = do+            Right (Right page) <- Store.runStoreIO storeHandle $ findDeadTimers deadFilter (DeadTimerPageRequest 1 cursor)+            fresh <- readIORef permissions+            rendered <- fmap catMaybes $ forM (page ^. #timers) $ \listed -> do+              Right inspected <- Store.runStoreIO storeHandle $ lookupTimerInspection (listed ^. #timer . #timerId)+              pure $ do+                inspection <- inspected+                (space, work) <-+                  either (const Nothing) Just $+                    parseEither (withObject "work" (\o -> (,) <$> o .: "space" <*> o .: "work")) (inspection ^. #timer . #payload)+                if Set.member space fresh then Just (work :: Text, inspection ^. #lastError) else Nothing+            pure (rendered, page ^. #nextAfterTimerId)+      (hidden, next1) <- renderPage Nothing+      hidden `shouldBe` []+      next1 `shouldSatisfy` isJust+      (malformed, next2) <- renderPage next1+      malformed `shouldBe` []+      next2 `shouldSatisfy` isJust+      (allowed, next3) <- renderPage next2+      allowed `shouldBe` [("original work", Just reason)]+      writeIORef permissions Set.empty+      renderPage next3 `shouldReturn` ([], Nothing)++    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)+      Right lookedUp <-+        Store.runStoreIO storeHandle $+          lookupTimer (counterTimerRequest ^. #timerId)+      fmap (^. #status) lookedUp `shouldBe` Just Firing+      -- 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 producer-identity" $ do+    let sourceId = EventId (UUID.fromWords 0 0 0 1)+        recorded = recordedFromEventId sourceId (CounterAdded 1)+        identity = ProducerOutbox.deriveProducerIdentity sampleProducer (ProducerOutbox.ProducerEventKey sourceId 0)+        enqueue producer event index draft storeHandle = Store.runStoreIO storeHandle (Store.runTransaction (ProducerOutbox.enqueueProducerEventTx producer event index draft))+        runDraft = enqueue sampleProducer recorded 0+        rows storeHandle = Store.runStoreIO storeHandle (ProducerOutbox.listOutbox "ordering")+    it "pins the version-1 SHA-256/UUIDv8 vector" $ do+      identity ^. #outboxId `shouldBe` OutboxId (UUID.fromWords 0x61dd62b4 0xbbfe81ce 0x96346ce6 0xafd48517)+      identity ^. #messageId `shouldBe` "msg_v1_61dd62b4bbfef1ce56346ce6afd485172774bc060102e5cf455e39bd0edfa84b"+      identity ^. #derivationVersion `shouldBe` 1+    it "pins canonical content digest independently of storage lifecycle" $ do+      ProducerOutbox.producerContentDigest (draftToEvent "ordering" "vector" sampleDraft)+        `shouldBe` "8b2eb3af1146c43d592f0ec19519609d4316ba4c83133eeb059a115a0517e323"+    it "separates source, name, event, index, tuple boundaries and UTF-8" $ do+      let key = ProducerOutbox.ProducerEventKey sourceId 0+          derive s n k = ProducerOutbox.deriveIdentity s n "msg" k+          values =+            [ derive "a" "bc" key,+              derive "ab" "c" key,+              derive "a" "b" key,+              derive "a" "b" (key & #emissionIndex .~ 1),+              derive "a" "b" (key & #sourceEventId .~ EventId sampleUuid),+              derive "a" "\x0101" key,+              derive "a" "\SOH" key+            ]+      Set.size (Set.fromList (fmap (^. #outboxId) values)) `shouldBe` length values+    it "rejects an empty namespace before subscription startup" $ do+      case mkIntegrationProducer (sampleProducer & #messageIdPrefix .~ "") of+        Left InvalidMessageIdPrefix {} -> pure ()+        _ -> expectationFailure "empty namespace was accepted"+    it "replays after closing and reopening the store with one unchanged row" $+      withFreshDatabase fixture $ \conn -> do+        before <- Store.withStore (Store.defaultConnectionSettings conn) $ \storeHandle -> do+          runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity)+          Right [row] <- rows storeHandle+          pure row+        Store.withStore (Store.defaultConnectionSettings conn) $ \storeHandle -> do+          runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity)+          rows storeHandle `shouldReturn` Right [before]+    around (withFreshStore fixture) $ do+      it "returns inserted, identical retry, and defaults recorded provenance" $ \storeHandle -> do+        runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity)+        Right [before] <- rows storeHandle+        (before ^. #event) ^. #sourceEventId `shouldBe` Just sourceId+        (before ^. #event) ^. #sourceGlobalPosition `shouldBe` Just (recorded ^. #globalPosition)+        runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity)+        rows storeHandle `shouldReturn` Right [before]+      it "rolls back enqueue with a failed checkpoint and reuses both IDs on redelivery" $ \storeHandle -> do+        Right () <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Tx.sql "CREATE TABLE producer_checkpoint (position bigint NOT NULL); INSERT INTO producer_checkpoint VALUES (0)"+        let checkpoint =+              Store.runStoreIO storeHandle $+                Store.runTransaction $+                  Tx.statement () (preparable "SELECT position FROM producer_checkpoint" E.noParams (D.singleRow (D.column (D.nonNullable D.int8))))+        result <- Store.runStoreIO storeHandle $ Store.runTransaction $ do+          outcome <- ProducerOutbox.enqueueProducerEventTx sampleProducer recorded 0 sampleDraft+          Tx.sql "UPDATE producer_checkpoint SET position = 1"+          Tx.condemn+          pure outcome+        result `shouldBe` Right (ProducerOutbox.ProducerInserted identity)+        rows storeHandle `shouldReturn` Right []+        checkpoint `shouldReturn` Right 0+        retried <- Store.runStoreIO storeHandle $ Store.runTransaction $ do+          outcome <- ProducerOutbox.enqueueProducerEventTx sampleProducer recorded 0 sampleDraft+          Tx.sql "UPDATE producer_checkpoint SET position = 1"+          pure outcome+        retried `shouldBe` Right (ProducerOutbox.ProducerInserted identity)+        checkpoint `shouldReturn` Right 1+        runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity)+        Right retained <- rows storeHandle+        length retained `shouldBe` 1+      it "concurrent identical attempts converge to one inserted and one duplicate" $ \storeHandle -> do+        a <- newEmptyMVar+        b <- newEmptyMVar+        _ <- forkIO (runDraft sampleDraft storeHandle >>= putMVar a)+        _ <- forkIO (runDraft sampleDraft storeHandle >>= putMVar b)+        outcomes <- sequence [takeMVar a, takeMVar b]+        length (filter (== Right (ProducerOutbox.ProducerInserted identity)) outcomes) `shouldBe` 1+        length (filter (== Right (ProducerOutbox.ProducerDuplicateIdentical identity)) outcomes) `shouldBe` 1+        Right retained <- rows storeHandle+        length retained `shouldBe` 1+      it "concurrent changed content selects one winner and reports one conflict" $ \storeHandle -> do+        a <- newEmptyMVar+        b <- newEmptyMVar+        _ <- forkIO (runDraft sampleDraft storeHandle >>= putMVar a)+        _ <- forkIO (runDraft (sampleDraft & #payloadBytes .~ "changed-secret") storeHandle >>= putMVar b)+        outcomes <- sequence [takeMVar a, takeMVar b]+        length (filter (== Right (ProducerOutbox.ProducerInserted identity)) outcomes) `shouldBe` 1+        length (filter (== Right (ProducerOutbox.ProducerIdentityConflict identity (ProducerOutbox.PayloadField NonEmpty.:| []))) outcomes) `shouldBe` 1+        Right retained <- rows storeHandle+        length retained `shouldBe` 1+      it "detects drift in every envelope field class without changing the original row" $ \storeHandle -> do+        runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity)+        Right [before] <- rows storeHandle+        let cases =+              [ (ProducerOutbox.RoutingField, sampleDraft & #destination .~ "elsewhere"),+                (ProducerOutbox.RoutingField, sampleDraft & #key .~ Nothing),+                (ProducerOutbox.SchemaField, sampleDraft & #eventType .~ "Renamed"),+                (ProducerOutbox.SchemaField, sampleDraft & #schemaVersion .~ 2),+                (ProducerOutbox.SchemaField, sampleDraft & #schemaReference ?~ SchemaReference (Just "r") (Just "s") (Just 2) (Just 3) (Just "f")),+                (ProducerOutbox.SchemaField, sampleDraft & #contentType .~ OtherContentType "application/json; charset=utf-8"),+                (ProducerOutbox.PayloadField, sampleDraft & #payloadBytes .~ "private-payload"),+                (ProducerOutbox.OccurredAtField, sampleDraft & #occurredAt %~ addUTCTime 1),+                (ProducerOutbox.CausalField, sampleDraft & #causationId ?~ sourceId),+                (ProducerOutbox.CausalField, sampleDraft & #correlationId ?~ sourceId),+                (ProducerOutbox.TraceField, sampleDraft & #traceContext ?~ TraceContext "parent" (Just "state")),+                (ProducerOutbox.AttributesField, sampleDraft & #attributes ?~ object ["private" Aeson..= True]),+                (ProducerOutbox.ProvenanceField, sampleDraft & #sourceEventId ?~ EventId sampleUuid),+                (ProducerOutbox.ProvenanceField, sampleDraft & #sourceGlobalPosition ?~ GlobalPosition 99)+              ]+        forM_ cases $ \(field, draft) -> do+          result <- runDraft draft storeHandle+          result `shouldBe` Right (ProducerOutbox.ProducerIdentityConflict identity (field NonEmpty.:| []))+          show result `shouldSatisfy` (not . isInfixOf "private-payload")+          rows storeHandle `shouldReturn` Right [before]+      it "normalizes sub-microsecond time and JSON object order across storage" $ \storeHandle -> do+        let draft =+              sampleDraft+                & #occurredAt+                %~ addUTCTime 0.123456789+                & #attributes+                ?~ object ["b" Aeson..= (2 :: Int), "a" Aeson..= (1 :: Int)]+        runDraft draft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity)+        runDraft (draft & #attributes ?~ object ["a" Aeson..= (1 :: Int), "b" Aeson..= (2 :: Int)]) storeHandle+          `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity)+      it "distinguishes absent attributes from JSON null and preserves raw MIME text" $ \storeHandle -> do+        let draft = sampleDraft & #attributes .~ Nothing & #contentType .~ OtherContentType "Application/JSON; charset=utf-8"+        runDraft draft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity)+        runDraft draft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity)+        runDraft (draft & #attributes ?~ Aeson.Null) storeHandle `shouldReturn` Right (ProducerOutbox.ProducerIdentityConflict identity (ProducerOutbox.AttributesField NonEmpty.:| []))+      it "keeps wire identity after successful-row retention expires" $ \storeHandle -> do+        _ <- runDraft sampleDraft storeHandle+        Right summary <- Store.runStoreIO storeHandle $ publishClaimedOutbox (perRow (\_ -> pure PublishSucceeded)) defaultPublishOptions Nothing+        summary ^. #published `shouldBe` 1+        Right [sent] <- rows storeHandle+        runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity)+        rows storeHandle `shouldReturn` Right [sent]+        now <- getCurrentTime+        Store.runStoreIO storeHandle (garbageCollectSent 0 (addUTCTime 1 now)) `shouldReturn` Right 1+        runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerInserted identity)+      it "different producer names and source events insert distinct identities" $ \storeHandle -> do+        let producer2 = sampleProducer & #name .~ ("second-producer" :: Text)+            recorded2 = recorded & #eventId .~ EventId sampleUuid+        _ <- runDraft sampleDraft storeHandle+        _ <- enqueue producer2 recorded 0 sampleDraft storeHandle+        _ <- enqueue sampleProducer recorded2 0 sampleDraft storeHandle+        Right retained <- rows storeHandle+        length retained `shouldBe` 3+        Set.size (Set.fromList (fmap (^. #outboxId) retained)) `shouldBe` 3+      it "preserves a rejected publication and its audit data on replay" $ \storeHandle -> do+        _ <- runDraft sampleDraft storeHandle+        rejection <- shouldBeRight (mkPublishRejection "refused" (Just "audit"))+        Right summary <-+          Store.runStoreIO storeHandle $+            publishClaimedOutbox (perRow (\_ -> pure (PublishRejected rejection))) defaultPublishOptions Nothing+        summary ^. #rejected `shouldBe` 1+        Right [before] <- rows storeHandle+        runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerDuplicateIdentical identity)+        rows storeHandle `shouldReturn` Right [before]+      it "reports both unique-identity collision routes and keeps explicit envelopes usable" $ \storeHandle -> do+        let event =+              draftToEvent "ordering" (identity ^. #messageId) sampleDraft+                & #sourceEventId+                ?~ sourceId+                & #sourceGlobalPosition+                ?~ GlobalPosition 1+        Store.runStoreIO storeHandle (Store.runTransaction (enqueueIntegrationEventTx (OutboxId outboxUuid1) event)) `shouldReturn` Right ()+        Store.runStoreIO storeHandle (Store.runTransaction (enqueueIntegrationEventTx (OutboxId outboxUuid1) event)) `shouldReturn` Right ()+        runDraft sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerIdentityConflict identity (ProducerOutbox.IdentityField NonEmpty.:| []))+        Right retained <- rows storeHandle+        length retained `shouldBe` 1+      it "treats namespace drift as an identity conflict on the outbox primary key" $ \storeHandle -> do+        _ <- runDraft sampleDraft storeHandle+        let changed = sampleProducer & #messageIdPrefix .~ ("event" :: Text)+            changedId = ProducerOutbox.deriveProducerIdentity changed (ProducerOutbox.ProducerEventKey sourceId 0)+        enqueue changed recorded 0 sampleDraft storeHandle `shouldReturn` Right (ProducerOutbox.ProducerIdentityConflict changedId (ProducerOutbox.IdentityField NonEmpty.:| []))+      it "records a distinct conflict metric after a checkpoint rollback" $ \storeHandle -> do+        (exporter, metricsRef) <- inMemoryMetricExporter+        (provider, _) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions {metricExporter = Just exporter}+        meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+        metrics <- Telemetry.newKeiroMetrics meter+        Right first <- runDraft sampleDraft storeHandle+        ProducerOutbox.recordProducerEnqueueOutcome (Just metrics) first+        Right outcome <- Store.runStoreIO storeHandle $ Store.runTransaction $ do+          result <- ProducerOutbox.enqueueProducerEventTx sampleProducer recorded 0 (sampleDraft & #payloadBytes .~ "secret")+          Tx.condemn+          pure result+        ProducerOutbox.recordProducerEnqueueOutcome (Just metrics) outcome+        _ <- forceFlushMeterProvider provider Nothing+        exported <- readIORef metricsRef+        lookup "keiro.outbox.identity.conflict" (flattenScalarPoints exported) `shouldBe` Just (IntNumber 1)++  describe "Keiro.Outbox" $ around (withFreshStore fixture) $ do+    it "validates terminal publication rejection data at its public boundary" $ \_storeHandle -> do+      let validCode64 = "a" <> Text.replicate 63 "z"+          validDetail1024 = Text.replicate 1024 "x"+          validUtf8Detail = Text.replicate 512 "é"+      valid <- shouldBeRight (mkPublishRejection validCode64 (Just validDetail1024))+      publishRejectionCode valid `shouldBe` validCode64+      publishRejectionDetail valid `shouldBe` Just validDetail1024+      shouldBeRight_ (mkPublishRejection "authorization.denied_v2" Nothing)+      shouldBeRight_ (mkPublishRejection "invalid-destination" (Just validUtf8Detail))+      mkPublishRejection "" Nothing+        `shouldBeLeft` InvalidPublishRejectionCode ""+      mkPublishRejection "Uppercase" Nothing+        `shouldBeLeft` InvalidPublishRejectionCode "Uppercase"+      mkPublishRejection "1leading-digit" Nothing+        `shouldBeLeft` InvalidPublishRejectionCode "1leading-digit"+      mkPublishRejection "contains/slash" Nothing+        `shouldBeLeft` InvalidPublishRejectionCode "contains/slash"+      mkPublishRejection ("a" <> Text.replicate 64 "z") Nothing+        `shouldBeLeft` InvalidPublishRejectionCode ("a" <> Text.replicate 64 "z")+      mkPublishRejection "invalid-destination" (Just "")+        `shouldBeLeft` PublishRejectionDetailEmpty+      mkPublishRejection "invalid-destination" (Just (Text.replicate 513 "é"))+        `shouldBeLeft` PublishRejectionDetailTooLong 1026++    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 "finalizes rejection exactly once with durable typed audit data" $ \storeHandle -> do+      let oid = OutboxId outboxUuid1+      rejection <- shouldBeRight (mkPublishRejection "authorization.denied" (Just "sink policy refused this message"))+      replacement <- shouldBeRight (mkPublishRejection "invalid.destination" Nothing)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+      firstClaimAt <- getCurrentTime+      Right [_] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 firstClaimAt)+      Right (Just OutboxFailed) <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (markOutboxFailedTx oid "transient predecessor" 5 0 firstClaimAt)+      secondClaimAt <- getCurrentTime+      Right [claimed] <- Store.runStoreIO storeHandle (claimOutboxBatch PerKeyHeadOfLine 10 secondClaimAt)+      rejectedAt <- getCurrentTime+      Right True <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (markOutboxRejectedTx oid rejection rejectedAt)+      Right False <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (markOutboxRejectedTx oid replacement (addUTCTime 60 rejectedAt))+      Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      row ^. #status `shouldBe` OutboxRejected+      row ^. #attemptCount `shouldBe` 2+      row ^. #nextAttemptAt `shouldBe` claimed ^. #nextAttemptAt+      row ^. #lastError `shouldBe` Nothing+      row ^. #publishedAt `shouldBe` Nothing+      row ^. #rejectedAt `shouldBe` Just rejectedAt+      row ^. #rejection `shouldBe` Just rejection++    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 "finalizes a mid-run rejection and continues the same-key suffix" $ \storeHandle -> do+      let row1Id = outboxIdFromOrdinal 1+          row2Id = outboxIdFromOrdinal 2+          row3Id = outboxIdFromOrdinal 3+          rows =+            [ (row1Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-1" & #key .~ Just "reject-run-key"),+              (row2Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-2" & #key .~ Just "reject-run-key"),+              (row3Id, sampleIntegrationEnvelope & #messageId .~ "reject-run-3" & #key .~ Just "reject-run-key")+            ]+      rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" (Just "the configured sink cannot accept this event type"))+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      let publish claimed =+            pure+              [ ( row ^. #outboxId,+                  if row ^. #outboxId == row2Id+                    then PublishRejected rejection+                    else PublishSucceeded+                )+              | row <- claimed+              ]+      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)+      summary ^. #claimed `shouldBe` 3+      summary ^. #published `shouldBe` 2+      summary ^. #rejected `shouldBe` 1+      summary ^. #retried `shouldBe` 0+      Right (Just row1) <- Store.runStoreIO storeHandle (lookupOutbox row1Id)+      Right (Just row2) <- Store.runStoreIO storeHandle (lookupOutbox row2Id)+      Right (Just row3) <- Store.runStoreIO storeHandle (lookupOutbox row3Id)+      row1 ^. #status `shouldBe` OutboxSent+      row2 ^. #status `shouldBe` OutboxRejected+      row2 ^. #rejection `shouldBe` Just rejection+      row3 ^. #status `shouldBe` OutboxSent++    it "redelivers callbacks after a pre-commit finalization failure" $ \storeHandle -> do+      let sentId = outboxIdFromOrdinal 1+          rejectedId = outboxIdFromOrdinal 2+          rows =+            [ (sentId, sampleIntegrationEnvelope & #messageId .~ "precommit-sent" & #key .~ Just "precommit-key"),+              (rejectedId, sampleIntegrationEnvelope & #messageId .~ "precommit-rejected" & #key .~ Just "precommit-key")+            ]+      rejection <- shouldBeRight (mkPublishRejection "invalid.destination" Nothing)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      callbackInvocations <- newIORef []+      let publish claimed = do+            liftIO (modifyIORef' callbackInvocations (fmap (^. #outboxId) claimed :))+            pure+              [ (row ^. #outboxId, if row ^. #outboxId == rejectedId then PublishRejected rejection else PublishSucceeded)+              | row <- claimed+              ]+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.sql+              "ALTER TABLE keiro.keiro_outbox ADD CONSTRAINT keiro_outbox_test_rejection_block CHECK (status <> 'rejected')"+      first <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)+      first `shouldSatisfy` \case+        Left _ -> True+        Right _ -> False+      Right (Just stillPublishingSent) <- Store.runStoreIO storeHandle (lookupOutbox sentId)+      Right (Just stillPublishingRejected) <- Store.runStoreIO storeHandle (lookupOutbox rejectedId)+      stillPublishingSent ^. #status `shouldBe` OutboxPublishing+      stillPublishingRejected ^. #status `shouldBe` OutboxPublishing+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.sql "ALTER TABLE keiro.keiro_outbox DROP CONSTRAINT keiro_outbox_test_rejection_block"+      now <- getCurrentTime+      let strandedAt = addUTCTime (-3600) now+          maintenanceOptions = defaultMaintenanceOptions & #publishingTimeout .~ 1+      Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt sentId strandedAt)+      Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt rejectedId strandedAt)+      Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass maintenanceOptions Nothing)+      maintenance ^. #requeued `shouldBe` 2+      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish defaultPublishOptions Nothing)+      summary ^. #published `shouldBe` 1+      summary ^. #rejected `shouldBe` 1+      Right (Just sentRow) <- Store.runStoreIO storeHandle (lookupOutbox sentId)+      Right (Just rejectedRow) <- Store.runStoreIO storeHandle (lookupOutbox rejectedId)+      sentRow ^. #status `shouldBe` OutboxSent+      rejectedRow ^. #status `shouldBe` OutboxRejected+      invocations <- readIORef callbackInvocations+      invocations `shouldBe` replicate 2 [sentId, rejectedId]++    it "treats rejection as terminal for per-source ordering" $ \storeHandle -> do+      let row1Id = outboxIdFromOrdinal 1+          row2Id = outboxIdFromOrdinal 2+          row3Id = outboxIdFromOrdinal 3+          sourceEvent oid messageId =+            (oid, sampleIntegrationEnvelope & #messageId .~ messageId & #source .~ "reject-source" & #key .~ Nothing)+          rows =+            [ sourceEvent row1Id "reject-source-1",+              sourceEvent row2Id "reject-source-2",+              sourceEvent row3Id "reject-source-3"+            ]+      rejection <- shouldBeRight (mkPublishRejection "authorization.denied" Nothing)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      let publish claimed =+            pure+              [ (row ^. #outboxId, if row ^. #outboxId == row2Id then PublishRejected rejection else PublishSucceeded)+              | row <- claimed+              ]+          opts = defaultPublishOptions & #orderingPolicy .~ PerSourceStream+      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish opts Nothing)+      summary ^. #published `shouldBe` 2+      summary ^. #rejected `shouldBe` 1+      Right (Just successor) <- Store.runStoreIO storeHandle (lookupOutbox row3Id)+      successor ^. #status `shouldBe` OutboxSent++    it "counts only a rejection finalization that wins the publishing-state race" $ \storeHandle -> do+      let oid = OutboxId outboxUuid1+      rejection <- shouldBeRight (mkPublishRejection "authorization.denied" Nothing)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+      now <- getCurrentTime+      let strandedAt = addUTCTime (-3600) now+          maintenanceOptions = defaultMaintenanceOptions & #publishingTimeout .~ 1+          publish _ = do+            backdateOutboxUpdatedAt oid strandedAt+            _ <- outboxMaintenancePass maintenanceOptions Nothing+            pure (PublishRejected rejection)+      Right summary <-+        Store.runStoreIO storeHandle $+          publishClaimedOutbox (perRow publish) defaultPublishOptions Nothing+      summary ^. #claimed `shouldBe` 1+      summary ^. #published `shouldBe` 0+      summary ^. #rejected `shouldBe` 0+      summary ^. #retried `shouldBe` 0+      summary ^. #dead `shouldBe` 0+      Right (Just row) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      row ^. #status `shouldBe` OutboxFailed+      row ^. #rejection `shouldBe` Nothing++    it "excludes rejected rows from claims, maintenance, backlog, and sent garbage collection" $ \storeHandle -> do+      let oid = OutboxId outboxUuid1+      rejection <- shouldBeRight (mkPublishRejection "invalid.destination" (Just "destination was removed"))+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+      Right summary <-+        Store.runStoreIO storeHandle $+          publishClaimedOutbox (perRow (const (pure (PublishRejected rejection)))) defaultPublishOptions Nothing+      summary ^. #rejected `shouldBe` 1+      now <- getCurrentTime+      Right () <- Store.runStoreIO storeHandle (backdateOutboxUpdatedAt oid (addUTCTime (-3600) now))+      Right claimed <- Store.runStoreIO storeHandle (claimOutboxBatch BestEffort 10 now)+      claimed `shouldBe` []+      Right maintenance <- Store.runStoreIO storeHandle (outboxMaintenancePass defaultMaintenanceOptions Nothing)+      maintenance ^. #requeued `shouldBe` 0+      maintenance ^. #deadLettered `shouldBe` 0+      maintenance ^. #backlog `shouldBe` 0+      Right deleted <- Store.runStoreIO storeHandle (garbageCollectSent 0 now)+      deleted `shouldBe` 0+      Right (Just retained) <- Store.runStoreIO storeHandle (lookupOutbox oid)+      retained ^. #status `shouldBe` OutboxRejected++    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 lateResult <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (markOutboxFailedTx oid "late failure from a timed-out worker" 5 60 now)+      lateResult `shouldBe` Nothing+      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 "StopTheLine continues after rejection and halts only on transient failure" $ \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-reject-" <> Text.pack (show i)) & #key .~ Just "stop-reject-key")+            | (i, oid) <- zip [1 .. 4 :: Int] ids+            ]+      rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" Nothing)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            traverse_ (uncurry enqueueIntegrationEventTx) rows+      seenRef <- newIORef []+      let publish claimed = do+            liftIO (modifyIORef' seenRef (<> fmap (^. #outboxId) claimed))+            pure+              [ ( row ^. #outboxId,+                  if row ^. #outboxId == row1Id+                    then PublishRejected rejection+                    else+                      if row ^. #outboxId == row3Id+                        then PublishFailed "stop after rejection"+                        else PublishSucceeded+                )+              | row <- claimed+              ]+          opts = defaultPublishOptions & #orderingPolicy .~ StopTheLine & #backoff .~ ConstantBackoff 0+      Right summary <- Store.runStoreIO storeHandle (publishClaimedOutbox publish opts Nothing)+      summary ^. #published `shouldBe` 1+      summary ^. #rejected `shouldBe` 1+      summary ^. #retried `shouldBe` 2+      summary ^. #haltedOn `shouldBe` Just row3Id+      readIORef seenRef `shouldReturn` take 3 ids+      Right (Just row4) <- Store.runStoreIO storeHandle (lookupOutbox row4Id)+      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 (freshIntegrationEvent 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 "does not mark a terminal rejection span as an error" $ \storeHandle -> do+      (processor, spansRef) <- inMemoryListExporter+      provider <- createTracerProvider [processor] emptyTracerProviderOptions+      rejection <- shouldBeRight (mkPublishRejection "authorization.denied" (Just "operator policy"))+      let tracer = makeTracer provider "keiro-test" tracerOptions+          oid = OutboxId outboxUuid1+          opts = defaultPublishOptions & #tracer ?~ tracer+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx oid sampleIntegrationEnvelope)+      Right summary <-+        Store.runStoreIO storeHandle $+          publishClaimedOutbox (perRow (const (pure (PublishRejected rejection)))) opts Nothing+      summary ^. #rejected `shouldBe` 1+      _ <- shutdownTracerProvider provider Nothing+      spans <- traverse captureSpan =<< readIORef spansRef+      case spans of+        [batchSpan] -> do+          textAttr (csAttributes batchSpan) "error.type" `shouldBe` Nothing+          case csStatus batchSpan of+            Unset -> pure ()+            Ok -> pure ()+            other -> expectationFailure ("expected rejection span to be Unset/Ok, got " <> show other)+        other -> expectationFailure ("expected one rejection 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+          rejectId = OutboxId outboxUuid3+          okEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-ok" & #key .~ Nothing+          failEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-fail" & #key .~ Nothing+          rejectEvent = sampleIntegrationEnvelope & #messageId .~ "metrics-reject" & #key .~ Nothing+      rejection <- shouldBeRight (mkPublishRejection "unsupported.sink" (Just "not routed"))+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx okId okEvent)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx failId failEvent)+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (enqueueIntegrationEventTx rejectId rejectEvent)+      let publish row+            | row ^. #outboxId == okId = pure PublishSucceeded+            | row ^. #outboxId == rejectId = pure (PublishRejected rejection)+            | 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 ^. #rejected `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.rejected" 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 delegated contracts" $ do+    it "computes the existing dedupe key and runs without a Store interpreter" $ do+      observed <- newIORef Nothing+      let event = sampleIntegrationEnvelope & #messageId .~ "delegated-no-store" & #source .~ "ordering"+      result <-+        runEff $+          runInboxDelegated Nothing PreferIntegrationMessageId event Nothing $ \dedupe delivered -> do+            liftIO (writeIORef observed (Just (dedupe, delivered ^. #source)))+            pure (DelegatedFresh (42 :: Int))+      result `shouldBe` Right (InboxProcessed 42)+      readIORef observed `shouldReturn` Just ("delegated-no-store", "ordering")++    it "rejects an invalid policy before invoking the delegated handler" $ do+      invoked <- newIORef False+      let event = sampleIntegrationEnvelope+      result <-+        runEff $+          runInboxDelegated Nothing (CustomDedupeKey "") event Nothing $ \_ _ -> do+            liftIO (writeIORef invoked True)+            pure (DelegatedFresh ())+      result `shouldBe` Left (DedupePolicyUnsatisfied (CustomDedupeKey ""))+      readIORef invoked `shouldReturn` False++    it "validates retry contexts and stops after the caller-owned ceiling" $ do+      mkDelegatedRetryContext 0 1 `shouldBe` Left "delegated retry ceiling must be positive"+      mkDelegatedRetryContext 3 0 `shouldBe` Left "delegated retry attempt must be positive"+      context3 <- shouldBeRight (mkDelegatedRetryContext 3 3)+      context4 <- shouldBeRight (mkDelegatedRetryContext 3 4)+      invoked <- newIORef (0 :: Int)+      let event = sampleIntegrationEnvelope & #messageId .~ "delegated-retry"+          handler _ _ = do+            liftIO (modifyIORef' invoked (+ 1))+            pure (DelegatedFresh ("ok" :: Text))+      atCeiling <- runEff (runInboxDelegatedWithRetries Nothing context3 PreferIntegrationMessageId event Nothing handler)+      aboveCeiling <- runEff (runInboxDelegatedWithRetries Nothing context4 PreferIntegrationMessageId event Nothing handler)+      atCeiling `shouldBe` Right (InboxProcessed "ok")+      aboveCeiling `shouldBe` Right (InboxPreviouslyFailed Nothing)+      readIORef invoked `shouldReturn` 1++    it "reports the current retry attempt when a synchronous handler exception occurs" $ do+      retryContext <- shouldBeRight (mkDelegatedRetryContext 3 2)+      let event = sampleIntegrationEnvelope & #messageId .~ "delegated-retry-failure"+          handler _ _ = liftIO (throwIO (userError "delegated exploded"))+      result <- runEff (runInboxDelegatedWithRetries Nothing retryContext PreferIntegrationMessageId event Nothing handler)+      case result of+        Right (InboxHandlerFailed reason 2) -> Text.isInfixOf "delegated exploded" reason `shouldBe` True+        other -> expectationFailure ("expected delegated attempt failure, got " <> show (void other))++    it "applies attempts 1 through 4 exactly at a ceiling of 3" $ do+      contexts <- traverse (shouldBeRight . mkDelegatedRetryContext 3) [1, 2, 3, 4]+      invocations <- newIORef (0 :: Int)+      let event = sampleIntegrationEnvelope & #messageId .~ "delegated-retry-ladder"+          failing _ _ = do+            liftIO (modifyIORef' invocations (+ 1))+            liftIO (throwIO (userError "retry ladder failure"))+            pure (DelegatedFresh ())+          succeeding _ _ = do+            liftIO (modifyIORef' invocations (+ 1))+            pure (DelegatedFresh ())+          forbidden _ _ = do+            liftIO (modifyIORef' invocations (+ 1))+            pure (DelegatedFresh ())+      case contexts of+        [attempt1, attempt2, attempt3, attempt4] -> do+          first <- runEff (runInboxDelegatedWithRetries Nothing attempt1 PreferIntegrationMessageId event Nothing failing)+          second <- runEff (runInboxDelegatedWithRetries Nothing attempt2 PreferIntegrationMessageId event Nothing failing)+          third <- runEff (runInboxDelegatedWithRetries Nothing attempt3 PreferIntegrationMessageId event Nothing succeeding)+          fourth <- runEff (runInboxDelegatedWithRetries Nothing attempt4 PreferIntegrationMessageId event Nothing forbidden)+          first `shouldSatisfy` \case Right (InboxHandlerFailed _ 1) -> True; _ -> False+          second `shouldSatisfy` \case Right (InboxHandlerFailed _ 2) -> True; _ -> False+          third `shouldBe` Right (InboxProcessed ())+          fourth `shouldBe` Right (InboxPreviouslyFailed Nothing)+          readIORef invocations `shouldReturn` 3+        other -> expectationFailure ("unexpected retry contexts: " <> show other)++    it "records failed and poisoned metrics on a failing ceiling attempt" $ do+      (exporter, metricsRef) <- inMemoryMetricExporter+      (provider, _env) <-+        createMeterProvider+          emptyMaterializedResources+          defaultSdkMeterProviderOptions {metricExporter = Just exporter}+      meter <- getMeter provider Telemetry.keiroInstrumentationLibrary+      metrics <- Telemetry.newKeiroMetrics meter+      retryContext <- shouldBeRight (mkDelegatedRetryContext 3 3)+      let event = sampleIntegrationEnvelope & #messageId .~ "delegated-poison-metrics"+          handler _ _ = do+            liftIO (throwIO (userError "terminal delegated failure"))+            pure (DelegatedFresh ())+      result <- runEff (runInboxDelegatedWithRetries (Just metrics) retryContext PreferIntegrationMessageId event Nothing handler)+      result `shouldSatisfy` \case Right (InboxHandlerFailed _ 3) -> True; _ -> False+      _ <- forceFlushMeterProvider provider Nothing+      exported <- readIORef metricsRef+      let scalars = flattenScalarPoints exported+      lookup "keiro.inbox.failed" scalars `shouldBe` Just (IntNumber 1)+      lookup "keiro.inbox.poisoned" scalars `shouldBe` Just (IntNumber 1)++    it "retries a batch identity after failure and suppresses it only after success" $ do+      invocations <- newIORef (0 :: Int)+      let event = sampleIntegrationEnvelope & #messageId .~ "delegated-batch-retry" & #source .~ "source-a"+          handler _ _ = do+            current <- liftIO (atomicModifyIORef' invocations (\n -> (n + 1, n)))+            when (current == 0) (liftIO (throwIO (userError "first attempt failed")))+            pure (DelegatedFresh ())+      results <-+        runEff $+          runInboxDelegatedBatch+            Nothing+            PreferIntegrationMessageId+            [(event, Nothing), (event, Nothing), (event, Nothing)]+            handler+      case results of+        [Right (InboxHandlerFailed reason 1), Right (InboxProcessed ()), Right InboxDuplicate] ->+          Text.isInfixOf "first attempt failed" reason `shouldBe` True+        other -> expectationFailure ("unexpected delegated batch results: " <> show other)+      readIORef invocations `shouldReturn` 2++    it "scopes in-batch suppression by integration source" $ do+      invocations <- newIORef ([] :: [Text])+      let first = sampleIntegrationEnvelope & #messageId .~ "shared" & #source .~ "source-a"+          second = sampleIntegrationEnvelope & #messageId .~ "shared" & #source .~ "source-b"+          handler _ event = do+            liftIO (modifyIORef' invocations (<> [event ^. #source]))+            pure (DelegatedFresh ())+      results <-+        runEff $+          runInboxDelegatedBatch Nothing PreferIntegrationMessageId [(first, Nothing), (second, Nothing)] handler+      results `shouldBe` [Right (InboxProcessed ()), Right (InboxProcessed ())]+      readIORef invocations `shouldReturn` ["source-a", "source-b"]++    it "keeps invalid and poison deliveries isolated from later batch items" $ do+      invoked <- newIORef ([] :: [Text])+      let invalid = sampleIntegrationEnvelope & #messageId .~ "" & #source .~ "invalid-source"+          poison = sampleIntegrationEnvelope & #messageId .~ "poison" & #source .~ "poison-source"+          healthy = sampleIntegrationEnvelope & #messageId .~ "healthy" & #source .~ "healthy-source"+          handler _ event = do+            liftIO (modifyIORef' invoked (<> [event ^. #source]))+            when (event ^. #source == "poison-source") (liftIO (throwIO (userError "poison item")))+            pure (DelegatedFresh ())+      results <-+        runEff $+          runInboxDelegatedBatch+            Nothing+            PreferIntegrationMessageId+            [(invalid, Nothing), (poison, Nothing), (healthy, Nothing)]+            handler+      case results of+        [ Left (DedupePolicyUnsatisfied PreferIntegrationMessageId),+          Right (InboxHandlerFailed reason 1),+          Right (InboxProcessed ())+          ] -> Text.isInfixOf "poison item" reason `shouldBe` True+        other -> expectationFailure ("unexpected isolated batch results: " <> show other)+      readIORef invoked `shouldReturn` ["poison-source", "healthy-source"]++    it "propagates async cancellation from a synchronized delegated batch handler" $ do+      entered <- newEmptyMVar+      release <- newEmptyMVar+      completed <- newEmptyMVar+      let event = sampleIntegrationEnvelope & #messageId .~ "delegated-cancel"+          handler _ _ = liftIO (putMVar entered () >> takeMVar release) >> pure (DelegatedFresh ())+      worker <-+        forkIO $ do+          outcome <-+            try @AsyncException $+              runEff (runInboxDelegatedBatch Nothing PreferIntegrationMessageId [(event, Nothing)] handler)+          putMVar completed outcome+      takeMVar entered+      killThread worker+      takeMVar completed `shouldReturn` Left ThreadKilled++  describe "Keiro.Inbox.Delegated pure adapters" $ do+    it "pins ASCII, Unicode, empty-field, and delimiter identity vectors" $ do+      let base = delegatedEventId "consumer" "source" "message" (StreamName "counter-1") "apply"+      base `shouldBe` EventId (uuidLiteral "8c9d74d0-1b27-5ef8-aa0c-3b37ed8ce8a8")+      delegatedEventId "消費者" "源" "鍵" (StreamName "対象-1") "適用"+        `shouldBe` EventId (uuidLiteral "e63f2f93-c519-5e9b-95e7-a233a1c32ae6")+      delegatedEventId "" "a:b" "c" (StreamName "") ":"+        `shouldBe` EventId (uuidLiteral "9ffa9002-be85-5713-8705-38c47a9731b4")+      base `shouldNotBe` delegatedEventId "consumer:" "source" "message" (StreamName "counter-1") "apply"+      base `shouldNotBe` delegatedEventId "consumer" ":source" "message" (StreamName "counter-1") "apply"+      base `shouldNotBe` delegatedEventId "consumer" "source" "message" (StreamName "counter-2") "apply"++    it "maps every process-manager command result without acknowledging failures or no-ops" $ do+      let targetName = StreamName "counter-delegated-pm"+          target = stream "counter-delegated-pm" :: Stream CounterEventStream+          appended n =+            CommandResult+              { target,+                streamVersion = StreamVersion (fromIntegral n),+                globalPosition = if n > 0 then Just (GlobalPosition (fromIntegral n)) else Nothing,+                eventsAppended = n+              }+          marker = EventId sampleUuid+      delegatedFromPMCommand targetName (PMCommandAppended (appended 2))+        `shouldBe` Right (DelegatedFresh (appended 2))+      delegatedFromPMCommand targetName (PMCommandDuplicate marker)+        `shouldBe` Right DelegatedDuplicate+      delegatedFromPMCommand targetName (PMCommandAppended (appended 0))+        `shouldBe` Left (DelegatedCommandWithoutReceipt targetName)+      delegatedFromPMCommand targetName (PMCommandFailed targetName CommandRejected)+        `shouldBe` Left (DelegatedCommandFailed targetName CommandRejected)++  describe "Keiro.Inbox delegated" $ around (withFreshResourceStore fixture) $ do+    it "bypasses the inbox and preflights a one-shot command before invalid dispatch" $ \(storeHandle, StoreRunner runner) -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      callbackInvocations <- newIORef (0 :: Int)+      let event = sampleIntegrationEnvelope & #messageId .~ "delegated-command-once" & #source .~ "delegated-source"+          targetName = StreamName "delegated-once-1"+          target = stream "delegated-once-1" :: Stream DelegatedOneShotEventStream+          marker = delegatedEventId "billing-consumer" (event ^. #source) (event ^. #messageId) targetName "apply-order"+          handler dedupe _ = do+            outcome <- delegatedCommand defaultRunCommandOptions targetName marker $ \prepared -> do+              liftIO (modifyIORef' callbackInvocations (+ 1))+              fmap (fmap Prelude.fst) $+                runCommandWithSql+                  prepared+                  delegatedOneShotEventStream+                  target+                  (Add 1)+                  (\_ -> Tx.statement dedupe inboxTestCounterInsertStmt)+            case outcome of+              Left err -> liftIO (throwIO (userError (show err)))+              Right delegated -> pure delegated+      first <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler)+      case first of+        Right (Right (InboxProcessed commandResult)) -> commandResult ^. #eventsAppended `shouldBe` 1+        other -> expectationFailure ("expected a fresh delegated command, got " <> show other)++      -- Hydrating and dispatching the command now would reject in the terminal+      -- state. Delegated replay must find the marker before reaching that path.+      directReplay <- runner (runCommand defaultRunCommandOptions delegatedOneShotEventStream target (Add 1))+      directReplay `shouldBe` Right (Left CommandRejected)+      second <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler)+      second `shouldBe` Right (Right InboxDuplicate)+      readIORef callbackInvocations `shouldReturn` 1++      Right stored <- Store.runStoreIO storeHandle (Store.readStreamForward targetName (StreamVersion 0) 10)+      Vector.length stored `shouldBe` 1+      stored Vector.! 0 ^. #eventId `shouldBe` marker+      Right counterRows <- Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () inboxTestCounterCountStmt))+      counterRows `shouldBe` 1+      Right inboxRows <- Store.runStoreIO storeHandle (listInbox "delegated-source")+      inboxRows `shouldBe` []++    it "recovers a lost acknowledgement for an atomic multi-event command" $ \(storeHandle, StoreRunner runner) -> 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 .~ "delegated-command-multi" & #source .~ "delegated-multi-source"+          targetName = StreamName "counter-delegated-multi"+          target = stream "counter-delegated-multi" :: Stream CounterEventStream+          marker = delegatedEventId "billing-consumer" (event ^. #source) (event ^. #messageId) targetName "apply-multi"+          handler dedupe _ = do+            outcome <- delegatedCommand defaultRunCommandOptions targetName marker $ \prepared ->+              fmap (fmap Prelude.fst) $+                runCommandWithSql+                  prepared+                  multiCounterEventStream+                  target+                  (Add 2)+                  (\_ -> Tx.statement dedupe inboxTestCounterInsertStmt)+            case outcome of+              Left err -> liftIO (throwIO (userError (show err)))+              Right delegated -> pure delegated+      -- Discard the first successful return to simulate a crash before source+      -- acknowledgement, then redeliver the same envelope.+      _ <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler)+      redelivery <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler)+      redelivery `shouldBe` Right (Right InboxDuplicate)+      Right stored <- Store.runStoreIO storeHandle (Store.readStreamForward targetName (StreamVersion 0) 10)+      Vector.length stored `shouldBe` 2+      stored Vector.! 0 ^. #eventId `shouldBe` marker+      Right counterRows <- Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () inboxTestCounterCountStmt))+      counterRows `shouldBe` 1+      Right inboxRows <- Store.runStoreIO storeHandle (listInbox "delegated-multi-source")+      inboxRows `shouldBe` []++    it "rejects zero-event commands and unconfirmed duplicate errors" $ \(_storeHandle, StoreRunner runner) -> do+      let targetName = StreamName "counter-delegated-errors"+          target = stream "counter-delegated-errors" :: Stream CounterEventStream+          marker = EventId sampleUuid+          other = EventId sampleUuid2+          noOp prepared = runCommand prepared noOpCounterEventStream target (Add 1)+      zero <- runner (delegatedCommand defaultRunCommandOptions targetName marker noOp)+      zero `shouldBe` Right (Left (DelegatedCommandWithoutReceipt targetName))+      mismatched <-+        runner $+          delegatedCommand defaultRunCommandOptions targetName marker $ \_ ->+            pure (Left (StoreFailed (Store.DuplicateEvent (Just other))))+      mismatched `shouldBe` Right (Left (DelegatedCommandFailed targetName (StoreFailed (Store.DuplicateEvent (Just other)))))+      missing <-+        runner $+          delegatedCommand defaultRunCommandOptions targetName marker $ \_ ->+            pure (Left (StoreFailed (Store.DuplicateEvent Nothing)))+      missing `shouldBe` Right (Left (DelegatedCommandFailed targetName (StoreFailed (Store.DuplicateEvent Nothing))))++    it "converges a concurrent delivery race to one event batch and SQL effect" $ \(storeHandle, StoreRunner runner) -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction (Tx.sql "CREATE TABLE IF NOT EXISTS inbox_test_counter (message_id TEXT PRIMARY KEY)")+      arrivals <- newMVar (0 :: Int)+      release <- newEmptyMVar+      firstDone <- newEmptyMVar+      secondDone <- newEmptyMVar+      retryContext <- shouldBeRight (mkDelegatedRetryContext 3 1)+      let event = sampleIntegrationEnvelope & #messageId .~ "delegated-race" & #source .~ "delegated-race-source"+          targetName = StreamName "counter-delegated-race"+          target = stream "counter-delegated-race" :: Stream CounterEventStream+          marker = delegatedEventId "billing-consumer" (event ^. #source) (event ^. #messageId) targetName "apply-race"+          awaitPeer = do+            arrived <- modifyMVar arrivals $ \count ->+              let next = count + 1+               in pure (next, next)+            when (arrived == 2) (putMVar release ())+            readMVar release+          options =+            defaultRunCommandOptions+              & #retryLimit+              .~ 0+              & #beforeAppend+              .~ awaitPeer+          handler dedupe _ = do+            outcome <- delegatedCommand options targetName marker $ \prepared ->+              fmap (fmap Prelude.fst) $+                runCommandWithSql+                  prepared+                  counterEventStream+                  target+                  (Add 1)+                  (\_ -> Tx.statement dedupe inboxTestCounterInsertStmt)+            case outcome of+              Left err -> liftIO (throwIO (userError (show err)))+              Right delegated -> pure delegated+          runOne destination =+            runner+              (runInboxDelegatedWithRetries Nothing retryContext PreferIntegrationMessageId event Nothing handler)+              >>= putMVar destination+      _ <- forkIO (runOne firstDone)+      _ <- forkIO (runOne secondDone)+      outcomes <- traverse takeMVar [firstDone, secondDone]+      let processed =+            Prelude.length+              [ ()+              | Right (Right (InboxProcessed {})) <- outcomes+              ]+          safeLosers =+            Prelude.length+              [ ()+              | Right (Right InboxDuplicate) <- outcomes+              ]+              + Prelude.length+                [ ()+                | Right (Right (InboxHandlerFailed {})) <- outcomes+                ]+      (processed, safeLosers) `shouldBe` (1, 1)++      -- A retry after either allowed loser classification observes the winner.+      replay <-+        runner $+          runInboxDelegated Nothing PreferIntegrationMessageId event Nothing $ \_ _ -> do+            outcome <- delegatedCommand defaultRunCommandOptions targetName marker (\_ -> error "race replay dispatched")+            case outcome of+              Left err -> liftIO (throwIO (userError (show err)))+              Right delegated -> pure delegated+      replay `shouldBe` Right (Right InboxDuplicate)+      Right stored <- Store.runStoreIO storeHandle (Store.readStreamForward targetName (StreamVersion 0) 10)+      Vector.length stored `shouldBe` 1+      Right counterRows <- Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () inboxTestCounterCountStmt))+      counterRows `shouldBe` 1+      Right inboxRows <- Store.runStoreIO storeHandle (listInbox "delegated-race-source")+      inboxRows `shouldBe` []++    it "does not acknowledge a globally colliding marker from another stream" $ \(storeHandle, StoreRunner runner) -> do+      let marker = EventId sampleUuid3+          foreignName = StreamName "counter-delegated-foreign"+          targetName = StreamName "counter-delegated-collision"+          target = stream "counter-delegated-collision" :: Stream CounterEventStream+      appendCounterEventWithId storeHandle foreignName marker (CounterAdded 9)+      outcome <-+        runner $+          delegatedCommand defaultRunCommandOptions targetName marker $ \prepared ->+            runCommand prepared counterEventStream target (Add 1)+      case outcome of+        Right (Left (DelegatedCommandFailed failedTarget (StoreFailed Store.DuplicateEvent {}))) ->+          failedTarget `shouldBe` targetName+        other -> expectationFailure ("expected an unconfirmed foreign collision, got " <> show other)+      Right targetEvents <- Store.runStoreIO storeHandle (Store.readStreamForward targetName (StreamVersion 0) 10)+      Right foreignEvents <- Store.runStoreIO storeHandle (Store.readStreamForward foreignName (StreamVersion 0) 10)+      Vector.length targetEvents `shouldBe` 0+      Vector.length foreignEvents `shouldBe` 1++  describe "Keiro.Inbox delegated access control"+    $ around+      ( withFreshResourceStorePrepared+          fixture+          prepareDelegatedDeniedInboxRole+          (\settings -> settings & #connString %~ (<> " user=delegated_inbox_denied"))+      )+    $ do+      it "runs with downstream privileges while the inbox table is denied" $ \(storeHandle, StoreRunner runner) -> do+        denied <- Store.runStoreIO storeHandle (listInbox "delegated-denied-source")+        denied `shouldSatisfy` \case+          Left _ -> True+          Right _ -> False+        let event = sampleIntegrationEnvelope & #messageId .~ "delegated-denied" & #source .~ "delegated-denied-source"+            targetName = StreamName "counter-delegated-denied"+            target = stream "counter-delegated-denied" :: Stream CounterEventStream+            marker = delegatedEventId "billing-consumer" (event ^. #source) (event ^. #messageId) targetName "apply-denied"+            handler dedupe _ = do+              outcome <- delegatedCommand defaultRunCommandOptions targetName marker $ \prepared ->+                fmap (fmap Prelude.fst) $+                  runCommandWithSql+                    prepared+                    counterEventStream+                    target+                    (Add 1)+                    (\_ -> Tx.statement dedupe inboxTestCounterInsertStmt)+              case outcome of+                Left err -> liftIO (throwIO (userError (show err)))+                Right delegated -> pure delegated+        first <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler)+        first `shouldSatisfy` \case+          Right (Right (InboxProcessed commandResult)) -> commandResult ^. #eventsAppended == 1+          _ -> False+        replay <- runner (runInboxDelegated Nothing PreferIntegrationMessageId event Nothing handler)+        replay `shouldBe` Right (Right InboxDuplicate)+        Right stored <- Store.runStoreIO storeHandle (Store.readStreamForward targetName (StreamVersion 0) 10)+        Vector.length stored `shouldBe` 1+        Right counterRows <- Store.runStoreIO storeHandle (Store.runTransaction (Tx.statement () inboxTestCounterCountStmt))+        counterRows `shouldBe` 1++  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++    -- Discovery is exact. A completed workflow is finished, and a workflow+    -- parked on an unresolved await has nothing to do until its wake source+    -- resolves — the wake's own append is what makes it discoverable again.+    it "discovers a parked workflow only once its awaited step is journaled" $ \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)+      parkedAt <- getCurrentTime+      Right whileParked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt)+      whileParked `shouldBe` []+      Right () <- Store.runStoreIO storeHandle $ do+        now <- liftIO getCurrentTime+        appendJournalEntry+          (WorkflowName "pending")+          (WorkflowId "p-1")+          (StepRecorded "awk:wait" (toJSON (7 :: Int)) now)+      wokenAt <- getCurrentTime+      Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)+      unfinished `shouldBe` [("p-1", "pending")]++  describe "Keiro.Workflow instance table" $ around (withFreshStore fixture) $ do+    it "lists workflow instances with filters and stable keyset pages" $ \storeHandle -> do+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $ do+            Instance.upsertInstanceTx "b-2" "beta" 0 Instance.WfFailed (Just "boom")+            Instance.upsertInstanceTx "a-2" "alpha" 0 Instance.WfCompleted Nothing+            Instance.upsertInstanceTx "b-1" "beta" 0 Instance.WfRunning Nothing+            Instance.upsertInstanceTx "a-1" "alpha" 0 Instance.WfFailed (Just "bad")++      let firstPageFilter =+            Instance.defaultWorkflowInstanceFilter+              { Instance.pageSize = 2+              }+      Right firstPage <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances firstPageFilter+      fmap (\row -> (row ^. #workflowName, row ^. #workflowId)) firstPage+        `shouldBe` [("alpha", "a-1"), ("alpha", "a-2")]++      let secondPageFilter =+            firstPageFilter+              { Instance.afterKey = Just ("alpha", "a-2")+              }+      Right secondPage <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances secondPageFilter+      fmap (\row -> (row ^. #workflowName, row ^. #workflowId)) secondPage+        `shouldBe` [("beta", "b-1"), ("beta", "b-2")]++      let failedBetaFilter =+            Instance.defaultWorkflowInstanceFilter+              { Instance.statuses = Just (Instance.WfFailed :| []),+                Instance.workflowName = Just "beta"+              }+      Right failedBeta <- Store.runStoreIO storeHandle $ Instance.listWorkflowInstances failedBetaFilter+      fmap (\row -> (row ^. #workflowName, row ^. #workflowId, row ^. #status)) failedBeta+        `shouldBe` [("beta", "b-2", Instance.WfFailed)]++    it "cancels active workflows idempotently without minting unknown state" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "operator-cancel"+          wid = WorkflowId "operator-cancel-1"+          completedName = WorkflowName "operator-completed"+          completedId = WorkflowId "operator-completed-1"+      Left (_ :: SimulatedCrash) <-+        try $+          Store.runStoreIO storeHandle $+            runWorkflow name wid (crashAfterStep1 counter)++      Right Instance.WorkflowCancelRecorded <-+        Store.runStoreIO storeHandle $+          Instance.cancelWorkflow name wid+      Right Keiro.Workflow.Cancelled <-+        Store.runStoreIO storeHandle $+          runWorkflow name wid (threeStep counter)+      readIORef counter `shouldReturn` 1+      Right (Instance.WorkflowAlreadyTerminal Instance.WfCancelled) <-+        Store.runStoreIO storeHandle $+          Instance.cancelWorkflow name wid++      Right (Completed _) <-+        Store.runStoreIO storeHandle $+          runWorkflow completedName completedId (demoWorkflow counter)+      Right (Instance.WorkflowAlreadyTerminal Instance.WfCompleted) <-+        Store.runStoreIO storeHandle $+          Instance.cancelWorkflow completedName completedId++      Right Instance.WorkflowCancelUnknown <-+        Store.runStoreIO storeHandle $+          Instance.cancelWorkflow (WorkflowName "missing") (WorkflowId "missing-1")+      Right Nothing <-+        Store.runStoreIO storeHandle $+          Instance.lookupInstance (WorkflowName "missing") (WorkflowId "missing-1")+      pure ()++    it "cancels suspended and linked-child workflows through supported paths" $ \storeHandle -> do+      let suspendedName = WorkflowName "operator-suspended"+          suspendedId = WorkflowId "operator-suspended-1"+          parentName = WorkflowName "operator-parent"+          parentId = WorkflowId "operator-parent-1"+          childName = WorkflowName "ship"+          childId = WorkflowId "operator-child-1"+      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow suspendedName suspendedId neverArmingWorkflow+      Right Instance.WorkflowCancelRecorded <-+        Store.runStoreIO storeHandle $+          Instance.cancelWorkflow suspendedName suspendedId+      now <- getCurrentTime+      Right discovered <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)+      discovered `shouldNotContain` [("operator-suspended-1", "operator-suspended")]++      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow parentName parentId (parentWorkflow childId)+      Right Instance.WorkflowCancelRecorded <-+        Store.runStoreIO storeHandle $+          Instance.cancelWorkflow childName childId+      Store.runStoreIO storeHandle (runWorkflow parentName parentId (parentWorkflow childId))+        `shouldThrow` (== WorkflowChildCancelled childName childId)++    it "serializes cancellation against completion so exactly one marker wins" $ \storeHandle -> do+      let name = WorkflowName "operator-terminal-race"+          wid = WorkflowId "operator-terminal-race-1"+      seededAt <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt)+      start <- newEmptyMVar+      cancelDone <- newEmptyMVar+      completeDone <- newEmptyMVar+      _ <- forkIO $ do+        takeMVar start+        result <- Store.runStoreIO storeHandle $ Instance.cancelWorkflow name wid+        putMVar cancelDone result+      _ <- forkIO $ do+        takeMVar start+        completedAt <- getCurrentTime+        result <- Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCompleted completedAt)+        putMVar completeDone result+      putMVar start ()+      putMVar start ()+      _ <- takeMVar cancelDone+      _ <- takeMVar completeDone+      Right hasCancelled <- Store.runStoreIO storeHandle $ stepExists name wid 0 cancelledStepName+      Right hasCompleted <- Store.runStoreIO storeHandle $ stepExists name wid 0 completedStepName+      (hasCancelled, hasCompleted) `shouldSatisfy` \case+        (True, False) -> True+        (False, True) -> True+        _ -> False++    it "force-releases leases and makes the old owner stop at its next boundary" $ \storeHandle -> do+      firstEffect <- newIORef (0 :: Int)+      secondEffect <- newIORef (0 :: Int)+      let name = WorkflowName "operator-force-release"+          wid = WorkflowId "operator-force-release-1"+          options owner =+            defaultWorkflowRunOptions+              & #leaseHeartbeat+              .~ Just LeaseHeartbeat {owner, ttl = 60}+          body = do+            first <-+              step (StepName "first") $ do+                value <- liftIO (incrementAndRead firstEffect)+                released <- Instance.forceReleaseInstanceLease name wid+                liftIO (released `shouldBe` True)+                pure value+            second <- step (StepName "second") (liftIO (incrementAndRead secondEffect))+            pure (first, second)+      Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 60 name wid+      claimedA `shouldBe` Instance.ClaimAcquired+      lost <-+        try+          ( Store.runStoreIO storeHandle $+              runWorkflowWith (options "owner-a") name wid body+          ) ::+          IO+            ( Either+                WorkflowLeaseLost+                (Either Store.StoreError (WorkflowOutcome (Int, Int)))+            )+      lost `shouldBe` Left WorkflowLeaseLost+      readIORef firstEffect `shouldReturn` 1+      readIORef secondEffect `shouldReturn` 0+      Right releasedAgain <- Store.runStoreIO storeHandle $ Instance.forceReleaseInstanceLease name wid+      releasedAgain `shouldBe` False++      Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 60 name wid+      claimedB `shouldBe` Instance.ClaimAcquired+      Right (Completed (1, 1)) <-+        Store.runStoreIO storeHandle $+          runWorkflowWith (options "owner-b") name wid body+      readIORef firstEffect `shouldReturn` 1+      readIORef secondEffect `shouldReturn` 1++    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 discovery index" $ around (withFreshStore fixture) $ do+    -- The discovery predicate must be stated as the positive active set+    -- (status IN ('running','suspended')) rather than as the complement of the+    -- terminal trio: Postgres proves partial-index applicability from the query+    -- predicate alone and never consults the table's CHECK constraint, so the+    -- complement form cannot use keiro_workflows_active_idx and seq-scans+    -- keiro_workflows on every resume pass. With seq scans discouraged, a plan+    -- that names the index is proof the planner can match it.+    it "plans the discovery predicate through keiro_workflows_active_idx" $ \storeHandle -> do+      now <- getCurrentTime+      Right () <- Store.runStoreIO storeHandle $+        Store.runTransaction $+          for_ (discoveryFixtureRows now) $ \row ->+            Tx.statement row insertWorkflowInstanceStmt+      Right planLines <- Store.runStoreIO storeHandle $+        Store.runTransaction $ do+          Tx.sql "SET LOCAL enable_seqscan = off"+          Tx.statement () explainDiscoveryStmt+      Text.unpack (Text.intercalate "\n" planLines)+        `shouldSatisfy` isInfixOf "keiro_workflows_active_idx"++    -- Exact discovery: 'running' always, 'suspended' only with a due wake hint.+    -- A suspended instance with no hint is parked on a wake source that will+    -- flip the row itself, so returning it would be pure waste.+    it "returns exactly the runnable and wake-due instances" $ \storeHandle -> do+      now <- getCurrentTime+      Right () <- Store.runStoreIO storeHandle $+        Store.runTransaction $+          for_ (discoveryFixtureRows now) $ \row ->+            Tx.statement row insertWorkflowInstanceStmt+      Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)+      unfinished+        `shouldBe` [ ("a-running", "discovery-index"),+                     ("c-due-sleep", "discovery-index")+                   ]++  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 snapshot wake-safety" $ around (withFreshStore fixture) $ do+    it "keeps a genuinely unresolved awakeable pending under Every 1" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "snapshot-unsignalled"+          wid = WorkflowId "wf1"+          opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1+          run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef)+      first <- run+      first `shouldBe` Right Suspended+      aid <- readRequiredAwakeableId aidRef+      Right (Just rowAfterFirst) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)+      rowAfterFirst ^. #status `shouldBe` Awk.Pending+      rowAfterFirst ^. #payload `shouldBe` Nothing+      second <- run+      second `shouldBe` Right Suspended+      Right (Just rowAfterSecond) <- Store.runStoreIO storeHandle $ Awk.lookupAwakeable (awakeableIdToUuid aid)+      rowAfterSecond ^. #status `shouldBe` Awk.Pending+      rowAfterSecond ^. #payload `shouldBe` Nothing++    it "delivers an awakeable signalled mid-run despite the stale in-memory map" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "snapshot-midrun-awakeable"+          wid = WorkflowId "wf1"+          opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1+          run = Store.runStoreIO storeHandle $ runWorkflowWith opts name wid snapshotShadowedAwakeable+      armed <-+        Store.runStoreIO storeHandle $+          runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef)+      armed `shouldBe` Right Suspended+      first <- run+      first `shouldBe` Right (Completed "payload")+      second <- run+      second `shouldBe` Right (Completed "payload")++    it "delivers an awakeable shadowed by a snapshot on a later run" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "snapshot-stale-awakeable"+          wid = WorkflowId "wf1"+          opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1+      armed <-+        Store.runStoreIO storeHandle $+          runWorkflowWith opts name wid (snapshotUnsignalledAwakeable aidRef)+      armed `shouldBe` Right Suspended+      first <-+        Store.runStoreIO storeHandle $+          runWorkflowWith opts name wid (snapshotStaleAwakeablePhaseOne aidRef)+      first `shouldBe` Right Suspended+      aid <- readRequiredAwakeableId aidRef+      Right (Just (staleSeed, _)) <-+        Store.runStoreIO storeHandle $+          loadWorkflowSnapshot (workflowGenerationStreamName name wid 0)+      staleSeed `shouldSatisfy` Map.notMember ("awk:" <> awakeableIdText aid)+      second <-+        Store.runStoreIO storeHandle $+          runWorkflowWith opts name wid snapshotStaleAwakeablePhaseTwo+      second `shouldBe` Right (Completed "payload")++    it "delivers a child completion shadowed by a snapshot on a later run" $ \storeHandle -> do+      let name = WorkflowName "snapshot-stale-child-parent"+          wid = WorkflowId "wf1"+          childWid = WorkflowId "child1"+          opts = defaultWorkflowRunOptions & #snapshotPolicy .~ Every 1+      first <-+        Store.runStoreIO storeHandle $+          runWorkflowWith opts name wid (snapshotStaleChildPhaseOne childWid)+      first `shouldBe` Right Suspended+      Right (Just (staleSeed, _)) <-+        Store.runStoreIO storeHandle $+          loadWorkflowSnapshot (workflowGenerationStreamName name wid 0)+      staleSeed `shouldSatisfy` Map.notMember (childResultStepName childWid)+      second <-+        Store.runStoreIO storeHandle $+          runWorkflowWith opts name wid (snapshotStaleChildPhaseTwo childWid)+      second `shouldBe` Right (Completed "packed+labelled")++  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,+            advanced = 1,+            resumed = 1,+            completed = 1,+            stillSuspended = 0,+            unknownName = 0,+            failed = 0,+            transientErrors = 0,+            leaseSkipped = 0,+            paced = 0,+            sleepDue = 0,+            unregisteredNames = Set.empty+          }+      -- 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,+            advanced = 1,+            resumed = 1,+            completed = 1,+            stillSuspended = 0,+            unknownName = 0,+            failed = 0,+            transientErrors = 0,+            leaseSkipped = 0,+            paced = 0,+            sleepDue = 0,+            unregisteredNames = Set.empty+          }+      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,+            advanced = 0,+            resumed = 0,+            completed = 0,+            stillSuspended = 0,+            unknownName = 1,+            failed = 0,+            transientErrors = 0,+            leaseSkipped = 0,+            paced = 0,+            sleepDue = 0,+            unregisteredNames = Set.singleton "orphan"+          }+      -- 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,+            advanced = 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++    -- Concurrency is opt-in and observable. Two workflows whose step actions+    -- take ~300 ms run in overlapping windows under `maxConcurrentAdvances = 2`+    -- and in disjoint windows under the default, so one slow step body no+    -- longer delays every other workflow in the pass.+    it "advances candidates concurrently only when the option allows it" $ \storeHandle -> do+      let slowStep windows label = do+            start <- liftIO getCurrentTime+            liftIO (threadDelay 300_000)+            end <- liftIO getCurrentTime+            liftIO (modifyMVar windows (\ws -> pure ((label, start, end) : ws, ())))+            pure (1 :: Int)+          runPass concurrency prefix = do+            windows <- newMVar []+            let nameA = WorkflowName (prefix <> "-a")+                nameB = WorkflowName (prefix <> "-b")+                widA = WorkflowId (prefix <> "-1")+                widB = WorkflowId (prefix <> "-2")+                opts =+                  defaultWorkflowResumeOptions+                    & #maxConcurrentAdvances+                    .~ concurrency+                    & #logEvent+                    .~ const (pure ())+                registry =+                  Map.fromList+                    [ (nameA, WorkflowDef (\_ -> step (StepName "slow") (slowStep windows ("a" :: Text)))),+                      (nameB, WorkflowDef (\_ -> step (StepName "slow") (slowStep windows "b")))+                    ]+            now <- getCurrentTime+            Right () <-+              Store.runStoreIO storeHandle $+                appendJournalEntry nameA widA (StepRecorded "seed" (toJSON True) now)+            Right () <-+              Store.runStoreIO storeHandle $+                appendJournalEntry nameB widB (StepRecorded "seed" (toJSON True) now)+            Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+            completed summary `shouldBe` 2+            readMVar windows+      concurrentWindows <- runPass 2 "overlap"+      windowsOverlap concurrentWindows `shouldBe` True+      serialWindows <- runPass 1 "serial"+      windowsOverlap serialWindows `shouldBe` False++    -- Concurrency must not change what a pass reports or how it isolates a bad+    -- candidate: the deltas are added at the end, so the summary cannot depend+    -- on the order candidates finish in. Each phase runs against its own fresh+    -- store, because an unknown-name candidate stays discoverable and would+    -- otherwise carry into the next phase's counts.+    it "reports a mixed pass the same way when advancing sequentially" $ \storeHandle -> do+      summary <- runMixedResumePass storeHandle 1+      summary `shouldBe` expectedMixedResumeSummary++    it "reports a mixed pass the same way when advancing concurrently" $ \storeHandle -> do+      summary <- runMixedResumePass storeHandle 3+      summary `shouldBe` expectedMixedResumeSummary++    it "records no crash attempt against a workflow that already went terminal" $ \storeHandle -> do+      let name = WorkflowName "crash-race"+          wid = WorkflowId "cr-1"+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (StepRecorded "seed" (toJSON True) now)+      -- A live instance paces normally.+      Right live <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Instance.recordCrashTx "cr-1" "crash-race" "boom"+      live `shouldBe` Just 1+      -- Once terminal, the UPDATE's status guard matches no row. That is the+      -- answer, not an error: there is no live instance left to pace.+      cancelledAt <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (WorkflowCancelled cancelledAt)+      Right afterTerminal <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Instance.recordCrashTx "cr-1" "crash-race" "boom"+      afterTerminal `shouldBe` Nothing++    -- The race the arm above exists for. Workflow A goes terminal inside its own+    -- run and then crashes, so the pass records its crash against a cancelled+    -- instance. The zero-row result used to fail a single-row decoder, and+    -- because the crash record sits outside the per-advance catches, the store+    -- error escaped the whole pass: `resumeWorkflowsOnce` returned Left and+    -- every remaining candidate was skipped until the next tick.+    it "survives a crash recorded against a just-cancelled workflow" $ \storeHandle -> do+      healthyCounter <- newIORef (0 :: Int)+      events <- newIORef ([] :: [ResumeLogEvent])+      let raceName = WorkflowName "crash-race-pass"+          raceId = WorkflowId "crp-1"+          healthyName = WorkflowName "crash-race-healthy"+          healthyId = WorkflowId "crh-1"+          opts =+            defaultWorkflowResumeOptions+              & #maxAttempts+              .~ 1+              & #logEvent+              .~ (\event -> modifyIORef' events (event :))+          registry =+            Map.fromList+              [ ( raceName,+                  WorkflowDef+                    ( \_ -> do+                        cancelledAt <- liftIO getCurrentTime+                        appendJournalEntry raceName raceId (WorkflowCancelled cancelledAt)+                        liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)+                    )+                ),+                (healthyName, WorkflowDef (\_ -> threeStep healthyCounter))+              ]+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry raceName raceId (StepRecorded "seed" (toJSON True) now)+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry healthyName healthyId (StepRecorded "seed" (toJSON True) now)+      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+      summary+        `shouldBe` emptyResumeSummary+          { discovered = 2,+            advanced = 1,+            resumed = 2,+            completed = 1,+            transientErrors = 1+          }+      -- The healthy workflow ran to completion regardless of which candidate+      -- discovery returned first, and nothing was marked failed: a workflow that+      -- is already cancelled must not also be condemned.+      readIORef healthyCounter `shouldReturn` 3+      logged <- readIORef events+      logged `shouldContain` [ResumeCrashRecordSkipped "crash-race-pass" "crp-1"]+      Right (Just raceRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance raceName raceId+      raceRow ^. #status `shouldBe` Instance.WfCancelled+      raceRow ^. #attempts `shouldBe` 0++    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 "resurrects a failed workflow and completes without rerunning its journaled prefix" $ \storeHandle -> do+      shouldCrash <- newIORef True+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "resurrect-complete"+          wid = WorkflowId "rc-1"+          opts =+            defaultWorkflowResumeOptions+              & #maxAttempts+              .~ 1+              & #logEvent+              .~ const (pure ())+          registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter))+      crashed <-+        try+          ( Store.runStoreIO storeHandle $+              runWorkflow name wid (recoverableWorkflow shouldCrash counter)+          ) ::+          IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int)))+      case crashed of+        Left _ -> pure ()+        Right other -> expectationFailure ("expected a simulated crash, got " <> show other)+      readIORef counter `shouldReturn` 1++      Right failedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+      failed failedPass `shouldBe` 1+      Right (Just failedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      failedRow ^. #status `shouldBe` Instance.WfFailed++      writeIORef shouldCrash False+      resurrected <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid+      resurrected `shouldBe` Right Instance.WorkflowResurrected+      Right (Just revivedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      revivedRow ^. #status `shouldBe` Instance.WfRunning+      revivedRow ^. #attempts `shouldBe` 0+      revivedRow ^. #lastError `shouldBe` Nothing+      revivedRow ^. #nextAttemptAt `shouldBe` Nothing++      Right completedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+      completed completedPass `shouldBe` 1+      readIORef counter `shouldReturn` 2+      Right (Just completedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      completedRow ^. #status `shouldBe` Instance.WfCompleted++    it "can fail again in the same generation after resurrection" $ \storeHandle -> do+      shouldCrash <- newIORef True+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "resurrect-refail"+          wid = WorkflowId "rr-1"+          opts =+            defaultWorkflowResumeOptions+              & #maxAttempts+              .~ 1+              & #logEvent+              .~ const (pure ())+          registry = Map.singleton name (WorkflowDef (\_ -> recoverableWorkflow shouldCrash counter))+      crashed <-+        try+          ( Store.runStoreIO storeHandle $+              runWorkflow name wid (recoverableWorkflow shouldCrash counter)+          ) ::+          IO (Either SomeException (Either Store.StoreError (WorkflowOutcome Int)))+      case crashed of+        Left _ -> pure ()+        Right other -> expectationFailure ("expected a simulated crash, got " <> show other)++      Right firstFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+      failed firstFailedPass `shouldBe` 1+      firstRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid+      firstRevival `shouldBe` Right Instance.WorkflowResurrected+      Right secondFailedPass <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+      failed secondFailedPass `shouldBe` 1+      Right (Just refailedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      refailedRow ^. #status `shouldBe` Instance.WfFailed++      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward+            (workflowGenerationStreamName name wid 0)+            (StreamVersion 0)+            10+      let failureIds =+            [ event ^. #eventId+            | event <- Vector.toList recorded,+              Right decoded <- [decodeRecorded workflowJournalCodec event],+              WorkflowFailed {} <- [decoded]+            ]+      case failureIds of+        [firstFailureId, secondFailureId] ->+          firstFailureId `shouldNotBe` secondFailureId+        other ->+          expectationFailure ("expected two failure events, got " <> show other)++      secondRevival <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid+      secondRevival `shouldBe` Right Instance.WorkflowResurrected++    it "guards resurrection and revives a failed child link transactionally" $ \storeHandle -> do+      let runningName = WorkflowName "resurrect-running"+          runningId = WorkflowId "running-1"+          missingName = WorkflowName "resurrect-missing"+          missingId = WorkflowId "missing-1"+          childName = WorkflowName "resurrect-child"+          childId = WorkflowId "child-1"+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry runningName runningId (StepRecorded "seed" (toJSON True) now)+      runningOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow runningName runningId+      runningOutcome `shouldBe` Right Instance.WorkflowNotFailed+      missingOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow missingName missingId+      missingOutcome `shouldBe` Right Instance.WorkflowNotFound++      Right childMarkedFailed <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $ do+            Child.registerChildTx+              "child-1"+              "resurrect-child"+              "parent-1"+              "resurrect-parent"+              "child:child-1:result"+            Child.markChildFailedTx "child-1" "resurrect-child" "simulated terminal failure"+      childMarkedFailed `shouldBe` True+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry childName childId (WorkflowFailed "simulated terminal failure" now)++      childOutcome <- Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow childName childId+      childOutcome `shouldBe` Right Instance.WorkflowResurrected+      Right (Just childRow) <- Store.runStoreIO storeHandle $ Child.lookupChild "child-1" "resurrect-child"+      childRow ^. #status `shouldBe` Child.Running+      childRow ^. #result `shouldBe` Nothing+      childRow ^. #failureReason `shouldBe` Nothing+      childRow ^. #completedAt `shouldBe` Nothing++    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` Instance.ClaimAcquired+      Right claimedB <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid+      claimedB `shouldBe` Instance.ClaimLeaseHeld+      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` Instance.ClaimAcquired++    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` Instance.ClaimAcquired+      Right attempt <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Instance.recordCrashTx "le-1" "lease-expire" "boom"+      attempt `shouldBe` Just 1+      Right () <- Store.runStoreIO storeHandle $ Instance.releaseInstance "owner-a" False name wid+      Right pacedClaim <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-b" 30 name wid+      pacedClaim `shouldBe` Instance.ClaimPaced+      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` Instance.ClaimAcquired+      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` Instance.ClaimAcquired+      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 lease renewal" $ around (withFreshStore fixture) $ do+    it "renews before a slow fresh step so the original lease cannot be stolen" $ \storeHandle -> do+      attemptedClaim <- newIORef Nothing+      let name = WorkflowName "lease-heartbeat"+          wid = WorkflowId "heartbeat-1"+          runOpts =+            defaultWorkflowRunOptions+              & #leaseHeartbeat+              .~ Just LeaseHeartbeat {owner = "owner-a", ttl = 60}+          body =+            step (StepName "slow-boundary") $ do+              liftIO (threadDelay 300_000)+              claimed <-+                Instance.claimInstance+                  "owner-b"+                  60+                  name+                  wid+              liftIO (writeIORef attemptedClaim (Just claimed))+              pure (claimed == Instance.ClaimAcquired)+      Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 0.2 name wid+      claimedA `shouldBe` Instance.ClaimAcquired+      outcome <- Store.runStoreIO storeHandle $ runWorkflowWith runOpts name wid body+      outcome `shouldBe` Right (Completed False)+      readIORef attemptedClaim `shouldReturn` Just Instance.ClaimLeaseHeld+      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      row ^. #leasedBy `shouldBe` Just "owner-a"++    it "stops at a lost lease boundary and the resume worker records no crash" $ \storeHandle -> do+      let directName = WorkflowName "lease-lost-direct"+          directId = WorkflowId "lost-direct-1"+          directOpts =+            defaultWorkflowRunOptions+              & #leaseHeartbeat+              .~ Just LeaseHeartbeat {owner = "owner-a", ttl = 60}+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry directName directId (StepRecorded "seed" (toJSON True) now)+      Right claimedA <- Store.runStoreIO storeHandle $ Instance.claimInstance "owner-a" 60 directName directId+      claimedA `shouldBe` Instance.ClaimAcquired+      leaseUntil <- addUTCTime 60 <$> getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement+              ("lost-direct-1", "lease-lost-direct", "owner-b", leaseUntil)+              forceWorkflowLeaseStmt+      firstDirectEffect <- newIORef (0 :: Int)+      secondDirectEffect <- newIORef (0 :: Int)+      direct <-+        try+          ( Store.runStoreIO storeHandle $+              runWorkflowWith directOpts directName directId $ do+                _ <- step (StepName "first") (liftIO (incrementAndRead firstDirectEffect))+                step (StepName "second") (liftIO (incrementAndRead secondDirectEffect))+          ) ::+          IO+            ( Either+                WorkflowLeaseLost+                (Either Store.StoreError (WorkflowOutcome Int))+            )+      direct `shouldBe` Left WorkflowLeaseLost+      readIORef firstDirectEffect `shouldReturn` 0+      readIORef secondDirectEffect `shouldReturn` 0+      directFinishedAt <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry directName directId (WorkflowCompleted directFinishedAt)++      firstWorkerEffect <- newIORef (0 :: Int)+      secondWorkerEffect <- newIORef (0 :: Int)+      let workerName = WorkflowName "lease-lost-worker"+          workerId = WorkflowId "lost-worker-1"+          workerOpts =+            defaultWorkflowResumeOptions+              & #logEvent+              .~ const (pure ())+          registry =+            Map.singleton workerName $+              WorkflowDef $ \_ -> do+                _ <-+                  step (StepName "first") $ do+                    value <- liftIO (incrementAndRead firstWorkerEffect)+                    expires <- liftIO (addUTCTime 60 <$> getCurrentTime)+                    Store.runTransaction $+                      Tx.statement+                        ("lost-worker-1", "lease-lost-worker", "owner-b", expires)+                        forceWorkflowLeaseStmt+                    pure value+                step (StepName "second") (liftIO (incrementAndRead secondWorkerEffect))+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry workerName workerId (StepRecorded "seed" (toJSON True) now)+      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce workerOpts registry+      summary+        `shouldBe` emptyResumeSummary+          { discovered = 1,+            leaseSkipped = 1+          }+      readIORef firstWorkerEffect `shouldReturn` 1+      readIORef secondWorkerEffect `shouldReturn` 0+      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance workerName workerId+      row ^. #attempts `shouldBe` 0+      row ^. #leasedBy `shouldBe` Just "owner-b"++  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.Workflow patch recording at rotation" $ around (withFreshStore fixture) $ do+    it "keeps the active patch after a wake append lands before the first rotated run" $ \storeHandle -> do+      let name = WorkflowName "patch-rotation-race"+          wid = WorkflowId "prr-1"+          patchOptions =+            defaultWorkflowRunOptions+              & #activePatches+              .~ Set.singleton fraudPatchId+          generationOneStream = workflowGenerationStreamName name wid 1++      first <-+        Store.runStoreIO storeHandle $+          runWorkflowWith patchOptions name wid rotatingPatchWorkflow+      first `shouldBe` Right ContinuedAsNew+      Right patchSetRecorded <-+        Store.runStoreIO storeHandle $+          stepExists name wid 1 patchSetStepName+      patchSetRecorded `shouldBe` True++      now <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry+            name+            wid+            ( StepRecorded+                "awk:11111111-1111-1111-1111-111111111111"+                (toJSON True)+                now+            )++      second <-+        Store.runStoreIO storeHandle $+          runWorkflowWith patchOptions name wid rotatingPatchWorkflow+      second `shouldBe` Right (Completed "new-branch")+      replayed <-+        Store.runStoreIO storeHandle $+          runWorkflowWith patchOptions name wid rotatingPatchWorkflow+      replayed `shouldBe` Right (Completed "new-branch")++      Right generationOneJournal <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward generationOneStream (StreamVersion 0) 20+      let decoded =+            map (decodeRecorded workflowJournalCodec) (Vector.toList generationOneJournal)+          patchSets =+            [ value+            | Right (StepRecorded key value _) <- decoded,+              key == patchSetStepName+            ]+          decisions =+            [ value+            | Right (StepRecorded key value _) <- decoded,+              key == patchStepName fraudPatchId+            ]+      patchSets `shouldBe` [toJSON [unPatchId fraudPatchId]]+      decisions `shouldBe` [toJSON True]++  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+      -- Break the table discovery itself reads, so every pass fails outright.+      -- (Hiding keiro_workflow_steps no longer suffices: under exact discovery+      -- the parked workflow is not returned, so a pass never reaches it.)+      Right () <-+        Store.runStoreIO store $+          Store.runTransaction $+            Tx.sql "ALTER TABLE keiro.keiro_workflows RENAME TO keiro_workflows_hidden"+      worker <- forkIO (runWorkflowResumeWorkerPush store opts registry)+      logged <- waitForPassFailure+      logged `shouldBe` Just ()+      Right () <-+        Store.runStoreIO store $+          Store.runTransaction $+            Tx.sql "ALTER TABLE keiro.keiro_workflows_hidden RENAME TO keiro_workflows"+      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"+      -- Park a workflow on the first of two gates, then journal that gate's+      -- result. The append flips the instance row to running, which is what+      -- makes exact discovery return it; the re-invocation then parks on the+      -- second gate and stays Suspended, which still counts as a re-invocation.+      suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (twoGateWorkflow counter)+      suspended `shouldBe` Right Suspended+      gateAt <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (StepRecorded "awk:first" (toJSON ()) gateAt)+      -- Register one pending awakeable (independent of the suspended workflow's+      -- own await) so the pending gauge has something to count.+      let aid = awakeableIdToUuid (generation0AwakeableId (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 -> twoGateWorkflow counter))+          resumeOpts =+            defaultWorkflowResumeOptions+              & #runOptions+              .~ (defaultWorkflowRunOptions & #metrics .~ Just metrics)+      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce resumeOpts registry+      (discovered summary, resumed summary, stillSuspended summary) `shouldBe` (1, 1, 1)+      _ <- 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 ^. #stateShapeHash) `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 deterministic id derivation" $ do+    -- Deterministic ids are replay identity: the same seed must yield the same+    -- id on every deploy, forever (ADR 24). Every literal below was captured+    -- from the *previous* derivation — which hashed each character's codepoint+    -- modulo 256 — before it was replaced by UTF-8 seed bytes. For ASCII seeds+    -- the two encodings agree byte for byte, so a failure here means a+    -- deployed id moved. Regenerate a literal only alongside a versioned+    -- derivation and a migration story, never to make the suite green.+    let name = WorkflowName "orderFulfillment"+        wid = WorkflowId "wf-1"+        sourceEventId = EventId (uuidLiteral "3f2504e0-4f89-51d3-9a0c-0305e82c3301")++    it "freezes the ASCII journal-event ids, reserved step names included" $ do+      deterministicJournalId name wid 0 "charge-card"+        `shouldBe` EventId (uuidLiteral "1618b21a-5321-536f-998b-99f88f078148")+      deterministicJournalId name wid 1 "charge-card"+        `shouldBe` EventId (uuidLiteral "ddbf5d19-df0d-50f7-9aa2-9c8214bfde00")+      deterministicJournalId name wid 0 completedStepName+        `shouldBe` EventId (uuidLiteral "5ac985e8-4168-5705-91bc-5523833d3f60")+      deterministicJournalId name wid 0 cancelledStepName+        `shouldBe` EventId (uuidLiteral "52493d94-d35a-5a7e-8ce9-40e1111c45f9")+      deterministicJournalId name wid 0 failedStepName+        `shouldBe` EventId (uuidLiteral "b7ed900d-0fac-54dd-87b1-a01f6782a298")+      deterministicJournalId name wid 0 continuedAsNewStepName+        `shouldBe` EventId (uuidLiteral "338f8962-ef47-5992-a4e0-c314358a2f05")+      deterministicJournalId name wid 0 continueSeedStepName+        `shouldBe` EventId (uuidLiteral "268c2031-b026-564a-be24-85cab59c3ce7")+      deterministicJournalId name wid 0 patchSetStepName+        `shouldBe` EventId (uuidLiteral "c188a7f9-617d-59e5-8e09-4498d7daf477")+      deterministicJournalId name wid 0 (patchStepName (PatchId "new-tax"))+        `shouldBe` EventId (uuidLiteral "64de4580-0a2d-522b-b397-e25c6ee3eacc")+      deterministicJournalId name wid 0 (sleepStepName (StepName "cool"))+        `shouldBe` EventId (uuidLiteral "e3a009bd-f287-5331-9f72-8e273f0040cf")++    it "freezes the ASCII sleep, awakeable, and process-manager ids" $ do+      sleepTimerId name wid 0 "sleep:cool"+        `shouldBe` TimerId (uuidLiteral "cfebe58e-b34c-5031-af98-18e71e6f4cfa")+      sleepTimerId name wid 1 "sleep:cool"+        `shouldBe` TimerId (uuidLiteral "e9696450-3993-59da-902e-4e5ebcfd1ab0")+      sleepTimerId name wid 2 "sleep:cool"+        `shouldBe` TimerId (uuidLiteral "6affc998-5cf2-51d0-9bbb-22e792581433")+      generation0AwakeableId name wid "approval"+        `shouldBe` AwakeableId (uuidLiteral "f677231c-8a27-51b6-9a5e-69015262b26f")+      deterministicCommandId "counter-pm" "order-1" sourceEventId 0+        `shouldBe` EventId (uuidLiteral "ff20892c-6665-5e92-8c99-d1569d2ce629")+      deterministicCommandId "counter-pm" "order-1" sourceEventId (-1)+        `shouldBe` EventId (uuidLiteral "4f3aa6bc-b12c-5dae-8eb5-81f6364f41ef")++    it "freezes target-keyed process-reaction ids and their byte preimage" $ do+      let asciiId =+            Reaction.deterministicReactionCommandId+              "billing"+              "order:1"+              sourceEventId+              (StreamName "account:42")+              0+          explicitPreimage =+            "5:keiro16:process-reaction7:billing7:order:136:3f2504e0-4f89-51d3-9a0c-0305e82c330110:account:421:0"+          independentlyHashed =+            EventId+              ( UUID.V5.generateNamed+                  UUID.V5.namespaceURL+                  (ByteString.unpack (TE.encodeUtf8 explicitPreimage))+              )+      asciiId `shouldBe` EventId (uuidLiteral "5a89007a-a634-58bf-8002-5ea7843155f2")+      asciiId `shouldBe` independentlyHashed+      Reaction.deterministicReactionCommandId+        "\x4E2D\x6587"+        "corr:\x0101"+        sourceEventId+        (StreamName "target:\x1F600")+        0+        `shouldBe` EventId (uuidLiteral "ca7f7bd8-2b54-508f-a542-1e24da394d95")++    it "separates reaction fields, targets, occurrences, and the router family" $ do+      let reaction manager correlation target occurrence =+            Reaction.deterministicReactionCommandId manager correlation sourceEventId (StreamName target) occurrence+          baseline = reaction "a:b" "c" "target" 0+      baseline `shouldNotBe` reaction "a" "b:c" "target" 0+      baseline `shouldNotBe` reaction "a:b" "c" "target:other" 0+      baseline `shouldNotBe` reaction "a:b" "c" "target" 1+      baseline+        `shouldNotBe` deterministicRouterCommandId "a:b" "c" sourceEventId (StreamName "target") 0++    -- Each pair below produced one shared id under the old derivation, because+    -- U+0101 and U+0001 (and U+4E2D/U+2E2D, U+6587/U+2587) agree modulo 256.+    it "separates seeds the codepoint-truncating derivation collapsed" $ do+      deterministicJournalId name wid 0 "\x0101"+        `shouldNotBe` deterministicJournalId name wid 0 "\SOH"+      deterministicJournalId name wid 0 "\x4E2D\x6587"+        `shouldNotBe` deterministicJournalId name wid 0 "\x2E2D\x2587"+      sleepTimerId name wid 0 "\x0101"+        `shouldNotBe` sleepTimerId name wid 0 "\SOH"+      generation0AwakeableId name wid "\x0101"+        `shouldNotBe` generation0AwakeableId name wid "\SOH"+      deterministicCommandId "counter-pm" "\x0101" sourceEventId 0+        `shouldNotBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0++    it "keeps the seed components positional" $ do+      deterministicJournalId (WorkflowName "a") (WorkflowId "b") 0 "s"+        `shouldNotBe` deterministicJournalId (WorkflowName "b") (WorkflowId "a") 0 "s"+      deterministicCommandId "a" "b" sourceEventId 0+        `shouldNotBe` deterministicCommandId "b" "a" sourceEventId 0++    around (withFreshStore fixture) $+      -- End to end: under the old derivation both step names hashed to one+      -- event id, so the second append lost to the store's global event-id+      -- uniqueness and this example returned @Left (DuplicateEvent Nothing)@ —+      -- deterministically, on every retry, until the resume worker's+      -- crash-backoff ladder marked the workflow failed. Now both steps+      -- journal and the workflow completes.+      it "runs a workflow whose step names collided under the old derivation" $ \storeHandle -> do+        counter <- newIORef (0 :: Int)+        let wfName = WorkflowName "unicodeSteps"+            wfId = WorkflowId "us-1"+        outcome <-+          Store.runStoreIO storeHandle $+            runWorkflow wfName wfId (collidingStepWorkflow counter)+        outcome `shouldBe` Right (Completed (1, 2))+        readIORef counter `shouldReturn` 2+        Right firstRecorded <- Store.runStoreIO storeHandle $ stepExists wfName wfId 0 "\x0101"+        firstRecorded `shouldBe` True+        Right secondRecorded <- Store.runStoreIO storeHandle $ stepExists wfName wfId 0 "\SOH"+        secondRecorded `shouldBe` True++  describe "Keiro deterministic id legacy-encoding bridge" $ do+    -- These values were captured by running the pre-UTF-8 implementation at+    -- 7d7a200b in an isolated worktree. Do not regenerate them from the bridge+    -- implementation: they are the independent evidence that it reproduces+    -- deployed identity.+    let sourceEventId = EventId (uuidLiteral "3f2504e0-4f89-51d3-9a0c-0305e82c3301")+        name = WorkflowName "legacy-awake"+        wid = WorkflowId "la-1"++    it "reproduces every captured process-manager command id" $ do+      let commandGoldens =+            [ ("order-1", 0, "ff20892c-6665-5e92-8c99-d1569d2ce629"),+              ("order-1", -1, "4f3aa6bc-b12c-5dae-8eb5-81f6364f41ef"),+              ("Jos\x00E9", 0, "78cbd6e1-c15f-58c3-be0e-14c861de6c85"),+              ("\x4E2D\x6587", 0, "58e6ef7b-a2c9-5e46-b580-db8df2ce72c7"),+              ("\x4E2D\x6587", -1, "f276cf1b-0f5c-5427-a27a-f6d4ad2ca577"),+              ("\x1F600", 0, "ddc163fc-3563-5ae6-a7f8-fbe1af2712b2"),+              ("\x0101", 0, "cfa5de78-8cc7-5eb2-8edd-da847221541d"),+              ("\SOH", 0, "cfa5de78-8cc7-5eb2-8edd-da847221541d"),+              ("\x0169ser", 0, "4fb869b4-d5b7-5c99-8c5d-c4552c5d4115"),+              ("iser", 0, "4fb869b4-d5b7-5c99-8c5d-c4552c5d4115")+            ]+      for_ commandGoldens $ \(correlation, emitIndex, golden) ->+        legacyDeterministicCommandId "counter-pm" correlation sourceEventId emitIndex+          `shouldBe` EventId (uuidLiteral golden)+      legacyDeterministicCommandId "demo-router" "g-\x4E2D\x6587" sourceEventId 0+        `shouldBe` EventId (uuidLiteral "379ebaad-62e1-5265-9605-340789ae6af7")++    it "reproduces every captured deterministic awakeable id" $ do+      preUtf8Generation0AwakeableId name wid "\x627F\x8A8D"+        `shouldBe` AwakeableId (uuidLiteral "c4eb4dfa-4108-577d-8e92-84edb337a48b")+      preUtf8Generation0AwakeableId name wid "caf\x00E9"+        `shouldBe` AwakeableId (uuidLiteral "446e5258-0697-525d-af06-0c2c3911ded7")+      preUtf8Generation0AwakeableId name wid "\x4E2D"+        `shouldBe` AwakeableId (uuidLiteral "7b252ef4-c7c0-579e-8f15-8f26c73196de")+      preUtf8Generation0AwakeableId name wid "-"+        `shouldBe` AwakeableId (uuidLiteral "7b252ef4-c7c0-579e-8f15-8f26c73196de")++    it "keeps ASCII identity stable and moves every non-ASCII capture" $ do+      legacyDeterministicCommandId "counter-pm" "order-1" sourceEventId 0+        `shouldBe` deterministicCommandId "counter-pm" "order-1" sourceEventId 0+      legacyDeterministicCommandId "counter-pm" "\SOH" sourceEventId 0+        `shouldBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0+      legacyDeterministicCommandId "counter-pm" "iser" sourceEventId 0+        `shouldBe` deterministicCommandId "counter-pm" "iser" sourceEventId 0+      for_ ["Jos\x00E9", "\x4E2D\x6587", "\x1F600", "\x0101", "\x0169ser"] $ \correlation ->+        legacyDeterministicCommandId "counter-pm" correlation sourceEventId 0+          `shouldNotBe` deterministicCommandId "counter-pm" correlation sourceEventId 0+      legacyDeterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId (-1)+        `shouldNotBe` deterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId (-1)+      preUtf8Generation0AwakeableId name wid "legacy"+        `shouldBe` generation0AwakeableId name wid "legacy"+      preUtf8Generation0AwakeableId name wid "-"+        `shouldBe` generation0AwakeableId name wid "-"+      for_ ["\x627F\x8A8D", "caf\x00E9", "\x4E2D"] $ \label ->+        preUtf8Generation0AwakeableId name wid label+          `shouldNotBe` generation0AwakeableId name wid label++    it "documents the historical truncation collisions and their UTF-8 separation" $ do+      legacyDeterministicCommandId "counter-pm" "\x0101" sourceEventId 0+        `shouldBe` legacyDeterministicCommandId "counter-pm" "\SOH" sourceEventId 0+      deterministicCommandId "counter-pm" "\x0101" sourceEventId 0+        `shouldNotBe` deterministicCommandId "counter-pm" "\SOH" sourceEventId 0+      legacyDeterministicCommandId "counter-pm" "\x0169ser" sourceEventId 0+        `shouldBe` legacyDeterministicCommandId "counter-pm" "iser" sourceEventId 0+      deterministicCommandId "counter-pm" "\x0169ser" sourceEventId 0+        `shouldNotBe` deterministicCommandId "counter-pm" "iser" sourceEventId 0+      preUtf8Generation0AwakeableId name wid "\x4E2D"+        `shouldBe` preUtf8Generation0AwakeableId name wid "-"+      generation0AwakeableId name wid "\x4E2D"+        `shouldNotBe` generation0AwakeableId name wid "-"++    it "adds a legacy command probe only when the seed moved" $ do+      NonEmpty.toList (deterministicCommandIdProbes "counter-pm" "order-1" sourceEventId 0)+        `shouldBe` [deterministicCommandId "counter-pm" "order-1" sourceEventId 0]+      NonEmpty.toList (deterministicCommandIdProbes "counter-pm" "\x4E2D\x6587" sourceEventId 0)+        `shouldBe` [ deterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId 0,+                     legacyDeterministicCommandId "counter-pm" "\x4E2D\x6587" sourceEventId 0+                   ]++    it "builds one current probe for an ASCII seed" $ do+      let seed = "keiro:probe:ascii"+      NonEmpty.toList (deterministicIdProbes seed)+        `shouldBe` [UUID.V5.generateNamed UUID.V5.namespaceURL (identitySeedBytes seed)]++    it "orders the current and legacy probes for a non-ASCII seed" $ do+      let seed = "keiro:probe:\x4E2D"+      NonEmpty.toList (deterministicIdProbes seed)+        `shouldBe` [ UUID.V5.generateNamed UUID.V5.namespaceURL (identitySeedBytes seed),+                     UUID.V5.generateNamed UUID.V5.namespaceURL (legacySeedBytes seed)+                   ]++  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 2 "sleep:cool")+        `shouldBe` Just ("sleep:cool", Just 2)+      parseSleepPayload+        ( object+            [ "kind" Aeson..= ("keiro.workflow.sleep" :: Text),+              "step" Aeson..= ("sleep:legacy" :: Text)+            ]+        )+        `shouldBe` Just ("sleep:legacy", Nothing)+      parseSleepPayload (object ["kind" Aeson..= ("counter-timeout" :: Text)])+        `shouldBe` Nothing++    it "recovers a legacy payload's generation from its deterministic timer id" $ do+      let name = WorkflowName "wf"+          wid = WorkflowId "w-legacy"+          full = "sleep:cool"+      for_ [0 .. 2] $ \gen ->+        matchSleepTimerGeneration name wid 2 full (sleepTimerId name wid gen full)+          `shouldBe` Just gen++    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", Just 0)+          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 "keeps a due wake_after stable on re-arm and clears it on fire" $ \storeHandle -> do+        counter <- newIORef (0 :: Int)+        let name = WorkflowName "sleep-wake-stable"+            wid = WorkflowId "sws-1"+            registry = Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") 0))+        Right Suspended <-+          Store.runStoreIO storeHandle $+            runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 0)+        Right (Just firstWakeAfter) <-+          Store.runStoreIO storeHandle $+            workflowWakeAfter name wid++        Right rearmed <-+          Store.runStoreIO storeHandle $+            resumeWorkflowsOnce defaultWorkflowResumeOptions registry+        discovered rearmed `shouldBe` 1+        Right (Just secondWakeAfter) <-+          Store.runStoreIO storeHandle $+            workflowWakeAfter name wid+        secondWakeAfter `shouldBe` firstWakeAfter++        fireTime <- getCurrentTime+        Right (Just _) <-+          Store.runStoreIO storeHandle $+            runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing)+        Right clearedWakeAfter <-+          Store.runStoreIO storeHandle $+            workflowWakeAfter name wid+        clearedWakeAfter `shouldBe` Nothing++        Right resumed <-+          Store.runStoreIO storeHandle $+            resumeWorkflowsOnce defaultWorkflowResumeOptions registry+        discovered resumed `shouldBe` 1+        completed resumed `shouldBe` 1+        readIORef counter >>= (`shouldBe` 2)++      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 whose instance row is missing after an arm crash" $ \storeHandle -> do+        let name = WorkflowName "sleep-missing-fire"+            wid = WorkflowId "smf-1"+            body = sleepNamed (StepName "wait") 0+        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body+        Right () <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Tx.statement ("smf-1", "sleep-missing-fire") deleteWorkflowInstanceStmt+        fireTime <- getCurrentTime+        Right (Just _) <-+          Store.runStoreIO storeHandle $+            runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing)+        Right resolved <-+          Store.runStoreIO storeHandle $+            stepExists name wid 0 "sleep:wait"+        resolved `shouldBe` True+        Right (Just recovered) <-+          Store.runStoreIO storeHandle $+            Instance.lookupInstance name wid+        recovered ^. #status `shouldBe` Instance.WfRunning+        Store.runStoreIO storeHandle (runWorkflow name wid body)+          `shouldReturn` Right (Completed ())++      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))+        Right Suspended <-+          Store.runStoreIO storeHandle $+            runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 1)+        threadDelay 1_200_000+        Right boundaryPass <-+          Store.runStoreIO storeHandle $+            resumeWorkflowsOnce defaultWorkflowResumeOptions registry+        discovered boundaryPass `shouldBe` 1+        fireTime <- getCurrentTime+        Right (Just _) <-+          Store.runStoreIO storeHandle $+            runWorkflowTimerWorker Nothing fireTime (\_ -> pure Nothing)+        Right completionPass <-+          Store.runStoreIO storeHandle $+            resumeWorkflowsOnce defaultWorkflowResumeOptions registry+        discovered completionPass `shouldBe` 1+        completed completionPass `shouldBe` 1+        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.Timer batched drain" $ around (withFreshStore fixture) $ do+    -- The single-claim worker drains a backlog at one timer per invocation, so+    -- ten due sleeps take ten poll ticks and the last workflow wakes ticks late.+    -- One drain pass wakes them all, with one requeue-and-gauge preamble instead+    -- of ten.+    it "drains a mixed backlog of sleeps and process-manager timers in one pass" $ \storeHandle -> do+      firedPm <- newIORef ([] :: [Text])+      let sleepers = [1 .. 4 :: Int]+          sleeperName = WorkflowName "drain-sleeper"+          sleeperId i = WorkflowId ("ds-" <> Text.pack (show i))+      for_ sleepers $ \i -> do+        outcome <-+          Store.runStoreIO storeHandle $+            runWorkflow sleeperName (sleeperId i) (sleepNamed (StepName "wait") 0)+        outcome `shouldBe` Right Suspended+      for_ [1 .. 6 :: Int] $ \i ->+        Store.runStoreIO storeHandle (Store.runTransaction (scheduleTimerTx (plainTimerRequest i)))+          `shouldReturn` Right ()+      now <- addUTCTime 1 <$> getCurrentTime+      Right drained <-+        Store.runStoreIO storeHandle $+          drainWorkflowSleepTimers Nothing now 20 $ \row -> do+            liftIO (modifyIORef' firedPm (row ^. #correlationId :))+            pure (Just (EventId sampleUuid2))+      drained `shouldBe` 10+      -- Every sleep actually woke: the completion is journaled, not merely+      -- claimed.+      for_ sleepers $ \i -> do+        Right woke <- Store.runStoreIO storeHandle $ stepExists sleeperName (sleeperId i) 0 "sleep:wait"+        woke `shouldBe` True+      readIORef firedPm >>= \fired -> length fired `shouldBe` 6+      -- Nothing is left claimable.+      Right leftovers <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 (\_ -> pure Nothing)+      leftovers `shouldBe` 0++    it "stops at the batch limit and leaves the rest claimable" $ \storeHandle -> do+      for_ [1 .. 10 :: Int] $ \i ->+        Store.runStoreIO storeHandle (Store.runTransaction (scheduleTimerTx (plainTimerRequest i)))+          `shouldReturn` Right ()+      now <- addUTCTime 1 <$> getCurrentTime+      let fireOne _ = pure (Just (EventId sampleUuid2))+      Right firstBatch <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 3 fireOne+      firstBatch `shouldBe` 3+      Right restBatch <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 fireOne+      restBatch `shouldBe` 7+      -- A limit of zero still runs the preamble but claims nothing, and an+      -- empty backlog costs exactly what a single-claim pass costs.+      Right noneLeft <- Store.runStoreIO storeHandle $ drainDueTimers Nothing now 20 fireOne+      noneLeft `shouldBe` 0++  describe "Keiro.Workflow sleep generation pinning" $ around (withFreshStore fixture) $ do+    it "keeps a stale re-fire on the generation that armed the sleep" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "sleep-generation-pin"+          wid = WorkflowId "sgp-1"+          full = "sleep:cool"+          TimerId generationZeroTimerId = sleepTimerId name wid 0 full+          TimerId generationOneTimerId = sleepTimerId name wid 1 full+          body = do+            seed <- restoreSeed (0 :: Int)+            _ <- step (StepName "work") (liftIO (incrementAndRead counter))+            if seed == 0+              then sleepNamed (StepName "cool") 0 >> continueAsNew (1 :: Int)+              else sleepNamed (StepName "cool") 3600 >> pure seed++      Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body+      claimTime <- getCurrentTime+      Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime+      claimed ^. #timerId `shouldBe` TimerId generationZeroTimerId+      Right (Just _) <-+        Store.runStoreIO storeHandle $+          workflowSleepFireAction claimed++      Right ContinuedAsNew <- Store.runStoreIO storeHandle $ runWorkflow name wid body+      Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid body+      Right (Just generationOneFireAt) <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement generationOneTimerId sleepTimerFireAtStmt++      requeueTime <- getCurrentTime+      Right requeued <-+        Store.runStoreIO storeHandle $+          requeueStuckTimers 0 (addUTCTime 1 requeueTime)+      requeued `shouldBe` 1+      Right (Just staleFire) <-+        Store.runStoreIO storeHandle $+          runWorkflowTimerWorker Nothing (addUTCTime 2 requeueTime) (\_ -> pure Nothing)+      staleFire ^. #timerId `shouldBe` TimerId generationZeroTimerId++      Right generationOneResolved <-+        Store.runStoreIO storeHandle $+          stepExists name wid 1 full+      generationOneResolved `shouldBe` False+      Right (Just instanceRow) <-+        Store.runStoreIO storeHandle $+          Instance.lookupInstance name wid+      instanceRow ^. #status `shouldBe` Instance.WfSuspended+      Right generationZeroStatus <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement generationZeroTimerId sleepTimerStatusStmt+      fmap fst generationZeroStatus `shouldBe` Just "fired"+      Right generationOneStatus <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement generationOneTimerId sleepTimerStatusStmt+      fmap fst generationOneStatus `shouldBe` Just "scheduled"+      Right (Just generationOneFireAtAfter) <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement generationOneTimerId sleepTimerFireAtStmt+      generationOneFireAtAfter `shouldBe` generationOneFireAt+      readIORef counter >>= (`shouldBe` 2)++  describe "Keiro.Workflow wake-lifecycle visibility" $ around (withFreshStore fixture) $ do+    -- Cancelling an awakeable writes no journal entry, so it is the one+    -- wake-source lifecycle transition that would otherwise leave the owning+    -- instance row untouched. It must still leave the workflow discoverable, or+    -- the workflow can never reach its await arm to observe the cancellation.+    it "flips the owner instance to running when its awakeable is cancelled" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "cancel-visible"+          wid = WorkflowId "cv-1"+          opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ())+          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))+      Right Suspended <-+        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+      aid <- readRequiredAwakeableId aidRef+      Right (Just parked) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      parked ^. #status `shouldBe` Instance.WfSuspended+      Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid+      cancelled `shouldBe` True+      Right (Just woken) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      woken ^. #status `shouldBe` Instance.WfRunning+      woken ^. #generation `shouldBe` 0+      now <- getCurrentTime+      Right unfinished <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)+      unfinished `shouldBe` [("cv-1", "cancel-visible")]+      -- The pass re-invokes the workflow; its await arm sees the cancelled row+      -- and throws, which the worker records as a crash attempt.+      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+      (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0)+      Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      crashed ^. #attempts `shouldBe` 1+      fmap Text.unpack (crashed ^. #lastError)+        `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled")++    -- Only the first arm writes wake_after, so a stale re-fire that clears it+    -- erases a hint nothing will rewrite. Only a fresh append is a successful+    -- fire in ADR 7's sense.+    it "leaves a newer sleep's wake hint intact when a stale timer re-fires" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "sleep-refire"+          wid = WorkflowId "sr-2"+      Right Suspended <-+        Store.runStoreIO storeHandle $ runWorkflow name wid (twoSleepWorkflow counter)+      claimTime <- getCurrentTime+      Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime+      claimed ^. #timerId `shouldBe` sleepTimerId name wid 0 (sleepStepName (StepName "first"))+      -- Fire the first sleep, then "crash" before the worker marks the timer+      -- fired: the row stays in `firing` and is requeued below.+      Right firstFire <- Store.runStoreIO storeHandle $ workflowSleepFireAction claimed+      firstFire `shouldSatisfy` isJust+      Right cleared <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid+      cleared `shouldBe` Nothing+      -- The next run replays past the first sleep and arms the second one,+      -- whose insert writes the live wake hint.+      Right Suspended <-+        Store.runStoreIO storeHandle $ runWorkflow name wid (twoSleepWorkflow counter)+      Right (Just liveHint) <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid+      liveHint `shouldSatisfy` (> claimTime)+      requeueTime <- getCurrentTime+      Right requeued <-+        Store.runStoreIO storeHandle $ requeueStuckTimers 0 (addUTCTime 1 requeueTime)+      requeued `shouldBe` 1+      Right (Just stale) <-+        Store.runStoreIO storeHandle $ claimDueTimer (addUTCTime 2 requeueTime)+      (stale ^. #timerId) `shouldBe` (claimed ^. #timerId)+      Right staleFire <- Store.runStoreIO storeHandle $ workflowSleepFireAction stale+      -- Still idempotent: the re-fire reports the same deterministic event id.+      staleFire `shouldBe` firstFire+      Right hintAfter <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid+      hintAfter `shouldBe` Just liveHint+      readIORef counter >>= (`shouldBe` 1)++  describe "Keiro.Workflow exact discovery" $ around (withFreshStore fixture) $ do+    it "hides a workflow parked on an awakeable until it is signalled" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "quiet-awk"+          wid = WorkflowId "qa-1"+          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))+          pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)+      Right Suspended <-+        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+      aid <- readRequiredAwakeableId aidRef+      parkedAt <- getCurrentTime+      Right parked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt)+      parked `shouldBe` []+      -- The whole point: a parked workflow costs a pass nothing at all.+      Right idle <- pass+      idle `shouldBe` emptyResumeSummary+      Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)+      signalled `shouldBe` True+      wokenAt <- getCurrentTime+      Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)+      woken `shouldBe` [("qa-1", "quiet-awk")]+      Right finish <- pass+      (discovered finish, completed finish) `shouldBe` (1, 1)+      doneAt <- getCurrentTime+      Right afterCompletion <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds doneAt)+      afterCompletion `shouldBe` []++    -- The parent is invisible while it waits, but the freshly spawned child is+    -- discovered from the instance row spawnChild writes in the spawn step's+    -- transaction — which is why the resume worker no longer needs a separate+    -- findRunningChildIds seed.+    it "hides a parent parked on a child while still discovering the zero-step child" $ \storeHandle -> do+      let parentName = WorkflowName "quiet-parent"+          parentWid = WorkflowId "qp-1"+          childName = WorkflowName "ship"+          childWid = WorkflowId "ship-quiet"+          registry = Map.singleton parentName (WorkflowDef (\_ -> parentWorkflow childWid))+      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow parentName parentWid (parentWorkflow childWid)+      parkedAt <- getCurrentTime+      Right parked <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt)+      parked `shouldBe` [("ship-quiet", "ship")]+      Right (Completed _) <-+        Store.runStoreIO storeHandle $+          runChildWorkflow defaultWorkflowRunOptions childName childWid shipWorkflow+      wokenAt <- getCurrentTime+      Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)+      woken `shouldBe` [("qp-1", "quiet-parent")]+      Right finish <-+        Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)+      (discovered finish, completed finish) `shouldBe` (1, 1)++    -- Wake-wins ordering. markInstanceSuspendedAwaiting is exactly the write a+    -- run performs after its (now stale) index miss, so calling it directly+    -- after a signal reproduces the race deterministically.+    it "writes running when the wake landed before the suspend write" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "race-wake-first"+          wid = WorkflowId "rwf-1"+          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))+      Right Suspended <-+        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+      aid <- readRequiredAwakeableId aidRef+      Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)+      Right () <-+        Store.runStoreIO storeHandle $+          Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid)+      Right (Just arbitrated) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      arbitrated ^. #status `shouldBe` Instance.WfRunning+      wokenAt <- getCurrentTime+      Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)+      woken `shouldBe` [("rwf-1", "race-wake-first")]+      Right finish <-+        Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)+      completed finish `shouldBe` 1++    -- Suspend-wins ordering: the wake, queued behind the suspend write on the+    -- same per-step lock, flips the instance itself.+    it "flips a suspended instance to running when the wake lands after the suspend write" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "race-suspend-first"+          wid = WorkflowId "rsf-1"+          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))+      Right Suspended <-+        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+      aid <- readRequiredAwakeableId aidRef+      Right () <-+        Store.runStoreIO storeHandle $+          Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid)+      Right (Just parkedRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      parkedRow ^. #status `shouldBe` Instance.WfSuspended+      parkedAt <- getCurrentTime+      Right invisible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt)+      invisible `shouldBe` []+      Right True <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)+      Right (Just wokenRow) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      wokenRow ^. #status `shouldBe` Instance.WfRunning+      Right finish <-+        Store.runStoreIO storeHandle (resumeWorkflowsOnce defaultWorkflowResumeOptions registry)+      completed finish `shouldBe` 1++    it "stays discoverable when a cancel lands before the stale suspend write" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "race-cancel-first"+          wid = WorkflowId "rcf-1"+          opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ())+          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))+      Right Suspended <-+        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+      aid <- readRequiredAwakeableId aidRef+      Right True <- Store.runStoreIO storeHandle $ cancelAwakeable aid+      Right () <-+        Store.runStoreIO storeHandle $+          Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid)+      Right (Just arbitrated) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      arbitrated ^. #status `shouldBe` Instance.WfRunning+      wokenAt <- getCurrentTime+      Right woken <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)+      woken `shouldBe` [("rcf-1", "race-cancel-first")]+      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+      (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0)+      Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      crashed ^. #attempts `shouldBe` 1+      fmap Text.unpack (crashed ^. #lastError)+        `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled")++    it "flips a suspended instance to running when the cancel lands after the suspend write" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "race-cancel-second"+          wid = WorkflowId "rcs-1"+          opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ())+          registry = Map.singleton name (WorkflowDef (\_ -> approvalFlowWithId aidRef))+      Right Suspended <-+        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+      aid <- readRequiredAwakeableId aidRef+      Right () <-+        Store.runStoreIO storeHandle $+          Instance.markInstanceSuspendedAwaiting name wid 0 (awakeableStepPrefix <> awakeableIdText aid)+      Right (Just parked) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      parked ^. #status `shouldBe` Instance.WfSuspended+      parkedAt <- getCurrentTime+      Right invisible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds parkedAt)+      invisible `shouldBe` []+      Right True <- Store.runStoreIO storeHandle $ cancelAwakeable aid+      Right (Just woken) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      woken ^. #status `shouldBe` Instance.WfRunning+      wokenAt <- getCurrentTime+      Right discoveredNow <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds wokenAt)+      discoveredNow `shouldBe` [("rcs-1", "race-cancel-second")]+      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+      (discovered summary, resumed summary, completed summary) `shouldBe` (1, 1, 0)+      Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      crashed ^. #attempts `shouldBe` 1+      fmap Text.unpack (crashed ^. #lastError)+        `shouldSatisfy` maybe False (isInfixOf "WorkflowAwakeableCancelled")++    it "surfaces a due sleep through the wake hint and a fired sleep through running" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "quiet-sleep"+          wid = WorkflowId "qs-1"+      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 60)+      now <- getCurrentTime+      Right early <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds now)+      early `shouldBe` []+      -- Due, but the timer worker has not fired it yet: the suspended arm.+      let dueAt = addUTCTime 61 now+      Right due <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds dueAt)+      due `shouldBe` [("qs-1", "quiet-sleep")]+      Right (Just _) <-+        Store.runStoreIO storeHandle $+          runWorkflowTimerWorker Nothing dueAt (\_ -> pure Nothing)+      Right (Just fired) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      fired ^. #status `shouldBe` Instance.WfRunning+      Right hint <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid+      hint `shouldBe` Nothing+      -- Now discovered through the running arm, with no hint left to expire.+      firedAt <- getCurrentTime+      Right visible <- Store.runStoreIO storeHandle (findUnfinishedWorkflowIds firedAt)+      visible `shouldBe` [("qs-1", "quiet-sleep")]++    -- A crashed workflow stays 'running', so exact discovery keeps returning it;+    -- what paces the retry is claimInstance's next_attempt_at gate, which is+    -- reported distinctly from a live foreign lease.+    it "keeps a crashed workflow discovered while its backoff gate paces retries" $ \storeHandle -> do+      let name = WorkflowName "crash-visible"+          wid = WorkflowId "cvz-1"+          opts =+            defaultWorkflowResumeOptions+              & #maxAttempts+              .~ 3+              & #logEvent+              .~ const (pure ())+          registry = Map.singleton name (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))+          pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry)+      seededAt <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt)+      Right first <- pass+      (discovered first, resumed first, failed first) `shouldBe` (1, 1, 0)+      Right (Just crashed) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      crashed ^. #status `shouldBe` Instance.WfRunning+      crashed ^. #attempts `shouldBe` 1+      Right second <- pass+      (discovered second, paced second, leaseSkipped second) `shouldBe` (1, 1, 0)++    it "a bounded drain loop terminates over a pool that cannot advance" $ \storeHandle -> do+      let crashName = WorkflowName "drain-crash"+          crashWid = WorkflowId "drain-crash-1"+          ghostName = WorkflowName "drain-ghost"+          ghostWid = WorkflowId "drain-ghost-1"+          opts =+            defaultWorkflowResumeOptions+              & #maxAttempts+              .~ 3+              & #logEvent+              .~ const (pure ())+          registry =+            Map.singleton+              crashName+              (WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))+          pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry)+          drain 0 acc = pure acc+          drain n acc = do+            Right summary <- pass+            if advanced summary > 0+              then drain (n - 1 :: Int) (acc <> [summary])+              else pure (acc <> [summary])+      seededAt <- getCurrentTime+      for_ [(crashName, crashWid), (ghostName, ghostWid)] $ \(name, wid) -> do+        Right () <-+          Store.runStoreIO storeHandle $+            appendJournalEntry name wid (StepRecorded "seed" (toJSON True) seededAt)+        pure ()+      passes <- drain 10 []+      length passes `shouldBe` 1+      case passes of+        [summary] -> do+          (discovered summary, resumed summary, unknownName summary, advanced summary)+            `shouldBe` (2, 1, 1, 0)+          unregisteredNames summary `shouldBe` Set.singleton "drain-ghost"+        other -> expectationFailure ("expected one drain pass, got " <> show other)+      Right blocked <- pass+      (discovered blocked, paced blocked, unknownName blocked, advanced blocked)+        `shouldBe` (2, 1, 1, 0)+      unregisteredNames blocked `shouldBe` Set.singleton "drain-ghost"++    it "a bounded drain loop terminates over a due sleep with no timer worker" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "drain-due-sleep"+          wid = WorkflowId "dds-1"+          opts = defaultWorkflowResumeOptions & #logEvent .~ const (pure ())+          registry =+            Map.singleton name (WorkflowDef (\_ -> sleepDemoNamed counter (StepName "wait") (-1)))+          pass = Store.runStoreIO storeHandle (resumeWorkflowsOnce opts registry)+          drain 0 acc = pure acc+          drain n acc = do+            Right summary <- pass+            if advanced summary > 0+              then drain (n - 1 :: Int) (acc <> [summary])+              else pure (acc <> [summary])+      -- Arm the sleep with an already-due fire time. No timer worker ever fires it.+      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow name wid (sleepDemoNamed counter (StepName "wait") (-1))+      readIORef counter `shouldReturn` 1+      passes <- drain 5 []+      length passes `shouldBe` 1+      case passes of+        [summary] ->+          (discovered summary, resumed summary, stillSuspended summary, advanced summary, sleepDue summary)+            `shouldBe` (1, 1, 1, 0, 1)+        other -> expectationFailure ("expected one drain pass, got " <> show other)+      Right blocked <- pass+      (discovered blocked, stillSuspended blocked, advanced blocked, sleepDue blocked)+        `shouldBe` (1, 1, 0, 1)+      -- Replay-only: neither step body re-ran.+      readIORef counter `shouldReturn` 1+      -- The candidate is still discoverable, blocked on the timer worker rather than lost.+      Right (Just row) <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      row ^. #status `shouldBe` Instance.WfSuspended+      Right hint <- Store.runStoreIO storeHandle $ workflowWakeAfter name wid+      hint `shouldSatisfy` isJust++  describe "Keiro.Workflow terminal boundaries" $ around (withFreshStore fixture) $ do+    -- The asymmetry this closes: cancellation stopped a run at the next step+    -- boundary, terminal failure did not. Before the append transaction checked+    -- both markers, this workflow ran step "two" and reported Completed.+    it "stops at the next step boundary when a workflow is failed mid-run" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "self-fail"+          wid = WorkflowId "sf-1"+      outcome <-+        Store.runStoreIO storeHandle $+          runWorkflow name wid (selfFailingWorkflow name wid counter)+      outcome `shouldBe` Right Keiro.Workflow.Failed+      -- Step one's action ran (its side effect is at-least-once at boundaries);+      -- step two's never did.+      readIORef counter `shouldReturn` 1+      -- Step one's own append is the one the in-transaction check has to refuse:+      -- the marker landed *inside* that action, after the pre-action probe had+      -- already passed. Nothing more is journaled into a terminal workflow.+      Right recordedOne <- Store.runStoreIO storeHandle $ stepExists name wid 0 "one"+      recordedOne `shouldBe` False+      Right recordedTwo <- Store.runStoreIO storeHandle $ stepExists name wid 0 "two"+      recordedTwo `shouldBe` False+      Right recorded <-+        Store.runStoreIO storeHandle $+          Store.readStreamForward (StreamName "wf:self-fail-sf-1") (StreamVersion 0) 10+      Right decoded <- pure (traverse (decodeRecorded workflowJournalCodec) (Vector.toList recorded))+      any (\case WorkflowFailed {} -> True; _ -> False) decoded `shouldBe` True+      any (\case StepRecorded "two" _ _ -> True; _ -> False) decoded `shouldBe` False++    it "declines an ordinary append into a cancelled workflow without erroring" $ \storeHandle -> do+      let name = WorkflowName "refuse-cancelled"+          wid = WorkflowId "rc-1"+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCancelled now)+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (StepRecorded "late" (toJSON True) now)+      Right present <- Store.runStoreIO storeHandle $ stepExists name wid 0 "late"+      present `shouldBe` False++    -- A wake source settles its own durable row even when it cannot deliver:+    -- the promise is resolved, the journal entry is not written.+    it "completes an awakeable owned by a failed workflow but journals nothing" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "refuse-signal"+          wid = WorkflowId "rs-1"+      Right Suspended <-+        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+      aid <- readRequiredAwakeableId aidRef+      failedAt <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (WorkflowFailed "ceiling reached" failedAt)+      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+      Right delivered <-+        Store.runStoreIO storeHandle $+          stepExists name wid 0 (awakeableStepPrefix <> awakeableIdText aid)+      delivered `shouldBe` False++    -- The refusal reads the derived failure-marker index row, which+    -- resurrection deletes, so a revived workflow accepts deliveries again by+    -- construction (ADR 8: failure history is immutable, derived state is+    -- revivable).+    it "accepts a wake append again after the workflow is resurrected" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "revive-delivery"+          wid = WorkflowId "rd-1"+      Right Suspended <-+        Store.runStoreIO storeHandle $ runWorkflow name wid (approvalFlowWithId aidRef)+      aid <- readRequiredAwakeableId aidRef+      failedAt <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (WorkflowFailed "ceiling reached" failedAt)+      Right Instance.WorkflowResurrected <-+        Store.runStoreIO storeHandle $ Instance.resurrectFailedWorkflow name wid+      Right signalled <- Store.runStoreIO storeHandle $ signalAwakeable aid ("ok" :: Text)+      signalled `shouldBe` True+      Right delivered <-+        Store.runStoreIO storeHandle $+          stepExists name wid 0 (awakeableStepPrefix <> awakeableIdText aid)+      delivered `shouldBe` True+      Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef))+        `shouldReturn` Right (Completed "ok!")++    -- Defense in depth for the sleep fire: its instance-status guard cannot see+    -- a cancellation whose instance row was already collected, but the append+    -- transaction still refuses. The timer is marked fired regardless, so it is+    -- not requeued forever against a workflow that will never accept it.+    it "marks a sleep timer fired without delivering into a cancelled workflow" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "refuse-sleep"+          wid = WorkflowId "rsl-1"+      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow name wid (sleepDemoNamed counter (StepName "wait") 0)+      cancelledAt <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $ appendJournalEntry name wid (WorkflowCancelled cancelledAt)+      -- Partial GC: the instance row is gone, so the fire action's terminal+      -- guard finds nothing and proceeds to the append.+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement ("rsl-1", "refuse-sleep") deleteWorkflowInstanceStmt+      claimTime <- getCurrentTime+      Right (Just claimed) <- Store.runStoreIO storeHandle $ claimDueTimer claimTime+      Right fired <- Store.runStoreIO storeHandle $ workflowSleepFireAction claimed+      fired `shouldSatisfy` isJust+      Right delivered <- Store.runStoreIO storeHandle $ stepExists name wid 0 "sleep:wait"+      delivered `shouldBe` False++  describe "Keiro.Workflow.Awakeable" $ do+    -- Pure (no-DB) check of the frozen generation-0 compatibility derivation.+    it "reproduces a stable, label-sensitive generation-0 AwakeableId" $ do+      let aid1 = generation0AwakeableId (WorkflowName "w") (WorkflowId "1") "approval"+          aid2 = generation0AwakeableId (WorkflowName "w") (WorkflowId "1") "approval"+          aidOther = generation0AwakeableId (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 (generation0AwakeableId (WorkflowName "sch") (WorkflowId "1") "a")+            aidB = awakeableIdToUuid (generation0AwakeableId (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. The guarded+        -- UPDATE returns the owner coordinates so the caller can flip the+        -- owning instance row in the same transaction.+        Right cancelled <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Awk.cancelAwakeableTx aidB+        cancelled `shouldBe` Just ("sch", "1")+        Right reCancelled <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Awk.cancelAwakeableTx aidB+        reCancelled `shouldBe` Nothing+        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 = generation0AwakeableId 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 = generation0AwakeableId 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 "adopts a pre-UTF-8 generation-0 row for a non-ASCII label" $ \storeHandle -> do+        aidRef <- newIORef Nothing+        let name = WorkflowName "legacy-awake"+            wid = WorkflowId "la-1"+            legacy = AwakeableId (uuidLiteral "c4eb4dfa-4108-577d-8e92-84edb337a48b")+        preUtf8Generation0AwakeableId name wid "\x627F\x8A8D" `shouldBe` legacy+        Right () <-+          Store.runStoreIO storeHandle $+            Store.runTransaction $+              Awk.registerAwakeableTx (awakeableIdToUuid legacy) (unWorkflowName name) (unWorkflowId wid)+        Right Suspended <- Store.runStoreIO storeHandle $ runWorkflow name wid (unicodeApprovalFlowWithId aidRef)+        adopted <- readRequiredAwakeableId aidRef+        adopted `shouldBe` legacy+        Right True <- Store.runStoreIO storeHandle $ signalAwakeable legacy ("ok" :: Text)+        completed <- Store.runStoreIO storeHandle $ runWorkflow name wid (unicodeApprovalFlowWithId 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 awakeable registration" $ around (withFreshStore fixture) $ do+    it "registers the row before a journaled hand-off can expose the id" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "awakeable-signal-gap"+          wid = WorkflowId "asg-1"+      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow name wid (publishAwakeableBeforeAwait aidRef)+      aid <- readRequiredAwakeableId aidRef+      Right (Just pendingRow) <-+        Store.runStoreIO storeHandle $+          Awk.lookupAwakeable (awakeableIdToUuid aid)+      pendingRow ^. #status `shouldBe` Awk.Pending++      Right signalled <-+        Store.runStoreIO storeHandle $+          signalAwakeable aid ("ok" :: Text)+      signalled `shouldBe` True+      Right (Just completedRow) <-+        Store.runStoreIO storeHandle $+          Awk.lookupAwakeable (awakeableIdToUuid aid)+      completedRow ^. #status `shouldBe` Awk.Completed++      let unknown =+            AwakeableId+              (uuidLiteral "00000000-0000-0000-0000-0000000002f2")+      Right unknownSignal <-+        Store.runStoreIO storeHandle $+          signalAwakeable unknown ("forged" :: Text)+      unknownSignal `shouldBe` False++      completed <-+        Store.runStoreIO storeHandle $+          runWorkflow name wid (awaitPublishedAwakeable aidRef)+      completed `shouldBe` Right (Completed "ok")++  describe "Keiro.Workflow awakeable signal race" $ around (withFreshStore fixture) $ do+    it "does not append a value when cancellation wins after the signal pre-read" $ \storeHandle -> do+      aidRef <- newIORef Nothing+      let name = WorkflowName "awakeable-cancel-race"+          wid = WorkflowId "acr-1"+      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow name wid (approvalFlowWithId aidRef)+      aid <- readRequiredAwakeableId aidRef+      Right (Just stalePendingRow) <-+        Store.runStoreIO storeHandle $+          Awk.lookupAwakeable (awakeableIdToUuid aid)+      Right cancelled <- Store.runStoreIO storeHandle $ cancelAwakeable aid+      cancelled `shouldBe` True+      Right signalled <-+        Store.runStoreIO storeHandle $+          signalAwakeableFrom stalePendingRow ("late" :: Text)+      signalled `shouldBe` False+      Right recorded <-+        Store.runStoreIO storeHandle $+          stepExists+            name+            wid+            0+            (awakeableStepPrefix <> awakeableIdText aid)+      recorded `shouldBe` False+      Store.runStoreIO storeHandle (runWorkflow name wid (approvalFlowWithId aidRef))+        `shouldThrow` (== WorkflowAwakeableCancelled aid)++  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.Child durable failed delivery" $ around (withFreshStore fixture) $ do+    it "delivers a persisted child failure after the parent rotates past the failure journal" $ \storeHandle -> do+      let childWid = WorkflowId "failed-before-rotation"+          parentName = WorkflowName "parent-failure-rotation"+          parentId = WorkflowId "p-failure-rotation"+          registry =+            Map.fromList+              [ (parentName, WorkflowDef (\_ -> failedChildBeforeRotation childWid)),+                (WorkflowName "ship", WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure ("" :: Text)))+              ]+          opts = defaultWorkflowResumeOptions & #maxAttempts .~ 1+      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow parentName parentId (failedChildBeforeRotation childWid)+      Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+      failed summary `shouldBe` 1+      Right (Just childRow) <-+        Store.runStoreIO storeHandle $+          Child.lookupChild "failed-before-rotation" "ship"+      childRow ^. #status `shouldBe` Child.ChildFailed+      childRow ^. #failureReason+        `shouldSatisfy` maybe False ("SimulatedCrash" `Text.isInfixOf`)+      Right failedOnGenerationZero <-+        Store.runStoreIO storeHandle $+          stepExists+            parentName+            parentId+            0+            (childResultStepName childWid)+      failedOnGenerationZero `shouldBe` True++      Right ContinuedAsNew <-+        Store.runStoreIO storeHandle $+          runWorkflow parentName parentId (rotatePastFailedChild childWid)+      Right generation <- Store.runStoreIO storeHandle $ currentGeneration parentName parentId+      generation `shouldBe` 1+      Right failedOnGenerationOne <-+        Store.runStoreIO storeHandle $+          stepExists+            parentName+            parentId+            1+            (childResultStepName childWid)+      failedOnGenerationOne `shouldBe` False++      delivered <-+        Store.runStoreIO storeHandle $+          runWorkflow parentName parentId (catchFailedChildAfterRotation childWid)+      delivered `shouldSatisfy` \case+        Right (Completed reason) -> "SimulatedCrash" `Text.isInfixOf` reason+        _ -> False++  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 "deletes scheduled sleep timers so a collected workflow cannot resurrect" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let name = WorkflowName "gc-scheduled-sleep"+          wid = WorkflowId "gss-1"+          journalStream = workflowGenerationStreamName name wid 0+          TimerId timerUuid = sleepTimerId name wid 0 "sleep:wait"+          body = do+            _ <- step (StepName "before-sleep") (liftIO (incrementAndRead counter))+            sleepNamed (StepName "wait") 3600+      Right Suspended <-+        Store.runStoreIO storeHandle $+          runWorkflow name wid body+      Right timerBeforeGc <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement timerUuid sleepTimerStatusStmt+      fmap fst timerBeforeGc `shouldBe` Just "scheduled"++      cancelledAt <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          appendJournalEntry name wid (WorkflowCancelled cancelledAt)+      gcClock <- getCurrentTime+      Right collected <-+        Store.runStoreIO storeHandle $+          WorkflowGc.gcWorkflowsOnce+            (addUTCTime 1 gcClock)+            WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10}+      collected `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 1}++      Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream+      Right timerAfterGc <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement timerUuid sleepTimerStatusStmt+      timerAfterGc `shouldBe` Nothing++      Right noClaim <-+        Store.runStoreIO storeHandle $+          runWorkflowTimerWorker Nothing (addUTCTime 7200 gcClock) (\_ -> pure Nothing)+      noClaim `shouldBe` Nothing+      Right Nothing <- Store.runStoreIO storeHandle $ Instance.lookupInstance name wid+      Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream+      readIORef counter >>= (`shouldBe` 1)++    it "cancels a sleep fire when a terminal instance survives partial GC" $ \storeHandle -> do+      let name = WorkflowName "gc-terminal-fire"+          wid = WorkflowId "gtf-1"+          full = "sleep:wait"+          timerId@(TimerId timerUuid) = sleepTimerId name wid 0 full+          journalStream = workflowGenerationStreamName name wid 0+      now <- getCurrentTime+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $ do+            Instance.upsertInstanceTx "gtf-1" "gc-terminal-fire" 0 Instance.WfCancelled Nothing+            void $+              scheduleTimerOnceTx+                TimerRequest+                  { timerId,+                    processManagerName = "gc-terminal-fire",+                    correlationId = "gtf-1",+                    fireAt = now,+                    payload = sleepTimerPayload 0 full+                  }+      Right (Just claimed) <-+        Store.runStoreIO storeHandle $+          runWorkflowTimerWorker Nothing now (\_ -> pure Nothing)+      claimed ^. #timerId `shouldBe` timerId+      Right terminalTimer <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement timerUuid sleepTimerStatusStmt+      fmap fst terminalTimer `shouldBe` Just "cancelled"+      Right Nothing <- Store.runStoreIO storeHandle $ Store.lookupStreamId journalStream+      Right resolved <-+        Store.runStoreIO storeHandle $+          stepExists name wid 0 full+      resolved `shouldBe` False++    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++    -- One failing deletion used to take the whole batch with it, and the+    -- summary claimed everything eligible had been deleted regardless. The+    -- sabotage is a workflow id long enough that its derived journal stream+    -- name exceeds kiroku's 512-byte limit, so `hardDeleteStream` throws+    -- `StreamNameTooLong` every time — no timing, no concurrency.+    it "isolates a failing deletion, reports it honestly, and re-scans it" $ \storeHandle -> do+      counter <- newIORef (0 :: Int)+      let healthyName = WorkflowName "gc-isolated"+          healthyId = WorkflowId "gi-1"+          sabotagedId = Text.replicate 600 "x"+          policy = WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10}+      Right (Completed _) <-+        Store.runStoreIO storeHandle $+          runWorkflow healthyName healthyId (demoWorkflow counter)+      -- Written directly: a workflow with this id could never journal anything,+      -- because the same limit rejects its appends. GC eligibility reads only+      -- the instance row, which is exactly the surface under test.+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement (sabotagedId, "gc-sabotaged") insertTerminalGcInstanceStmt+      now <- getCurrentTime+      Right summary <-+        Store.runStoreIO storeHandle $+          WorkflowGc.gcWorkflowsOnce (addUTCTime 1 now) policy+      summary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 2, deleted = 1}+      -- The healthy workflow was collected despite the other one failing.+      Right healthyGone <- Store.runStoreIO storeHandle $ Instance.lookupInstance healthyName healthyId+      healthyGone `shouldBe` Nothing+      -- The sabotaged one kept its instance row, so it stays eligible: a+      -- partially collected workflow converges instead of leaking.+      Right nextSummary <-+        Store.runStoreIO storeHandle $+          WorkflowGc.gcWorkflowsOnce (addUTCTime 2 now) policy+      nextSummary `shouldBe` WorkflowGc.WorkflowGcSummary {scanned = 1, deleted = 0}++    it "keeps the gc loop alive across a pass it cannot finish" $ \storeHandle -> do+      logged <- newIORef ([] :: [Text])+      let sabotagedId = Text.replicate 600 "x"+          policy = WorkflowGc.WorkflowGcPolicy {retention = 0, batchSize = 10}+          -- A bare `forever` loop would report at most once and then die on the+          -- error; per-pass isolation keeps it reporting every tick.+          waitForTwoPasses = timeout 5_000_000 $ do+            let go = do+                  seen <- readIORef logged+                  if length seen >= 2+                    then pure ()+                    else threadDelay 20_000 >> go+            go+      Right () <-+        Store.runStoreIO storeHandle $+          Store.runTransaction $+            Tx.statement (sabotagedId, "gc-loop-sabotaged") insertTerminalGcInstanceStmt+      worker <-+        forkIO . void . Store.runStoreIO storeHandle $+          WorkflowGc.runWorkflowGcWorkerWith policy 20_000 (\msg -> modifyIORef' logged (msg :))+      reported <- waitForTwoPasses `finally` killThread worker+      reported `shouldBe` Just ()+      messages <- readIORef logged+      messages `shouldSatisfy` all ("stay eligible" `Text.isInfixOf`)++-- | One resume pass over four candidates that exercise every outcome a pass+-- can report: one that completes, one that suspends, one whose name is absent+-- from the registry, and one that crashes into terminal failure at a ceiling of+-- one attempt. Parameterised by @maxConcurrentAdvances@ so the sequential and+-- concurrent runs are literally the same scenario.+runMixedResumePass :: Store.KirokuStore -> Int -> IO ResumeSummary+runMixedResumePass storeHandle concurrency = do+  healthyCounter <- newIORef (0 :: Int)+  let healthyName = WorkflowName "mixed-healthy"+      suspendedName = WorkflowName "mixed-suspended"+      poisonName = WorkflowName "mixed-poison"+      orphanName = WorkflowName "mixed-orphan"+      opts =+        defaultWorkflowResumeOptions+          & #maxAttempts+          .~ 1+          & #maxConcurrentAdvances+          .~ concurrency+          & #logEvent+          .~ const (pure ())+      registry =+        Map.fromList+          [ (healthyName, WorkflowDef (\_ -> threeStep healthyCounter)),+            (suspendedName, WorkflowDef (\_ -> neverArmingWorkflow)),+            (poisonName, WorkflowDef (\_ -> liftIO (throwIO SimulatedCrash) *> pure (0 :: Int)))+          ]+  now <- getCurrentTime+  for_ [healthyName, suspendedName, poisonName, orphanName] $ \name ->+    Store.runStoreIO+      storeHandle+      (appendJournalEntry name (WorkflowId "mixed-1") (StepRecorded "seed" (toJSON True) now))+      `shouldReturn` Right ()+  Right summary <- Store.runStoreIO storeHandle $ resumeWorkflowsOnce opts registry+  readIORef healthyCounter `shouldReturn` 3+  pure summary++expectedMixedResumeSummary :: ResumeSummary+expectedMixedResumeSummary =+  emptyResumeSummary+    { discovered = 4,+      advanced = 2,+      resumed = 3,+      completed = 1,+      stillSuspended = 1,+      unknownName = 1,+      failed = 1,+      unregisteredNames = Set.singleton "mixed-orphan"+    }++-- | Do two recorded execution windows intersect? Used to tell a concurrent+-- resume pass from a sequential one without measuring throughput.+windowsOverlap :: [(Text, UTCTime, UTCTime)] -> Bool+windowsOverlap = \case+  [(_, startA, endA), (_, startB, endB)] -> startA < endB && startB < endA+  _ -> False++-- | 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))++forceWorkflowLeaseStmt :: Statement (Text, Text, Text, UTCTime) ()+forceWorkflowLeaseStmt =+  preparable+    """+    UPDATE keiro.keiro_workflows+    SET leased_by = $3,+        lease_expires_at = $4,+        updated_at = now()+    WHERE workflow_id = $1+      AND workflow_name = $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++-- | 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)++-- | A workflow with one durable side effect before a switchable failure and+-- one durable side effect after it. Resurrection tests use the counter to prove+-- the recorded prefix never executes again.+recoverableWorkflow ::+  (Workflow :> es, IOE :> es) =>+  IORef Bool ->+  IORef Int ->+  Eff es Int+recoverableWorkflow shouldCrash counter = do+  _ <- step (StepName "durable-prefix") (liftIO (incrementAndRead counter))+  crashing <- liftIO (readIORef shouldCrash)+  when crashing (liftIO (throwIO SimulatedCrash))+  step (StepName "durable-tail") (liftIO (incrementAndRead counter))++-- | 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.+-- | Two steps whose names collided under the codepoint-truncating id+-- derivation: U+0101 and U+0001 both hashed as the single byte @0x01@, so the+-- second step's journal append was rejected as a duplicate event id.+collidingStepWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es (Int, Int)+collidingStepWorkflow counter = do+  a <- step (StepName "\x0101") (liftIO (incrementAndRead counter))+  b <- step (StepName "\SOH") (liftIO (incrementAndRead counter))+  pure (a, b)++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 <> "!"))++unicodeApprovalFlowWithId :: (Workflow :> es, Store :> es, IOE :> es) => IORef (Maybe AwakeableId) -> Eff es Text+unicodeApprovalFlowWithId ref = do+  (aid, await) <- awakeableNamed (StepName "\x627F\x8A8D")+  liftIO (writeIORef ref (Just aid))+  v <- await+  step (StepName "use") (pure (v <> "!"))++publishAwakeableBeforeAwait ::+  forall es.+  (Workflow :> es, Store :> es, IOE :> es) =>+  IORef (Maybe AwakeableId) ->+  Eff es ()+publishAwakeableBeforeAwait ref = do+  (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate")+  _ <-+    step (StepName "publish") $ do+      liftIO (writeIORef ref (Just aid))+  (_ :: ()) <- awaitStep (StepName "hold") (pure ())+  pure ()++awaitPublishedAwakeable ::+  (Workflow :> es, Store :> es, IOE :> es) =>+  IORef (Maybe AwakeableId) ->+  Eff es Text+awaitPublishedAwakeable ref = do+  (aid, await) <- awakeableNamed (StepName "gate")+  _ <-+    step (StepName "publish") $ do+      liftIO (writeIORef ref (Just aid))+  await++snapshotUnsignalledAwakeable ::+  (Workflow :> es, Store :> es, IOE :> es) =>+  IORef (Maybe AwakeableId) ->+  Eff es Text+snapshotUnsignalledAwakeable ref = do+  (aid, await) <- awakeableNamed (StepName "gate")+  liftIO (writeIORef ref (Just aid))+  await++snapshotShadowedAwakeable :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text+snapshotShadowedAwakeable = do+  (aid, await) <- awakeableNamed (StepName "gate")+  _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text)))+  await++snapshotStaleAwakeablePhaseOne ::+  forall es.+  (Workflow :> es, Store :> es, IOE :> es) =>+  IORef (Maybe AwakeableId) ->+  Eff es ()+snapshotStaleAwakeablePhaseOne ref = do+  (aid, _await :: Eff es Text) <- awakeableNamed (StepName "gate")+  liftIO (writeIORef ref (Just aid))+  _ <- step (StepName "mid") (void (signalAwakeable aid ("payload" :: Text)))+  (_ :: ()) <- awaitStep (StepName "hold") (pure ())+  pure ()++snapshotStaleAwakeablePhaseTwo :: (Workflow :> es, Store :> es, IOE :> es) => Eff es Text+snapshotStaleAwakeablePhaseTwo = do+  (_aid, await) <- awakeableNamed (StepName "gate")+  _ <- step (StepName "mid") (pure ())+  await++snapshotStaleChildPhaseOne ::+  (Workflow :> es, Store :> es, IOE :> es, Error Store.StoreError :> es) =>+  WorkflowId ->+  Eff es ()+snapshotStaleChildPhaseOne childWid = do+  _h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow+  _ <-+    step (StepName "drive") $+      void (runChildWorkflow defaultWorkflowRunOptions (WorkflowName "snapshot-child") childWid shipWorkflow)+  (_ :: ()) <- awaitStep (StepName "hold") (pure ())+  pure ()++snapshotStaleChildPhaseTwo ::+  (Workflow :> es, Store :> es, IOE :> es) =>+  WorkflowId ->+  Eff es Text+snapshotStaleChildPhaseTwo childWid = do+  h <- spawnChild (WorkflowName "snapshot-child") childWid shipWorkflow+  _ <- step (StepName "drive") (pure ())+  awaitChild h++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)++-- | Two sleeps on one generation with a step between them: the first is due+-- immediately, the second far in the future. Firing the first and resuming+-- moves the live wake hint onto the second sleep, which is the state a stale+-- re-fire of the first timer must not disturb.+twoSleepWorkflow ::+  (Workflow :> es, Store :> es, IOE :> es) =>+  IORef Int -> Eff es Int+twoSleepWorkflow counter = do+  sleepNamed (StepName "first") 0+  n <- step (StepName "mid") (liftIO (incrementAndRead counter))+  sleepNamed (StepName "second") 3600+  pure n++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++failedChildBeforeRotation ::+  (Workflow :> es, Store :> es) =>+  WorkflowId ->+  Eff es Text+failedChildBeforeRotation childWid = do+  _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow+  awaitStep (StepName "rotation-gate") (pure ())++rotatePastFailedChild ::+  (Workflow :> es, Store :> es) =>+  WorkflowId ->+  Eff es Text+rotatePastFailedChild childWid = do+  _ <- spawnChild (WorkflowName "ship") childWid shipWorkflow+  continueAsNew ()++catchFailedChildAfterRotation ::+  (Workflow :> es, Store :> es, IOE :> es) =>+  WorkflowId ->+  Eff es Text+catchFailedChildAfterRotation childWid = do+  child <- spawnChild (WorkflowName "ship") childWid shipWorkflow+  EffException.catch+    (awaitChild child)+    (\(WorkflowChildFailed _ _ reason) -> pure reason)++-- | 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 ())++-- | Two sequential gates. Journaling the first makes the workflow discoverable+-- again; the resulting re-invocation replays past it and parks on the second,+-- so the run is re-invoked and still suspends.+twoGateWorkflow :: (Workflow :> es, IOE :> es) => IORef Int -> Eff es Int+twoGateWorkflow counter = do+  _ <- step (StepName "s1") (liftIO (incrementAndRead counter))+  (_ :: ()) <- awaitStep (StepName "awk:first") (pure ())+  awaitStep (StepName "awk:second") (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++-- | The failure counterpart of 'selfCancellingWorkflow': step one's action+-- writes this workflow's own terminal failure marker, standing in for the+-- resume worker marking it failed while another runner is mid-run.+selfFailingWorkflow :: (Workflow :> es, Store :> es, IOE :> es) => WorkflowName -> WorkflowId -> IORef Int -> Eff es Int+selfFailingWorkflow name wid counter = do+  _ <-+    step (StepName "one") $ do+      now <- liftIO getCurrentTime+      appendJournalEntry name wid (WorkflowFailed "ceiling reached" now)+      liftIO (incrementAndRead counter)+  step (StepName "two") (liftIO (incrementAndRead counter))++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++prepareDelegatedDeniedInboxRole :: Store.KirokuStore -> IO ()+prepareDelegatedDeniedInboxRole storeHandle = do+  prepared <-+    Store.runStoreIO storeHandle $+      Store.runTransaction $+        Tx.sql $+          ByteString.intercalate+            "\n"+            [ "CREATE TABLE IF NOT EXISTS kiroku.inbox_test_counter (message_id TEXT PRIMARY KEY);",+              "DO $role$ BEGIN",+              "  IF NOT EXISTS (SELECT 1 FROM pg_roles WHERE rolname = 'delegated_inbox_denied') THEN",+              "    CREATE ROLE delegated_inbox_denied LOGIN;",+              "  END IF;",+              "END $role$;",+              "GRANT USAGE ON SCHEMA kiroku, keiro, public TO delegated_inbox_denied;",+              "GRANT SELECT, INSERT, UPDATE, DELETE ON ALL TABLES IN SCHEMA kiroku, public TO delegated_inbox_denied;",+              "GRANT USAGE, SELECT, UPDATE ON ALL SEQUENCES IN SCHEMA kiroku, public TO delegated_inbox_denied;",+              "GRANT EXECUTE ON ALL FUNCTIONS IN SCHEMA kiroku, public TO delegated_inbox_denied;",+              "REVOKE ALL PRIVILEGES ON TABLE keiro.keiro_inbox FROM delegated_inbox_denied;"+            ]+  either (fail . show) pure prepared++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,+      rejectedAt = Nothing,+      rejection = 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 DelegatedOneShotEventStream = EventStream (HsPred '[] CounterCommand) '[] DelegatedOneShotState CounterCommand CounterEvent++type ValidatedDelegatedOneShotEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] DelegatedOneShotState 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)++instance CanonicalStateShape CounterState++data DelegatedOneShotState+  = DelegatedReady+  | DelegatedDone+  deriving stock (Generic, Eq, Show, Enum, Bounded, Ord)++data CounterStateV2+  = CountingV2+  | PausedV2+  deriving stock (Generic, Eq, Show, Enum, Bounded, Ord)+  deriving anyclass (FromJSON, ToJSON)++instance CanonicalStateShape CounterStateV2++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 CanonicalStateShape PartialSnapshotState++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++delegatedOneShotEventStream :: ValidatedDelegatedOneShotEventStream+delegatedOneShotEventStream =+  mkEventStreamOrThrow+    "delegated-one-shot"+    EventStream+      { transducer =+          SymTransducer+            { edgesOut = \case+                DelegatedReady ->+                  [ Edge+                      { guard = matchInCtor addCtor,+                        update = UKeep,+                        output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)],+                        target = DelegatedDone,+                        mode = Keiki.Live+                      }+                  ]+                DelegatedDone -> [],+              initial = DelegatedReady,+              initialRegs = RNil,+              isFinal = (== DelegatedDone)+            },+        initialState = DelegatedReady,+        initialRegisters = RNil,+        eventCodec = counterCodec,+        resolveStreamName = Stream.streamName,+        snapshotPolicy = Never,+        stateCodec = Nothing+      }++auditedCounterEventStream :: ValidatedCounterEventStream+auditedCounterEventStream =+  mkEventStreamOrThrow+    "counter-audited-only"+    (counterEventStreamDef & #transducer .~ auditedCounterTransducer)++auditedCounterTransducer :: SymTransducer (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent+auditedCounterTransducer =+  SymTransducer+    { edgesOut = \case+        Counting ->+          [ Edge+              { guard = matchInCtor addCtor,+                update = UKeep,+                output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)],+                target = Counting,+                mode = Keiki.Live+              }+          ],+      initial = Counting,+      initialRegs = RNil,+      isFinal = \_ -> False+    }++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,+                mode = Keiki.Live+              }+          ],+      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,+                mode = Keiki.Live+              }+          ],+      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,+                mode = Keiki.Live+              }+          ],+      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,+                mode = Keiki.Live+              },+            Edge+              { guard = ambiguousGuard,+                update = UKeep,+                output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)],+                target = Counting,+                mode = Keiki.Live+              }+          ]+    }+  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,+                    mode = Keiki.Live+                  }+              ],+            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,+                mode = Keiki.Live+              }+          ],+      initial = Counting,+      initialRegs = RCons (Proxy @"lastAmount") 0 RNil,+      isFinal = \_ -> False+    }++foldV1SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream+foldV1SnapshotCounterEventStream =+  mkEventStreamOrThrow "snapshot-counter-fold-v1" foldV1SnapshotCounterEventStreamDef++foldV1SnapshotCounterEventStreamDef :: SnapshotCounterEventStream+foldV1SnapshotCounterEventStreamDef =+  snapshotCounterEventStreamDef+    { transducer = foldV1SnapshotCounterTransducer,+      stateCodec =+        Just+          ( defaultStateCodecWithFold+              @SnapshotCounterRegs+              @CounterState+              (FoldVersion "fold-v1")+              1+          )+    }++foldV2SnapshotCounterEventStream :: ValidatedSnapshotCounterEventStream+foldV2SnapshotCounterEventStream =+  mkEventStreamOrThrow "snapshot-counter-fold-v2" foldV2SnapshotCounterEventStreamDef++foldV2SnapshotCounterEventStreamDef :: SnapshotCounterEventStream+foldV2SnapshotCounterEventStreamDef =+  foldV1SnapshotCounterEventStreamDef+    { transducer = foldV2SnapshotCounterTransducer,+      snapshotPolicy = Every 1,+      stateCodec =+        Just+          ( defaultStateCodecWithFold+              @SnapshotCounterRegs+              @CounterState+              (FoldVersion "fold-v2")+              1+          )+    }++foldV2WithoutFingerprintBumpEventStream :: ValidatedSnapshotCounterEventStream+foldV2WithoutFingerprintBumpEventStream =+  mkEventStreamOrThrow+    "snapshot-counter-fold-v2-without-fingerprint-bump"+    foldV2WithoutFingerprintBumpEventStreamDef++foldV2WithoutFingerprintBumpEventStreamDef :: SnapshotCounterEventStream+foldV2WithoutFingerprintBumpEventStreamDef =+  foldV2SnapshotCounterEventStreamDef+    { stateCodec =+        Just+          ( defaultStateCodecWithFold+              @SnapshotCounterRegs+              @CounterState+              (FoldVersion "fold-v1")+              1+          )+    }++foldV1SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent+foldV1SnapshotCounterTransducer =+  foldSnapshotCounterTransducer+    (inpCtor addCtor #amount)++foldV2SnapshotCounterTransducer :: SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent+foldV2SnapshotCounterTransducer =+  foldSnapshotCounterTransducer+    (inpCtor addCtor #amount K..+ lit 1)++foldSnapshotCounterTransducer ::+  Keiki.Term SnapshotCounterRegs CounterCommand AddFields Int ->+  SymTransducer (HsPred SnapshotCounterRegs CounterCommand) SnapshotCounterRegs CounterState CounterCommand CounterEvent+foldSnapshotCounterTransducer nextLastAmount =+  SymTransducer+    { edgesOut = \case+        Counting ->+          [ Edge+              { guard =+                  PAnd+                    (matchInCtor addCtor)+                    (inpCtor addCtor #amount K..< lit 100),+                update =+                  USet+                    (#lastAmount :: IndexN "lastAmount" SnapshotCounterRegs Int)+                    nextLastAmount,+                output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)],+                target = Counting,+                mode = Keiki.Live+              },+            Edge+              { guard =+                  PAnd+                    (matchInCtor addCtor)+                    ( PAnd+                        (inpCtor addCtor #amount K..>= lit 100)+                        ( inpCtor addCtor #amount+                            .== (proj (#lastAmount :: Keiki.Index SnapshotCounterRegs Int) K..+ lit 100)+                        )+                    ),+                update = UKeep,+                output = [pack addCtor counterAuditedCtor (inpCtor addCtor #amount *: oNil)],+                target = Counting,+                mode = Keiki.Live+              }+          ],+      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,+                mode = Keiki.Live+              }+          ],+      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,+                mode = Keiki.Live+              }+          ],+      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,+                mode = Keiki.Live+              }+          ],+      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,+                mode = Keiki.Live+              }+          ]+    }++-- | 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,+          mode = Keiki.Live+        }++-- | 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,+                mode = Keiki.Live+              }+          ]+    }++-- | 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,+                mode = Keiki.Live+              }+          ]+    }++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,+                mode = Keiki.Live+              }+          ]+        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++data SilentChoiceCommand+  = RejectSilently+  | NoOpSilently+  | UnmatchedSilently+  deriving stock (Generic, Eq, Show)++data CoordinatorCommand+  = CoordinatorAccept !Int+  | CoordinatorReject !Text+  | CoordinatorNoOp !Text+  | CoordinatorUnmatched+  deriving stock (Generic, Eq, Show)++data DomainDispatchInput = DomainDispatchInput !Text ![CoordinatorCommand]+  deriving stock (Generic, Eq, Show)++type SilentChoiceEventStream = EventStream (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent++type ValidatedSilentChoiceEventStream = ValidatedEventStream (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent++type CoordinatorEventStream = EventStream (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent++type ValidatedCoordinatorEventStream = ValidatedEventStream (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent++type RetryDecisionEventStream = EventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent++type ValidatedRetryDecisionEventStream = ValidatedEventStream (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent++data FeasibilityGateCommand+  = TryAccept !Int+  | OpenGate+  deriving stock (Generic, Eq, Show)++data FeasibilityGateEvent+  = GateOpened+  | GateAccepted !Int+  deriving stock (Generic, Eq, Show)++data FeasibilityGateState+  = GateClosed+  | GateOpen+  deriving stock (Generic, Eq, Show, Enum, Bounded, Ord)++type FeasibilityGateEventStream = EventStream (HsPred '[] FeasibilityGateCommand) '[] FeasibilityGateState FeasibilityGateCommand FeasibilityGateEvent++type ValidatedFeasibilityGateEventStream = ValidatedEventStream (HsPred '[] FeasibilityGateCommand) '[] FeasibilityGateState FeasibilityGateCommand FeasibilityGateEvent++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+    }++silentChoiceEventStream :: ValidatedSilentChoiceEventStream+silentChoiceEventStream = mkEventStreamOrThrow "silent-choice-command" silentChoiceEventStreamDef++silentChoiceEventStreamDef :: SilentChoiceEventStream+silentChoiceEventStreamDef =+  EventStream+    { transducer = silentChoiceTransducer,+      initialState = Counting,+      initialRegisters = RNil,+      eventCodec = counterCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++retryDecisionEventStream :: ValidatedRetryDecisionEventStream+retryDecisionEventStream = mkEventStreamOrThrow "retry-domain-decision" retryDecisionEventStreamDef++retryDecisionEventStreamDef :: RetryDecisionEventStream+retryDecisionEventStreamDef =+  EventStream+    { transducer =+        SymTransducer+          { edgesOut = \case+              Draining ->+                [ Edge+                    { guard = matchInCtor addCtor,+                      update = UKeep,+                      output = [pack addCtor counterAddedCtor (inpCtor addCtor #amount *: oNil)],+                      target = Drained,+                      mode = Keiki.Live+                    }+                ]+              Drained ->+                [ Edge+                    { guard = matchInCtor addCtor,+                      update = UKeep,+                      output = [],+                      target = Drained,+                      mode = Keiki.Live+                    }+                ],+            initial = Draining,+            initialRegs = RNil,+            isFinal = const False+          },+      initialState = Draining,+      initialRegisters = RNil,+      eventCodec = counterCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++feasibilityGateEventStream :: ValidatedFeasibilityGateEventStream+feasibilityGateEventStream = mkEventStreamOrThrow "reaction-feasibility-gate" feasibilityGateEventStreamDef++feasibilityGateEventStreamDef :: FeasibilityGateEventStream+feasibilityGateEventStreamDef =+  EventStream+    { transducer = feasibilityGateTransducer,+      initialState = GateClosed,+      initialRegisters = RNil,+      eventCodec = feasibilityGateCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++feasibilityGateTransducer :: SymTransducer (HsPred '[] FeasibilityGateCommand) '[] FeasibilityGateState FeasibilityGateCommand FeasibilityGateEvent+feasibilityGateTransducer =+  SymTransducer+    { edgesOut = \case+        GateClosed ->+          [ Edge+              { guard = matchInCtor tryAcceptCtor,+                update = UKeep,+                output = [],+                target = GateClosed,+                mode = Keiki.Live+              },+            Edge+              { guard = matchInCtor openGateCtor,+                update = UKeep,+                output = [pack openGateCtor gateOpenedCtor oNil],+                target = GateOpen,+                mode = Keiki.Live+              }+          ]+        GateOpen ->+          [ Edge+              { guard = matchInCtor tryAcceptCtor,+                update = UKeep,+                output = [pack tryAcceptCtor gateAcceptedCtor (inpCtor tryAcceptCtor #amount *: oNil)],+                target = GateOpen,+                mode = Keiki.Live+              }+          ],+      initial = GateClosed,+      initialRegs = RNil,+      isFinal = const False+    }++tryAcceptCtor :: InCtor FeasibilityGateCommand AddFields+tryAcceptCtor =+  Keiki.unavailableInCtor+    "TryAccept"+    (\case TryAccept amount -> Just (RCons Proxy amount RNil); OpenGate -> Nothing)+    (\case RCons _ amount RNil -> TryAccept amount)++openGateCtor :: InCtor FeasibilityGateCommand '[]+openGateCtor =+  Keiki.unavailableInCtor+    "OpenGate"+    (\case OpenGate -> Just RNil; TryAccept {} -> Nothing)+    (\RNil -> OpenGate)++gateOpenedCtor :: WireCtor FeasibilityGateEvent ()+gateOpenedCtor =+  Keiki.unavailableWireCtor+    "GateOpened"+    (\case GateOpened -> Just (); GateAccepted {} -> Nothing)+    (const GateOpened)++gateAcceptedCtor :: WireCtor FeasibilityGateEvent (Int, ())+gateAcceptedCtor =+  Keiki.unavailableWireCtor+    "GateAccepted"+    (\case GateAccepted amount -> Just (amount, ()); GateOpened -> Nothing)+    (\case (amount, ()) -> GateAccepted amount)++feasibilityGateCodec :: Codec FeasibilityGateEvent+feasibilityGateCodec =+  Codec+    { eventTypes = EventType "GateOpened" :| [EventType "GateAccepted"],+      eventType = \case GateOpened -> EventType "GateOpened"; GateAccepted {} -> EventType "GateAccepted",+      schemaVersion = 1,+      encode = \case+        GateOpened -> object []+        GateAccepted amount -> object ["amount" Aeson..= amount],+      decode = \(EventType tag) value ->+        case tag of+          "GateOpened" -> Right GateOpened+          "GateAccepted" ->+            case parseEither (withObject "GateAccepted" (.: "amount")) value of+              Right amount -> Right (GateAccepted amount)+              Left message -> Left (fromStringLiteral message)+          _ -> Left ("unknown feasibility gate event type: " <> tag),+      upcasters = []+    }++coordinatorEventStream :: ValidatedCoordinatorEventStream+coordinatorEventStream = mkEventStreamOrThrow "coordinator-domain" coordinatorEventStreamDef++coordinatorEventStreamDef :: CoordinatorEventStream+coordinatorEventStreamDef =+  EventStream+    { transducer =+        SymTransducer+          { edgesOut = \case+              Counting ->+                [ Edge+                    { guard = matchInCtor coordinatorAcceptCtor,+                      update = UKeep,+                      output = [pack coordinatorAcceptCtor counterAddedCtor (inpCtor coordinatorAcceptCtor #amount *: oNil)],+                      target = Counting,+                      mode = Keiki.Live+                    },+                  Edge+                    { guard = matchInCtor coordinatorRejectCtor,+                      update = UKeep,+                      output = [],+                      target = Counting,+                      mode = Keiki.Live+                    },+                  Edge+                    { guard = matchInCtor coordinatorNoOpCtor,+                      update = UKeep,+                      output = [],+                      target = Counting,+                      mode = Keiki.Live+                    }+                ],+            initial = Counting,+            initialRegs = RNil,+            isFinal = const False+          },+      initialState = Counting,+      initialRegisters = RNil,+      eventCodec = counterCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++type CoordinatorMessageFields = '[ '("message", Text)]++coordinatorAcceptCtor :: InCtor CoordinatorCommand AddFields+coordinatorAcceptCtor =+  Keiki.unavailableInCtor+    "CoordinatorAccept"+    (\case CoordinatorAccept amount -> Just (RCons Proxy amount RNil); _ -> Nothing)+    (\case RCons _ amount RNil -> CoordinatorAccept amount)++coordinatorRejectCtor :: InCtor CoordinatorCommand CoordinatorMessageFields+coordinatorRejectCtor =+  Keiki.unavailableInCtor+    "CoordinatorReject"+    (\case CoordinatorReject message -> Just (RCons Proxy message RNil); _ -> Nothing)+    (\case RCons _ message RNil -> CoordinatorReject message)++coordinatorNoOpCtor :: InCtor CoordinatorCommand CoordinatorMessageFields+coordinatorNoOpCtor =+  Keiki.unavailableInCtor+    "CoordinatorNoOp"+    (\case CoordinatorNoOp message -> Just (RCons Proxy message RNil); _ -> Nothing)+    (\case RCons _ message RNil -> CoordinatorNoOp message)++silentChoiceTransducer :: SymTransducer (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent+silentChoiceTransducer =+  SymTransducer+    { edgesOut = \case+        Counting ->+          [ Edge+              { guard = matchInCtor rejectSilentlyCtor,+                update = UKeep,+                output = [],+                target = Counting,+                mode = Keiki.Live+              },+            Edge+              { guard = matchInCtor noOpSilentlyCtor,+                update = UKeep,+                output = [],+                target = Counting,+                mode = Keiki.Live+              }+          ],+      initial = Counting,+      initialRegs = RNil,+      isFinal = \_ -> False+    }++rejectSilentlyCtor :: InCtor SilentChoiceCommand '[]+rejectSilentlyCtor =+  Keiki.unavailableInCtor+    "RejectSilently"+    (\case RejectSilently -> Just RNil; _ -> Nothing)+    (\RNil -> RejectSilently)++noOpSilentlyCtor :: InCtor SilentChoiceCommand '[]+noOpSilentlyCtor =+  Keiki.unavailableInCtor+    "NoOpSilently"+    (\case NoOpSilently -> Just RNil; _ -> Nothing)+    (\RNil -> NoOpSilently)++multiCounterDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent Text Text+multiCounterDomainHandler =+  DomainCommandHandler+    { eventStream = multiCounterEventStream,+      classifySilent = \_ -> error "multiCounterDomainHandler: eventful edge classified as silent"+    }++ambiguousCounterDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] CounterState CounterCommand CounterEvent Text Text+ambiguousCounterDomainHandler =+  DomainCommandHandler+    { eventStream = ambiguousCounterEventStream,+      classifySilent = \_ -> error "ambiguousCounterDomainHandler: no edge should be selected"+    }++silentChoiceDomainHandler :: DomainCommandHandler (HsPred '[] SilentChoiceCommand) '[] CounterState SilentChoiceCommand CounterEvent Text Text+silentChoiceDomainHandler =+  DomainCommandHandler+    { eventStream = silentChoiceEventStream,+      classifySilent = \SilentCommandContext {command = selectedCommand, selectedEdge} ->+        case (selectedCommand, Keiki.edgeIndex selectedEdge) of+          (RejectSilently, 0) -> SilentRejected "edge-0: rejected"+          (NoOpSilently, 1) -> SilentNoOp "edge-1: already complete"+          other -> error ("silentChoiceDomainHandler: unexpected selected edge " <> show other)+    }++retryDecisionDomainHandler :: DomainCommandHandler (HsPred '[] CounterCommand) '[] DrainState CounterCommand CounterEvent Text Text+retryDecisionDomainHandler =+  DomainCommandHandler+    { eventStream = retryDecisionEventStream,+      classifySilent = \SilentCommandContext {state, selectedEdge} ->+        case (state, Keiki.edgeIndex selectedEdge) of+          (Drained, 0) -> SilentNoOp "already drained"+          other -> error ("retryDecisionDomainHandler: unexpected selected edge " <> show other)+    }++feasibilityGateDomainHandler :: DomainCommandHandler (HsPred '[] FeasibilityGateCommand) '[] FeasibilityGateState FeasibilityGateCommand FeasibilityGateEvent Text Text+feasibilityGateDomainHandler =+  DomainCommandHandler+    { eventStream = feasibilityGateEventStream,+      classifySilent = \SilentCommandContext {state, selectedEdge} ->+        case (state, Keiki.edgeIndex selectedEdge) of+          (GateClosed, 0) -> SilentNoOp "gate closed"+          other -> error ("feasibilityGateDomainHandler: unexpected selected edge " <> show other)+    }++strictFeasibilityGateEventStream :: ValidatedFeasibilityGateEventStream+strictFeasibilityGateEventStream =+  mkEventStreamOrThrow+    "reaction-strict-target"+    feasibilityGateEventStreamDef {transducer = strictFeasibilityGateTransducer}++strictFeasibilityGateTransducer :: SymTransducer (HsPred '[] FeasibilityGateCommand) '[] FeasibilityGateState FeasibilityGateCommand FeasibilityGateEvent+strictFeasibilityGateTransducer =+  feasibilityGateTransducer+    { edgesOut = \case+        GateClosed ->+          [ Edge+              { guard = matchInCtor openGateCtor,+                update = UKeep,+                output = [pack openGateCtor gateOpenedCtor oNil],+                target = GateOpen,+                mode = Keiki.Live+              }+          ]+        GateOpen ->+          [ Edge+              { guard = matchInCtor tryAcceptCtor,+                update = UKeep,+                output = [pack tryAcceptCtor gateAcceptedCtor (inpCtor tryAcceptCtor #amount *: oNil)],+                target = GateOpen,+                mode = Keiki.Live+              },+            Edge+              { guard = matchInCtor openGateCtor,+                update = UKeep,+                output = [],+                target = GateOpen,+                mode = Keiki.Live+              }+          ]+    }++coordinatorDomainHandler :: DomainCommandHandler (HsPred '[] CoordinatorCommand) '[] CounterState CoordinatorCommand CounterEvent Text Text+coordinatorDomainHandler =+  DomainCommandHandler+    { eventStream = coordinatorEventStream,+      classifySilent = \SilentCommandContext {command, selectedEdge} ->+        case (command, Keiki.edgeIndex selectedEdge) of+          (CoordinatorReject reason, 1) -> SilentRejected reason+          (CoordinatorNoOp explanation, 2) -> SilentNoOp explanation+          other -> error ("coordinatorDomainHandler: unexpected selected edge " <> show other)+    }++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,+                mode = Keiki.Live+              },+            Edge+              { guard = matchInCtor sSkipCtor,+                update = UKeep,+                output = [],+                target = Counting,+                mode = Keiki.Live+              }+          ],+      initial = Counting,+      initialRegs = RNil,+      isFinal = \_ -> False+    }++sAddCtor :: InCtor SkipCommand AddFields+sAddCtor =+  Keiki.unavailableInCtor+    "SAdd"+    ( \case+        SAdd amount -> Just (RCons Proxy amount RNil)+        SSkip -> Nothing+    )+    ( \case+        RCons _ amount RNil -> SAdd amount+    )++sSkipCtor :: InCtor SkipCommand '[]+sSkipCtor =+  Keiki.unavailableInCtor+    "SSkip"+    ( \case+        SAdd {} -> Nothing+        SSkip -> Just RNil+    )+    ( \case+        RNil -> SSkip+    )++addCtor :: InCtor CounterCommand AddFields+addCtor =+  Keiki.unavailableInCtor+    "Add"+    ( \case+        Add amount -> Just (RCons Proxy amount RNil)+    )+    ( \case+        RCons _ amount RNil -> Add amount+    )++counterAddedCtor :: WireCtor CounterEvent (Int, ())+counterAddedCtor =+  Keiki.unavailableWireCtor+    "CounterAdded"+    ( \case+        CounterAdded amount -> Just (amount, ())+        CounterAudited {} -> Nothing+    )+    ( \case+        (amount, ()) -> CounterAdded amount+    )++counterAuditedCtor :: WireCtor CounterEvent (Int, ())+counterAuditedCtor =+  Keiki.unavailableWireCtor+    "CounterAudited"+    ( \case+        CounterAudited amount -> Just (amount, ())+        CounterAdded {} -> Nothing+    )+    ( \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"++-- * Divert fixture (plan 143: replay-only transitions / black-acuity) -----++type DivertEventStream = EventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent++type ValidatedDivertEventStream = ValidatedEventStream (HsPred '[] DivertCommand) '[] DivertState DivertCommand DivertEvent++data DivertCommand+  = ConfirmDivert !Bool+  deriving stock (Generic, Eq, Show)++newtype DivertEvent+  = DivertConfirmed Bool+  deriving stock (Generic, Eq, Show)++data DivertState+  = DivertHeld+  deriving stock (Generic, Eq, Show, Enum, Bounded, Ord)++type DivertFields = '[ '("acuityBlack", Bool)]++confirmDivertCtor :: InCtor DivertCommand DivertFields+confirmDivertCtor =+  Keiki.unavailableInCtor+    "ConfirmDivert"+    ( \case+        ConfirmDivert acuityBlack -> Just (RCons Proxy acuityBlack RNil)+    )+    ( \case+        RCons _ acuityBlack RNil -> ConfirmDivert acuityBlack+    )++divertConfirmedCtor :: WireCtor DivertEvent (Bool, ())+divertConfirmedCtor =+  Keiki.unavailableWireCtor+    "DivertConfirmed"+    ( \case+        DivertConfirmed acuityBlack -> Just (acuityBlack, ())+    )+    ( \case+        (acuityBlack, ()) -> DivertConfirmed acuityBlack+    )++divertCodec :: Codec DivertEvent+divertCodec =+  Codec+    { eventTypes = EventType "DivertConfirmed" :| [],+      eventType = \_ -> EventType "DivertConfirmed",+      schemaVersion = 1,+      encode = \case+        DivertConfirmed acuityBlack -> object ["acuityBlack" Aeson..= acuityBlack],+      decode = parseDivertEvent,+      upcasters = []+    }++parseDivertEvent :: EventType -> Value -> Either Text DivertEvent+parseDivertEvent _ value =+  case parseEither parser value of+    Right event -> Right event+    Left message -> Left (fromStringLiteral message)+  where+    parser = withObject "DivertConfirmed" $ \objectValue ->+      DivertConfirmed <$> objectValue .: "acuityBlack"++-- | The old rule: confirm any reservation.+divertOldGuard :: HsPred '[] DivertCommand+divertOldGuard = matchInCtor confirmDivertCtor++-- | The tightened rule: confirm only non-black acuity.+divertNewGuard :: HsPred '[] DivertCommand+divertNewGuard =+  PAnd+    (matchInCtor confirmDivertCtor)+    (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit False)++-- | The removed region, @old ∧ ¬new@: exactly black acuity.+divertRemovedRegionGuard :: HsPred '[] DivertCommand+divertRemovedRegionGuard =+  PAnd+    (matchInCtor confirmDivertCtor)+    (inpCtor confirmDivertCtor #acuityBlack .== Keiki.lit True)++divertConfirmEdge ::+  HsPred '[] DivertCommand ->+  Keiki.EdgeMode ->+  Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState+divertConfirmEdge edgeGuard edgeMode =+  Edge+    { guard = edgeGuard,+      update = UKeep,+      output = [pack confirmDivertCtor divertConfirmedCtor (inpCtor confirmDivertCtor #acuityBlack *: oNil)],+      target = DivertHeld,+      mode = edgeMode+    }++divertEventStreamDef ::+  [Edge (HsPred '[] DivertCommand) '[] DivertCommand DivertEvent DivertState] ->+  DivertEventStream+divertEventStreamDef heldEdges =+  EventStream+    { transducer =+        SymTransducer+          { edgesOut = \case+              DivertHeld -> heldEdges,+            initial = DivertHeld,+            initialRegs = RNil,+            isFinal = const False+          },+      initialState = DivertHeld,+      initialRegisters = RNil,+      eventCodec = divertCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++-- | Machine A: the original permissive rule.+permissiveDivertEventStream :: ValidatedDivertEventStream+permissiveDivertEventStream =+  mkEventStreamOrThrow+    "divert-permissive"+    (divertEventStreamDef [divertConfirmEdge divertOldGuard Keiki.Live])++-- | Machine B without the twin: the tightened rule alone.+tightenedDivertEventStream :: ValidatedDivertEventStream+tightenedDivertEventStream =+  mkEventStreamOrThrow+    "divert-tightened"+    (divertEventStreamDef [divertConfirmEdge divertNewGuard Keiki.Live])++-- | Machine B with the replay-only twin carrying the removed region:+-- the tightened rule governs new traffic; black-acuity history keeps+-- its inverting edge.+twinDivertEventStream :: ValidatedDivertEventStream+twinDivertEventStream =+  mkEventStreamOrThrow+    "divert-twin"+    ( divertEventStreamDef+        [ divertConfirmEdge divertNewGuard Keiki.Live,+          divertConfirmEdge divertRemovedRegionGuard Keiki.ReplayOnly+        ]+    )++domainProcessManager ::+  DomainProcessManager+    DomainDispatchInput+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    (HsPred '[] CoordinatorCommand)+    '[]+    CounterState+    CoordinatorCommand+    CounterEvent+    Text+    Text+domainProcessManager =+  DomainProcessManager+    { name = "domain-pm",+      correlate = \(DomainDispatchInput correlationId _) -> correlationId,+      eventStream = counterEventStream,+      streamFor = \correlationId -> stream ("domain-pm:" <> correlationId),+      targetHandler = coordinatorDomainHandler,+      targetProjections = const [],+      handle = \(DomainDispatchInput correlationId targetCommands) ->+        ProcessManagerAction+          { command = Add 1,+            commands =+              Prelude.zipWith+                (\targetIndex targetCommand -> PMCommand {target = stream ("domain-pm-target:" <> correlationId <> ":" <> Text.pack (show targetIndex)), command = targetCommand})+                [0 :: Int ..]+                targetCommands,+            timers = []+          }+    }++domainRouter ::+  DomainRouter+    DomainDispatchInput+    (HsPred '[] CoordinatorCommand)+    '[]+    CounterState+    CoordinatorCommand+    CounterEvent+    Text+    Text+    es+domainRouter =+  DomainRouter+    { name = "domain-router",+      key = \(DomainDispatchInput correlationId _) -> correlationId,+      resolve = \(DomainDispatchInput correlationId targetCommands) ->+        pure+          ( Prelude.zipWith+              (\targetIndex targetCommand -> PMCommand {target = stream ("domain-router-target:" <> correlationId <> ":" <> Text.pack (show targetIndex)), command = targetCommand})+              [0 :: Int ..]+              targetCommands+          ),+      targetHandler = coordinatorDomainHandler,+      targetProjections = const []+    }++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 = []+            }+    }++type CounterReactionInput = (Text, Reaction.ReactionPlan CounterCommand CounterCommand)++counterReactionManager ::+  Reaction.ReactiveProcessManager+    CounterReactionInput+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    Text+    Text+counterReactionManager =+  Reaction.ReactiveProcessManager+    "counter-reaction"+    Prelude.fst+    multiCounterDomainHandler+    (\correlationId -> stream ("reaction-saga:" <> correlationId))+    counterEventStream+    (const [])+    Prelude.snd++type SilentReactionInput = (Text, Reaction.ReactionPlan SilentChoiceCommand CounterCommand)++silentReactionManager ::+  Reaction.ReactiveProcessManager+    SilentReactionInput+    (HsPred '[] SilentChoiceCommand)+    '[]+    CounterState+    SilentChoiceCommand+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    Text+    Text+silentReactionManager =+  Reaction.ReactiveProcessManager+    "silent-reaction"+    Prelude.fst+    silentChoiceDomainHandler+    (\correlationId -> stream ("reaction-silent-saga:" <> correlationId))+    counterEventStream+    (const [])+    Prelude.snd++retryTargetReactionManager ::+  Reaction.ReactiveProcessManager+    CounterReactionInput+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    DrainState+    CounterCommand+    CounterEvent+    Text+    Text+retryTargetReactionManager =+  Reaction.ReactiveProcessManager+    "retry-target-reaction"+    Prelude.fst+    multiCounterDomainHandler+    (\correlationId -> stream ("reaction-retry-saga:" <> correlationId))+    retryDecisionEventStream+    (const [])+    Prelude.snd++type StrictTargetReactionInput = (Text, Reaction.ReactionPlan CounterCommand FeasibilityGateCommand)++strictTargetReactionManager ::+  Reaction.ReactiveProcessManager+    StrictTargetReactionInput+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    (HsPred '[] FeasibilityGateCommand)+    '[]+    FeasibilityGateState+    FeasibilityGateCommand+    FeasibilityGateEvent+    Text+    Text+strictTargetReactionManager =+  Reaction.ReactiveProcessManager+    "strict-target-reaction"+    Prelude.fst+    multiCounterDomainHandler+    (\correlationId -> stream ("reaction-strict-saga:" <> correlationId))+    strictFeasibilityGateEventStream+    (const [])+    Prelude.snd++unicodeCounterProcessManager ::+  ProcessManager+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+    (HsPred '[] CounterCommand)+    '[]+    CounterState+    CounterCommand+    CounterEvent+unicodeCounterProcessManager =+  counterProcessManager+    { name = "unicode-pm",+      correlate = const "\x4E2D\x6587-42",+      streamFor = const (stream "pm:counter-unicode"),+      handle = \case+        CounterAdded amount ->+          ProcessManagerAction+            { command = Add amount,+              commands = [PMCommand {target = stream "counter-target-unicode", command = Add amount}],+              timers = []+            }+        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)++reactionTimerFailureTriggerSql :: ByteString+reactionTimerFailureTriggerSql =+  """+  CREATE OR REPLACE FUNCTION keiro.fail_reaction_timer()+  RETURNS trigger LANGUAGE plpgsql AS $$+  BEGIN+    IF NEW.process_manager_name = 'reaction-fail' THEN+      RAISE EXCEPTION 'injected reaction timer failure';+    END IF;+    RETURN NEW;+  END;+  $$;+  CREATE TRIGGER fail_reaction_timer+    BEFORE INSERT OR UPDATE ON keiro.keiro_timers+    FOR EACH ROW EXECUTE FUNCTION keiro.fail_reaction_timer();+  """  -- | An ordinary (non-sleep) process-manager timer, already due, distinguished -- only by index. Used to build a drainable backlog.